ME WANT COOKIES

This commit is contained in:
nek0 2019-09-18 15:24:23 +02:00
parent 20a1a8e888
commit 63335d41ae
7 changed files with 152 additions and 15 deletions

View file

@ -20,8 +20,10 @@ executable matebeamter
main-is: Main.hs main-is: Main.hs
other-modules: API other-modules: API
, Client , Client
, ClientAuth
, Util , Util
, Hash , Hash
, Session
, Types , Types
, Types.Page , Types.Page
, Types.Reader , Types.Reader
@ -48,11 +50,15 @@ executable matebeamter
, blaze-markup , blaze-markup
, text , text
, bytestring , bytestring
, hashable
, warp , warp
, wai , wai
, wai-logger , wai-logger
, wai-session
, http-client , http-client
, http-api-data , http-api-data
, http-types
, cookie
, mtl , mtl
, i18n , i18n
, cookie , cookie
@ -60,6 +66,9 @@ executable matebeamter
, random-bytestring , random-bytestring
, base64-bytestring , base64-bytestring
, cryptonite , cryptonite
, stm
, stm-containers
, vault
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -50,6 +50,7 @@ mateApi = Proxy
productStockRefill :<|> productStockRefill :<|>
productStockUpdate :<|> productStockUpdate :<|>
productList :<|> productList :<|>
productShortList :<|>
buy :<|> buy :<|>

12
src/ClientAuth.hs Normal file
View file

@ -0,0 +1,12 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module ClientAuth where
import Servant.API (AuthProtect)
import Servant.Client.Core
type instance AuthClientData (AuthProtect "header-auth") = String
authenticateReq :: String -> Request -> Request
authenticateReq s req = addHeader "Authentication" s req

View file

@ -4,6 +4,7 @@ module Control.User where
import Servant import Servant
import Servant.Client import Servant.Client
import Servant.Client.Core.Auth
import Servant.Server import Servant.Server
import Data.String (fromString) import Data.String (fromString)
@ -14,6 +15,8 @@ import Control.Monad (void)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Types.Status
-- imports from "mateamt" -- imports from "mateamt"
import qualified "mateamt" API as MA import qualified "mateamt" API as MA
@ -23,9 +26,11 @@ import qualified "mateamt" Types as MT
import Types import Types
import Client import Client
import ClientAuth
import View import View
import Hash import Hash
import API import API
import Util
userSelectControl :: UserHandler UserSelectPage userSelectControl :: UserHandler UserSelectPage
userSelectControl = do userSelectControl = do
@ -57,12 +62,39 @@ userNewPostControl us@(MT.UserSubmit ident email pass) = do
{ MT.userSubmitPassHash = hashedPass { MT.userSubmitPassHash = hashedPass
}) })
backend backend
throwError $ err303 redirect303 userSelectLink
{ errHeaders = [
("Location", "/" <> (fromString $ show $ linkURI $ userSelectLink))
]
}
userOverviewControl :: Int -> UserHandler UserOverviewPage userOverviewControl :: Int -> UserHandler UserOverviewPage
userOverviewControl uid = do userOverviewControl uid = do
error "Not yet implemented" (ReadState l10n backend _) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
backend
eproducts <- liftIO $ runClientM
(productShortList Nothing)
backend
case (euser, eproducts) of
(Right ud, Right prods) ->
return $ userOverviewPage l10n loc ud prods
(Left uerr, Right _) -> case uerr of
FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401
then
redirect303 authLink
else
throwError $ err500
{ errBody = fromString (show uerr)
}
_ ->
throwError $ err500
{ errBody = fromString (show uerr)
}
(Right _, Left perr) ->
throwError $ err500
{ errBody = fromString (show perr)
}
(Left uerr, Left perr) ->
throwError $ err500
{ errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr)
}

