This commit is contained in:
nek0 2019-10-16 18:07:12 +02:00
parent 0216209c56
commit b29daaf841
15 changed files with 320 additions and 271 deletions

View File

@ -1,10 +1,8 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
@ -13,7 +11,7 @@ module API where
import Servant.API import Servant.API
import Servant.Links import Servant.Links
import Servant.RawM -- import Servant.RawM
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Data.Proxy import Data.Proxy
@ -57,7 +55,6 @@ type UserAPI =
:> ReqBody '[FormUrlEncoded] AuthReturn :> ReqBody '[FormUrlEncoded] AuthReturn
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "auth" :> "logout" :<|> "auth" :> "logout"
-- :> ReqBody '[FormUrlEncoded] ()
:> Post '[HTML] UserOverviewPage :> Post '[HTML] UserOverviewPage
) )

View File

@ -1,35 +1,101 @@
{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE PackageImports #-}
module Client where module Client where
import Servant import Servant
import Servant.Client import Servant.Client
import Servant.Client.Core.Auth
import Network.HTTP.Client hiding (Proxy) import Servant.Client.Core.Request
import Control.Monad.IO.Class (liftIO)
-- imports from mateamt -- imports from mateamt
import qualified "mateamt" API as MT import qualified "mateamt" API as MA
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import Types mateApi :: Proxy MA.MateAPI
mateApi :: Proxy MT.MateAPI
mateApi = Proxy mateApi = Proxy
authGet :: MT.TicketRequest -> ClientM MT.AuthInfo
authSend :: MT.AuthRequest -> ClientM MT.AuthResult
authLogout :: AuthenticatedRequest (AuthProtect "header-auth") -> ClientM ()
authManageList
:: AuthenticatedRequest (AuthProtect "header-auth")
-> ClientM [MT.AuthOverview]
authManageNewAuth
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.AuthSubmit
-> ClientM Int
authManageDeleteAuth
:: AuthenticatedRequest (AuthProtect "header-auth")
-> Int
-> ClientM ()
userNew :: MT.UserSubmit -> ClientM Int
userGet
:: AuthenticatedRequest (AuthProtect "header-auth")
-> ClientM MT.UserDetails
userUpdate
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.UserDetailsSubmit
-> ClientM ()
userList :: Maybe MT.UserRefine -> ClientM [MT.UserSummary]
userRecharge
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.UserRecharge
-> ClientM ()
userTransfer
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.UserTransfer
-> ClientM ()
productNew
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.ProductSubmit
-> ClientM Int
productOverview :: Int -> ClientM MT.ProductOverview
productStockRefill
:: AuthenticatedRequest (AuthProtect "header-auth")
-> [MT.AmountRefill]
-> ClientM ()
productStockUpdate
:: AuthenticatedRequest (AuthProtect "header-auth")
-> [MT.AmountUpdate]
-> ClientM ()
productList :: Maybe MT.ProductRefine -> ClientM [MT.ProductOverview]
productShortList :: Maybe MT.ProductRefine -> ClientM [MT.ProductShortOverview]
buy
:: AuthenticatedRequest (AuthProtect "header-auth")
-> [MT.PurchaseDetail]
-> ClientM MT.PurchaseResult
journalShow
:: AuthenticatedRequest (AuthProtect "header-auth")
-> Maybe Int
-> Maybe Int
-> ClientM [MT.JournalEntry]
avatarGet
:: Int
-> (Servant.Client.Core.Request.Request
-> Servant.Client.Core.Request.Request)
-> ClientM Response
avatarInsert
:: AuthenticatedRequest (AuthProtect "header-auth")
-> MT.AvatarData
-> ClientM Int
avatarUpdate
:: AuthenticatedRequest (AuthProtect "header-auth")
-> Int
-> MT.AvatarData
-> ClientM ()
avatarList :: ClientM [MT.Avatar]
( authGet :<|> ( authGet :<|>
authSend :<|> authSend :<|>
authLogout :<|> authLogout :<|>

View File

@ -9,4 +9,4 @@ import Servant.Client.Core
type instance AuthClientData (AuthProtect "header-auth") = String type instance AuthClientData (AuthProtect "header-auth") = String
authenticateReq :: String -> Request -> Request authenticateReq :: String -> Request -> Request
authenticateReq s req = addHeader "Authentication" s req authenticateReq = addHeader "Authentication"

View File

@ -49,7 +49,7 @@ authControl mcookie mDestination = do
mAuthUser = lookup "x-auth-user" =<< mParsedCookie mAuthUser = lookup "x-auth-user" =<< mParsedCookie
mToken = lookup "x-token" =<< mParsedCookie mToken = lookup "x-token" =<< mParsedCookie
case (mAuthUser, mToken) of case (mAuthUser, mToken) of
(Just authUser, Just _) -> do (Just authUser, Just _) ->
throwError $ case mDestination of throwError $ case mDestination of
Just destination -> Just destination ->
err303 err303
@ -74,7 +74,7 @@ authControl mcookie mDestination = do
, MT.SecondaryPass , MT.SecondaryPass
] ]
eAuthInfos <- zip passes <$> eAuthInfos <- zip passes <$>
(liftIO $ mapM liftIO (mapM
(\req -> runClientM (\req -> runClientM
(authGet req) (authGet req)
backend backend
@ -85,7 +85,7 @@ authControl mcookie mDestination = do
then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $ then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $
unzip eAuthInfos) unzip eAuthInfos)
else throwError $ err400 else throwError $ err400
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos { errBody = fromString $ show $ lefts $ map snd eAuthInfos
} }
(Nothing, _) -> (Nothing, _) ->
error "Error handling not yet implemented properly." error "Error handling not yet implemented properly."
@ -105,10 +105,10 @@ authControl mcookie mDestination = do
ticketHeaders = map ticketHeaders = map
(\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) -> (\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) ->
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <> "x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
(fromString $ T.unpack ticket) <> ";Path=/") fromString (T.unpack ticket) <> ";Path=/")
tupAuthInfos tupAuthInfos
return $ return $
addHeader (ticketHeaders !! 0) $ addHeader (head ticketHeaders) $
addHeader (ticketHeaders !! 1) $ addHeader (ticketHeaders !! 1) $
authPage l10n loc mDestination authPage l10n loc mDestination
@ -177,8 +177,8 @@ authLogoutControl
authLogoutControl mcookie = do authLogoutControl mcookie = do
(ReadState _ backend _) <- ask (ReadState _ backend _) <- ask
let mParsedCookie = fmap parseCookieText mcookie let mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $ token = T.unpack $ fromMaybe "secret"
((lookup "x-token") =<< mParsedCookie) (lookup "x-token" =<< mParsedCookie)
eReturn <- liftIO $ runClientM eReturn <- liftIO $ runClientM
(authLogout (mkAuthenticatedRequest token authenticateReq)) (authLogout (mkAuthenticatedRequest token authenticateReq))
backend backend

