nek0/matebeamter
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

linted

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

7
src/API.hs
View file

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

104
src/Client.hs
View file

@ -1,35 +1,101 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PackageImports #-}
module Client where
import Servant
import Servant.Client
import Network.HTTP.Client hiding (Proxy)
import Control.Monad.IO.Class (liftIO)
import Servant.Client.Core.Auth
import Servant.Client.Core.Request
-- imports from mateamt
import qualified "mateamt" API as MT
import qualified "mateamt" Types as MT
import qualified "mateamt" API as MA
import qualified "mateamt" Types as MT
-- internal imports
import Types
mateApi :: Proxy MT.MateAPI
mateApi :: Proxy MA.MateAPI
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 :<|>
authSend :<|>
authLogout :<|>

2
src/ClientAuth.hs
View file

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

14
src/Control/Auth.hs
View file

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

79
src/Control/User.hs
View file

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

6
src/Hash.hs
View file

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

10
src/Main.hs
View file

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

3
src/Model/Auth.hs
View file

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

7
src/Model/User.hs
View file

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

10
src/Types/Orphans.hs
View file

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -5,14 +7,6 @@ module Types.Orphans where
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.HTML.Blaze
import Web.Internal.FormUrlEncoded

5
src/Types/Page.hs
View file

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

14
src/Util.hs
View file

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

7
src/View/Auth.hs
View file

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

6
src/View/Scaffold.hs
View file

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

317
src/View/User.hs
View file

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