View file

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Servant import Servant
@ -6,33 +8,49 @@ import Servant.Client
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Logger import Network.Wai.Logger
import Network.Wai.Session
import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client hiding (Proxy)
import Web.Cookie (defaultSetCookie)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Text.I18n import Data.Text.I18n
import Data.Text.I18n.Po import Data.Text.I18n.Po
import Data.ByteString (ByteString)
import qualified Data.Vault.Lazy as V
-- internal imports -- internal imports
import API import API
import Types import Types
import View import View
import Control import Control
import Session
main :: IO () main :: IO ()
main = do main = do
manager <- newManager defaultManagerSettings manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales" (l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
sessKey <- V.newKey :: IO (V.Key (Session IO ByteString ByteString))
let settings = setPort 3000 $ setLogger ilog defaultSettings let settings = setPort 3000 $ setLogger ilog defaultSettings
sessMap = sessionMap
initState = ReadState initState = ReadState
-- { rsManager = manager -- { rsManager = manager
{ rsL10n = l10n { rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "") , rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams , rsHashParams = recommendedHashParams
} }
cookieMiddleware = withSession
(sessionStore genSessionId sessMap)
"mateamt-cookies"
defaultSetCookie
sessKey
runSettings settings (userApp initState) runSettings settings (userApp initState)
userApp initState = serveWithContext userApi (EmptyContext) $ userApp initState = serveWithContext userApi (EmptyContext) $

60
src/Session.hs Normal file
View file

@ -0,0 +1,60 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Session where
import Network.Wai.Session
import Control.Monad (liftM)
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import qualified StmContainers.Map as SMap
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (fromJust)
import Data.ByteString (ByteString)
import Data.Hashable
sessionMap = unsafePerformIO SMap.newIO
sessionStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value)), (key2 -> value -> IO ()))
sessionStore genKey inmap =
mapStore genKey inmap
where
mapStore
:: IO ByteString
-> SMap.Map ByteString (SMap.Map ByteString ByteString)
-> SessionStore IO ByteString ByteString
-- -> IO ((key2 -> IO (Maybe value1)), (key2 -> value1 -> IO ()))
mapStore gen map = (\inkey ->
case inkey of
Just k -> do
mcmap <- atomically $ SMap.lookup k map
case mcmap of
Just cmap ->
return $ (sessionMapFromSTMMap cmap, genKey)
Nothing -> (mapStore genKey map) Nothing
Nothing -> do
nkey <- gen
nmap <- atomically $ SMap.new
atomically $ SMap.insert nmap nkey map
cmap <- fromJust <$> (atomically $ SMap.lookup nkey map)
return $ (sessionMapFromSTMMap cmap, gen)
)
sessionMapFromSTMMap
:: SMap.Map ByteString ByteString
-> Session IO ByteString ByteString
sessionMapFromSTMMap inmap =
( \k -> atomically $ SMap.lookup k inmap
, \k v -> atomically $ SMap.insert v k inmap
)

View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Util where module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
@ -18,19 +19,12 @@ import Data.List.Split (chunksOf)
import Data.String (fromString) import Data.String (fromString)
import Control.Monad.Error
import Web.Cookie import Web.Cookie
import Text.Printf (printf) import Text.Printf (printf)
authenticateReq
:: ToHttpApiData a
=> a
-> Servant.Client.Core.Request.Request
-> Servant.Client.Core.Request.Request
authenticateReq s req = addHeader "Authentication" s req
type instance AuthClientData (AuthProtect "header-auth") = String
setCookie setCookie
:: SetCookie :: SetCookie
-> Request -> Request
@ -47,3 +41,14 @@ formatMoney amount = pre <> t <> "," <> c
c = fromString $ snd sp c = fromString $ snd sp
sp = tail <$> sp = tail <$>
break (== '.') (printf "%.2f" (abs amount)) break (== '.') (printf "%.2f" (abs amount))
redirect303
:: MonadError ServerError m
=> Link
-> m a
redirect303 link =
throwError $ err303
{ errHeaders =
[ ("Location", "/" <> (fromString $ show $ linkURI $ link))
]
}