View File

@ -7,7 +7,6 @@ module Control.User where
import Servant import Servant
import Servant.Client import Servant.Client
import Servant.Client.Core.Auth import Servant.Client.Core.Auth
import Servant.Server
import Data.String (fromString) import Data.String (fromString)
@ -17,15 +16,14 @@ import Data.Text.I18n
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Either.Combinators (leftToMaybe) import Data.Either.Combinators (leftToMaybe)
import Control.Monad (void, when) import Control.Monad (void)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask, asks)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
-- imports from "mateamt" -- imports from "mateamt"
import qualified "mateamt" API as MA
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
-- internal imports -- internal imports
@ -44,7 +42,7 @@ userSelectControl mcookie = do
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userList (Nothing)) (userList Nothing)
backend backend
case euser of case euser of
Right uss -> Right uss ->
@ -54,7 +52,7 @@ userSelectControl mcookie = do
userNewControl :: Maybe T.Text -> UserHandler UserNewPage userNewControl :: Maybe T.Text -> UserHandler UserNewPage
userNewControl mcookie = do userNewControl mcookie = do
(ReadState l10n backend _) <- ask (ReadState l10n _ _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
return $ userNewPage l10n loc return $ userNewPage l10n loc
@ -63,8 +61,8 @@ userNewPostControl
:: Maybe T.Text :: Maybe T.Text
-> MT.UserSubmit -> MT.UserSubmit
-> UserHandler UserSelectPage -> UserHandler UserSelectPage
userNewPostControl _ us@(MT.UserSubmit ident email pass) = do userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do
backend <- rsBackend <$> ask backend <- asks rsBackend
hashedPass <- hashPassword pass hashedPass <- hashPassword pass
void $ liftIO $ runClientM void $ liftIO $ runClientM
(userNew $us (userNew $us
@ -89,7 +87,7 @@ userOverviewControl mcookie uid mRefine = do
(lookup "x-auth-user" =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
mMethod = T.unpack <$> mMethod = T.unpack <$>
(lookup "x-method" =<< mParsedCookie) (lookup "x-method" =<< mParsedCookie)
euser <- liftIO $ do euser <- liftIO $
runClientM runClientM
(userGet (mkAuthenticatedRequest token authenticateReq)) (userGet (mkAuthenticatedRequest token authenticateReq))
backend backend
@ -129,7 +127,7 @@ userOverviewControl mcookie uid mRefine = do
} }
(Left uerr, Left perr) -> (Left uerr, Left perr) ->
throwError $ err500 throwError $ err500
{ errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr) { errBody = fromString (show uerr) <> " " <> fromString (show perr)
} }
userManageControl userManageControl
@ -141,15 +139,15 @@ userManageControl mcookie uid = do
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
mParsedCookie = fmap parseCookieText mcookie mParsedCookie = fmap parseCookieText mcookie
token = T.unpack $ fromMaybe "secret" $ token = T.unpack $ fromMaybe "secret"
((lookup "x-token") =<< mParsedCookie) (lookup "x-token" =<< mParsedCookie)
mAuthUser = T.unpack <$> mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
eUserDetails <- liftIO $ do eUserDetails <- liftIO $
runClientM runClientM
(userGet (mkAuthenticatedRequest token authenticateReq)) (userGet (mkAuthenticatedRequest token authenticateReq))
backend backend
eAuthOverviews <- liftIO $ do eAuthOverviews <- liftIO $
runClientM runClientM
(authManageList (mkAuthenticatedRequest token authenticateReq)) (authManageList (mkAuthenticatedRequest token authenticateReq))
backend backend
@ -165,15 +163,18 @@ userManageControl mcookie uid = do
(Just $ userManageLink uid) (Just $ userManageLink uid)
[leftToMaybe (fst err), leftToMaybe (snd err)] [leftToMaybe (fst err), leftToMaybe (snd err)]
userManageDetailsSubmitControl
:: Maybe T.Text
-> Int
-> MT.UserDetailsSubmit
-> UserHandler UserOverviewPage
userManageDetailsSubmitControl mcookie uid uds = do userManageDetailsSubmitControl mcookie uid uds = do
(ReadState l10n backend _) <- ask (ReadState _ backend _) <- ask
let loc = Locale let mParsedCookie = fmap parseCookieText mcookie
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) token = T.unpack $ fromMaybe "secret"
mParsedCookie = fmap parseCookieText mcookie (lookup "x-token" =<< mParsedCookie)
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$> mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
eReturn <- liftIO $ runClientM eReturn <- liftIO $ runClientM
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds) (userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
backend backend
@ -182,15 +183,18 @@ userManageDetailsSubmitControl mcookie uid uds = do
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
userManageAuthCreateControl
:: Maybe T.Text
-> Int
-> AuthSubmitReturn
-> UserHandler UserOverviewPage
userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
(ReadState l10n backend _) <- ask (ReadState _ backend _) <- ask
let loc = Locale let mParsedCookie = fmap parseCookieText mcookie
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) token = T.unpack $ fromMaybe "secret"
mParsedCookie = fmap parseCookieText mcookie (lookup "x-token" =<< mParsedCookie)
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$> mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
hashedPass <- hashPassword pass hashedPass <- hashPassword pass
eReturn <- liftIO $ runClientM eReturn <- liftIO $ runClientM
(authManageNewAuth (authManageNewAuth
@ -203,15 +207,18 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) =
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
userManageAuthDeleteControl
:: Maybe T.Text
-> Int
-> AuthDetailId
-> UserHandler UserOverviewPage
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
(ReadState l10n backend _) <- ask (ReadState _ backend _) <- ask
let loc = Locale let mParsedCookie = fmap parseCookieText mcookie
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) token = T.unpack $ fromMaybe "secret"
mParsedCookie = fmap parseCookieText mcookie (lookup "x-token" =<< mParsedCookie)
token = T.unpack $ fromMaybe "secret" $
((lookup "x-token") =<< mParsedCookie)
mAuthUser = T.unpack <$> mAuthUser = T.unpack <$>
((lookup "x-auth-user") =<< mParsedCookie) (lookup "x-auth-user" =<< mParsedCookie)
eReturn <- liftIO $ runClientM eReturn <- liftIO $ runClientM
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
backend backend

