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

View File

@ -50,6 +50,7 @@ mateApi = Proxy
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
productShortList :<|>
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.Client
import Servant.Client.Core.Auth
import Servant.Server
import Data.String (fromString)
@ -14,6 +15,8 @@ import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Types.Status
-- imports from "mateamt"
import qualified "mateamt" API as MA
@ -23,9 +26,11 @@ import qualified "mateamt" Types as MT
import Types
import Client
import ClientAuth
import View
import Hash
import API
import Util
userSelectControl :: UserHandler UserSelectPage
userSelectControl = do
@ -57,12 +62,39 @@ userNewPostControl us@(MT.UserSubmit ident email pass) = do
{ MT.userSubmitPassHash = hashedPass
})
backend
throwError $ err303
{ errHeaders = [
("Location", "/" <> (fromString $ show $ linkURI $ userSelectLink))
]
}
redirect303 userSelectLink
userOverviewControl :: Int -> UserHandler UserOverviewPage
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
import Servant
@ -6,33 +8,49 @@ import Servant.Client
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import Network.Wai.Session
import Network.HTTP.Client hiding (Proxy)
import Web.Cookie (defaultSetCookie)
import Control.Monad.Reader
import Data.Text.I18n
import Data.Text.I18n.Po
import Data.ByteString (ByteString)
import qualified Data.Vault.Lazy as V
-- internal imports
import API
import Types
import View
import Control
import Session
main :: IO ()
main = do
manager <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do
sessKey <- V.newKey :: IO (V.Key (Session IO ByteString ByteString))
let settings = setPort 3000 $ setLogger ilog defaultSettings
sessMap = sessionMap
initState = ReadState
-- { rsManager = manager
{ rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams
}
cookieMiddleware = withSession
(sessionStore genSessionId sessMap)
"mateamt-cookies"
defaultSetCookie
sessKey
runSettings settings (userApp initState)
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 TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Util where
import Servant hiding (addHeader)
@ -18,19 +19,12 @@ import Data.List.Split (chunksOf)
import Data.String (fromString)
import Control.Monad.Error
import Web.Cookie
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
-> Request
@ -47,3 +41,14 @@ formatMoney amount = pre <> t <> "," <> c
c = fromString $ snd sp
sp = tail <$>
break (== '.') (printf "%.2f" (abs amount))
redirect303
:: MonadError ServerError m
=> Link
-> m a
redirect303 link =
throwError $ err303
{ errHeaders =
[ ("Location", "/" <> (fromString $ show $ linkURI $ link))
]
}