View File

@ -10,7 +10,7 @@ import Data.ByteString
import Data.ByteString.Random (random) import Data.ByteString.Random (random)
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Control.Monad.Reader (ask) import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
-- internal imports -- internal imports
@ -21,8 +21,8 @@ hashPassword
:: T.Text :: T.Text
-> UserHandler T.Text -> UserHandler T.Text
hashPassword passwd = do hashPassword passwd = do
(HashParams iter _ outputl) <- rsHashParams <$> ask (HashParams iter _ outputl) <- asks rsHashParams
let saltl = 0 let saltl = 0 :: Int
salt <- liftIO $ random (fromIntegral saltl) salt <- liftIO $ random (fromIntegral saltl)
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
return $ decodeUtf8 $ B64.encode hash return $ decodeUtf8 $ B64.encode hash

View File

@ -3,7 +3,6 @@
module Main where module Main where
import Servant import Servant
import Servant.Server
import Servant.Client import Servant.Client
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
@ -13,32 +12,31 @@ import Network.HTTP.Client hiding (Proxy)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Text.I18n
import Data.Text.I18n.Po import Data.Text.I18n.Po
-- internal imports -- internal imports
import API import API
import Types import Types
import View
import Control import Control
main :: IO () main :: IO ()
main = do main = do
manager <- newManager defaultManagerSettings mngr <- newManager defaultManagerSettings
(l10n, _) <- getL10n "./locales" (l10n, _) <- getL10n "./locales"
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
let settings = setPort 3000 $ setLogger ilog defaultSettings let settings = setPort 3000 $ setLogger ilog defaultSettings
initState = ReadState initState = ReadState
-- { rsManager = manager -- { rsManager = manager
{ rsL10n = l10n { rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "") , rsBackend = mkClientEnv mngr (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams , rsHashParams = recommendedHashParams
} }
runSettings settings (userApp initState) runSettings settings (userApp initState)
userApp initState = serveWithContext userApi (EmptyContext) $ userApp :: ReadState -> Application
userApp initState = serveWithContext userApi EmptyContext $
hoistServerWithContext hoistServerWithContext
userApi userApi
Proxy Proxy

View File

@ -1,3 +0,0 @@
module Model.Auth where

View File

@ -1,7 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Model.User where
import qualified "mateamt" Types as MT

View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
@ -5,14 +7,6 @@ module Types.Orphans where
import qualified "mateamt" Types as MT import qualified "mateamt" Types as MT
import GHC.Generics
import Text.Blaze
import Text.Read (readEither)
import qualified Data.Text as T
import Servant.API import Servant.API
import Servant.HTML.Blaze import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded import Web.Internal.FormUrlEncoded

View File

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Types.Page where module Types.Page where
import qualified Data.Text as T import qualified Data.Text as T
@ -44,9 +43,9 @@ template
template (Page title favicon meta style) content = template (Page title favicon meta style) content =
H.docTypeHtml $ do H.docTypeHtml $ do
H.head $ do H.head $ do
H.title $ H.toHtml $ title H.title $ H.toHtml title
meta meta
favicon favicon
style style
H.body $ H.body
content content

View File

@ -3,12 +3,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE LambdaCase #-}
module Util where module Util where
import Servant hiding (addHeader) import Servant hiding (addHeader)
import Servant.Client import Servant.Client
import Servant.Client.Core.Request import Servant.Client.Core.Request
import Servant.Client.Core.Request (addHeader)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Lazy.Encoding import Data.Text.Lazy.Encoding
@ -58,7 +58,7 @@ redirect303
redirect303 link = redirect303 link =
err303 err303
{ errHeaders = { errHeaders =
[ ("Location", "/" <> (fromString $ show $ linkURI link)) [ ("Location", "/" <> fromString (show $ linkURI link))
] ]
} }
@ -77,7 +77,7 @@ handleErrors
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
handleErrors mAuthUser mLink merrs = do handleErrors mAuthUser mLink merrs = do
codes <- mapM codes <- mapM
(\eerr -> case eerr of (\case
Just (FailureResponse _ resp) -> Just (FailureResponse _ resp) ->
return $ statusCode (responseStatusCode resp) return $ statusCode (responseStatusCode resp)
Just err -> Just err ->
@ -88,7 +88,7 @@ handleErrors mAuthUser mLink merrs = do
return 200 return 200
) )
merrs merrs
if (any (== 401) codes) if 401 `elem` codes
then then
redirectOverAuth mAuthUser mLink Nothing redirectOverAuth mAuthUser mLink Nothing
else else
@ -99,14 +99,14 @@ handleErrors mAuthUser mLink merrs = do
redirectOverAuth redirectOverAuth
:: Maybe Int :: Maybe Int
-> Maybe Link -> Maybe Link
-> Maybe (MT.ProductRefine) -> Maybe MT.ProductRefine
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
redirectOverAuth muid mLink mRefine = do redirectOverAuth muid mLink mRefine = do
let redirectHeaders = errHeaders $ let redirectHeaders = errHeaders $
redirect303 (authLink (Just $ "/" <> redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (case (mLink, muid) of fromString (show $ linkURI (case (mLink, muid) of
(Just link, _) -> link (Just link, _) -> link
(Nothing, Just uid) -> userOverviewLink uid Nothing (Nothing, Just uid) -> userOverviewLink uid mRefine
_ -> userSelectLink _ -> userSelectLink
)))) ))))
throwError throwError
@ -114,7 +114,7 @@ redirectOverAuth muid mLink mRefine = do
{ errHeaders = redirectHeaders ++ (case muid of { errHeaders = redirectHeaders ++ (case muid of
Just uid -> Just uid ->
[ ( "Set-Cookie" [ ( "Set-Cookie"
, "x-auth-user=" <> (fromString $ show uid) <> "; Path=/" , "x-auth-user=" <> fromString (show uid) <> "; Path=/"
) )
] ]
Nothing -> Nothing ->

View File

@ -36,10 +36,9 @@ authPage l10n locale mDestination = scaffold
" - " <> " - " <>
translate "Authentication" translate "Authentication"
) )
$ do $ H.p $ H.form
H.p $ H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ H.! HA.action ("/" <> fromString (show $ linkURI $
authPostLink mDestination)) authPostLink mDestination))
H.! HA.enctype "application/x-www-form-urlencoded" $ do H.! HA.enctype "application/x-www-form-urlencoded" $ do
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
@ -67,7 +66,7 @@ authPage l10n locale mDestination = scaffold
H.! HA.type_ "password" H.! HA.type_ "password"
H.! HA.required "" H.! HA.required ""
H.! HA.value "" H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $ do H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit" H.! HA.type_ "submit"

View File

@ -24,9 +24,9 @@ scaffold
-> H.Html -> H.Html
-> H.Html -> H.Html
scaffold l10n locale page content = template page $ do scaffold l10n locale page content = template page $ do
H.header $ H.nav $ H.ul $ do H.header $ H.nav $ H.ul $
H.li $ H.a H.! H.href ("/" <> (fromString $ show $ linkURI $ userSelectLink)) $ H.li $ H.a H.! H.href ("/" <> fromString (show $ linkURI userSelectLink)) $
H.toHtml $ localize l10n locale $ gettext "Home" H.toHtml $ localize l10n locale $ gettext "Home"
H.hr H.hr
H.div H.! H.id "main" H.! H.role "main" $ do H.div H.! H.id "main" H.! H.role "main" $
content content

View File

@ -13,7 +13,7 @@ import Data.Text.I18n
import Data.String (fromString) import Data.String (fromString)
import Data.Maybe (isJust, fromJust, fromMaybe) import Data.Maybe (isJust, fromJust)
-- imports from mateamt -- imports from mateamt
@ -32,16 +32,16 @@ userSelectPage
-> [MT.UserSummary] -> [MT.UserSummary]
-> UserSelectPage -> UserSelectPage
userSelectPage l10n locale uss = scaffold l10n locale (initPage $ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(translate "Matebeamter") <> translate "Matebeamter" <>
" - " <> " - " <>
(translate "Home") translate "Home"
) $ do ) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do mapM_ (\(MT.UserSummary uid ident _) ->
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ H.a H.! HA.href ("/" <> fromString (show $ linkURI $
userOverviewLink uid Nothing)) $ userOverviewLink uid Nothing)) $
H.toHtml ident H.toHtml ident
) uss ) uss
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $ H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
H.toHtml $ translate "New user" H.toHtml $ translate "New user"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -54,23 +54,23 @@ userOverviewPage
-> [MT.ProductShortOverview] -> [MT.ProductShortOverview]
-> UserOverviewPage -> UserOverviewPage
userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
(localize l10n locale $ gettext "Matebeamter") <> localize l10n locale (gettext "Matebeamter") <>
" - " <> " - " <>
(localize l10n locale $ gettext "User Menu for ") <> localize l10n locale (gettext "User Menu for ") <>
(MT.userDetailsIdent ud) MT.userDetailsIdent ud
) $ do ) $ do
H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud) H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud
<> "!" <> "!"
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $ H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
(translate "Your current balance is") <> translate "Your current balance is" <>
": " <> ": " <>
(formatMoney $ MT.userDetailsBalance ud) formatMoney (MT.userDetailsBalance ud)
-- TODO: Add currency symbol -- TODO: Add currency symbol
H.p $ H.form H.p $ H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> (fromString $ show $ linkURI $ authLogoutLink)) H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
H.! HA.enctype "application/x-www-form-urlencoded" $ do H.! HA.enctype "application/x-www-form-urlencoded" $
H.div H.! HA.class_ "form-group optional" $ do H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit" H.! HA.type_ "submit"
@ -92,7 +92,7 @@ userSettingsPointer
-> Int -> Int
-> H.Html -> H.Html
userSettingsPointer l10n locale uid = userSettingsPointer l10n locale uid =
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink uid)) $ H.a H.! HA.href ("/" <> fromString (show $ linkURI $ userManageLink uid)) $
H.toHtml $ translate "Manage user settings" H.toHtml $ translate "Manage user settings"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -104,7 +104,7 @@ productList pos =
H.p $ H.p $
H.ul H.! HA.class_ "product_list" $ H.ul H.! HA.class_ "product_list" $
mapM_ mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do (\(MT.ProductShortOverview pid ident _ _ _ avatarid) ->
H.li H.! HA.class_ "product" H.!? H.li H.! HA.class_ "product" H.!?
(isJust avatarid (isJust avatarid
, productBgStyle (fromString $ show $ fromJust avatarid) , productBgStyle (fromString $ show $ fromJust avatarid)
@ -129,46 +129,45 @@ userNewPage
-> Locale -> Locale
-> UserNewPage -> UserNewPage
userNewPage l10n locale = scaffold l10n locale (initPage $ userNewPage l10n locale = scaffold l10n locale (initPage $
(translate "Matebeamter") <> translate "Matebeamter" <>
" - " <> " - " <>
(translate "Create new user") translate "Create new user"
) $ do ) $ H.p $ H.form
H.p $ H.form H.! HA.method "post"
H.! HA.method "post" H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink))
H.! HA.action ("/" <> (fromString $ show $ linkURI $ userNewPostLink)) H.! HA.enctype "application/x-www-form-urlencoded" $ do
H.! HA.enctype "application/x-www-form-urlencoded" $ do H.div H.! HA.class_ "form-group required" $ do
H.div H.! HA.class_ "form-group required" $ do H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
H.label H.! HA.for "username" $ H.toHtml $ translate "Username" H.input
H.input H.! HA.id "username"
H.! HA.id "username" H.! HA.class_ "form-control"
H.! HA.class_ "form-control" H.! HA.name "userSubmitIdent"
H.! HA.name "userSubmitIdent" H.! HA.type_ "text"
H.! HA.type_ "text" H.! HA.required ""
H.! HA.required "" H.! HA.value ""
H.! HA.value "" H.div H.! HA.class_ "form-group optional" $ do
H.div H.! HA.class_ "form-group optional" $ do H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" H.input
H.input H.! HA.id "useremail"
H.! HA.id "useremail" H.! HA.class_ "form-control"
H.! HA.class_ "form-control" H.! HA.name "userSubmitEmail"
H.! HA.name "userSubmitEmail" H.! HA.type_ "email"
H.! HA.type_ "email" H.! HA.required ""
H.! HA.required "" H.! HA.value ""
H.! HA.value "" H.div H.! HA.class_ "form-group required" $ do
H.div H.! HA.class_ "form-group required" $ do H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password"
H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password" H.input
H.input H.! HA.id "userpass"
H.! HA.id "userpass" H.! HA.class_ "form-control"
H.! HA.class_ "form-control" H.! HA.name "userSubmitPassHash"
H.! HA.name "userSubmitPassHash" H.! HA.type_ "password"
H.! HA.type_ "password" H.! HA.required ""
H.! HA.required "" H.! HA.value ""
H.! HA.value "" H.div H.! HA.class_ "form-group optional" $
H.div H.! HA.class_ "form-group optional" $ do H.button
H.button H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-default" H.! HA.type_ "submit"
H.! HA.type_ "submit" $ H.toHtml $ translate "Submit"
$ H.toHtml $ translate "Submit"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -180,118 +179,118 @@ userManagePage
-> UserManagePage -> UserManagePage
userManagePage l10n locale userDetails authOverviews = userManagePage l10n locale userDetails authOverviews =
scaffold l10n locale (initPage $ scaffold l10n locale (initPage $
(translate "Matebeamter") <> translate "Matebeamter" <>
" - " <> " - " <>
(translate "Manage user data") translate "Manage user data"
) $ do ) $ H.p $ H.form
H.p $ H.form H.! HA.method "post"
H.! HA.method "post" H.! HA.action ("/" <>
H.! HA.action ("/" <> fromString (show $ linkURI $
(fromString $ show $ linkURI $ userManageDetailsSubmitLink (MT.userDetailsId userDetails)))
userManageDetailsSubmitLink (MT.userDetailsId userDetails))) H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do H.legend $ H.toHtml $ translate "User details"
H.legend $ H.toHtml $ translate "User details" H.div H.! HA.class_ "form-group required" $ do
H.div H.! HA.class_ "form-group required" $ do H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
H.label H.! HA.for "username" $ H.toHtml $ translate "Username" H.input
H.input H.! HA.id "username"
H.! HA.id "username" H.! HA.class_ "form-control"
H.! HA.class_ "form-control" H.! HA.name "userDetailsSubmitIdent"
H.! HA.name "userDetailsSubmitIdent" H.! HA.type_ "text"
H.! HA.type_ "text" H.! HA.required ""
H.! HA.required "" H.! HA.value
H.! HA.value (fromString $ T.unpack $ MT.userDetailsIdent userDetails)
(fromString $ T.unpack $ MT.userDetailsIdent userDetails) H.div H.! HA.class_ "form-group optional" $ do
H.div H.! HA.class_ "form-group optional" $ do H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" H.input
H.input H.! HA.id "useremail"
H.! HA.id "useremail" H.! HA.class_ "form-control"
H.! HA.class_ "form-control" H.! HA.name "userDetailsSubmitEmail"
H.! HA.name "userDetailsSubmitEmail" H.! HA.type_ "email"
H.! HA.type_ "email" H.! HA.required ""
H.! HA.required "" H.! HA.value
H.! HA.value (maybe "" (fromString . T.unpack)
(fromMaybe "" $ fromString <$> T.unpack <$> (MT.userDetailsEmail userDetails))
MT.userDetailsEmail userDetails) H.div H.! HA.class_ "form-group optional" $
H.div H.! HA.class_ "form-group optional" $ do H.button
H.button H.! HA.class_ "btn btn-default"
H.! HA.class_ "btn btn-default" H.! HA.type_ "submit"
H.! HA.type_ "submit" $ H.toHtml $ translate "Submit"
$ H.toHtml $ translate "Submit" H.p $ do
H.p $ do mapM_
mapM_ (\(MT.AuthOverview aoid comment method) -> H.form
(\(MT.AuthOverview aoid comment method) -> H.form H.! HA.method "post"
H.! HA.action ("/" <>
fromString (show $ linkURI $
userManageAuthDeleteLink (MT.userDetailsId userDetails)))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml (comment <> " - " <> case method of
MT.PrimaryPass ->
translate "Primary password"
MT.SecondaryPass ->
translate "Secondary password"
MT.ChallengeResponse ->
translate "Challenge response authentication"
)
H.div H.! HA.class_ "form-group required" $
H.input
H.! HA.class_ "form-control"
H.! HA.name "unId"
H.! HA.type_ "hidden"
H.! HA.required ""
H.! HA.value (fromString $ show aoid)
H.div H.! HA.class_ "form-group optional" $
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete"
)
authOverviews
H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
(fromString $ show $ linkURI $ fromString (show $ linkURI $
userManageAuthDeleteLink (MT.userDetailsId userDetails))) userManageAuthCreateLink (MT.userDetailsId userDetails)))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ comment <> " - " <> case method of H.legend $ H.toHtml $ translate "Authentication details"
MT.PrimaryPass ->
translate "Primary password"
MT.SecondaryPass ->
translate "Secondary password"
MT.ChallengeResponse ->
translate "Challenge response authentication"
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "comment" $ H.toHtml $
translate "Comment"
H.input H.input
H.! HA.class_ "form-control" H.! HA.id "comment"
H.! HA.name "unId" H.! HA.class_ "form_control"
H.! HA.type_ "hidden" H.! HA.name "authSubmitReturnComment"
H.! HA.type_ "text"
H.! HA.required "" H.! HA.required ""
H.! HA.value (fromString $ show aoid) H.! HA.value ""
H.div H.! HA.class_ "form-group optional" $ do H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "password" $ H.toHtml $
translate "Password"
H.input
H.! HA.id "password"
H.! HA.class_ "form_control"
H.! HA.name "authSubmitReturnPass"
H.! HA.type_ "password"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $
translate "Authentication Method"
H.select
H.! HA.id "method"
H.! HA.class_ "form-control"
H.! HA.name "authSubmitReturnMethod"
H.! HA.required ""
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do
H.option H.!
HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $
H.toHtml $ translate "Secondary password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $
H.button H.button
H.! HA.class_ "btn btn-default" H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit" H.! HA.type_ "submit"
$ H.toHtml $ translate "Delete" $ H.toHtml $ translate "Submit"
)
authOverviews
H.form
H.! HA.method "post"
H.! HA.action ("/" <>
(fromString $ show $ linkURI $
userManageAuthCreateLink (MT.userDetailsId userDetails)))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.legend $ H.toHtml $ translate "Authentication details"
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "comment" $ H.toHtml $
translate "Comment"
H.input
H.! HA.id "comment"
H.! HA.class_ "form_control"
H.! HA.name "authSubmitReturnComment"
H.! HA.type_ "text"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "password" $ H.toHtml $
translate "Password"
H.input
H.! HA.id "password"
H.! HA.class_ "form_control"
H.! HA.name "authSubmitReturnPass"
H.! HA.type_ "password"
H.! HA.required ""
H.! HA.value ""
H.div H.! HA.class_ "form-group required" $ do
H.label H.! HA.for "method" $ H.toHtml $
translate "Authentication Method"
H.select
H.! HA.id "method"
H.! HA.class_ "form-control"
H.! HA.name "authSubmitReturnMethod"
H.! HA.required ""
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do
H.option H.!
HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $
H.toHtml $ translate "Secondary password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
H.toHtml $ translate "Primary password"
H.div H.! HA.class_ "form-group optional" $ do
H.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Submit"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext