matebeamter/src/View/User.hs

298 lines
10 KiB
Haskell
Raw Normal View History

2019-09-08 10:48:57 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-09-08 15:27:38 +00:00
{-# LANGUAGE PackageImports #-}
2019-09-08 10:48:57 +00:00
module View.User where
2019-09-16 07:44:46 +00:00
import Servant.Links
2019-09-11 04:27:54 +00:00
import qualified Text.Blaze.Html5 as H hiding (style)
2019-09-17 19:29:56 +00:00
import qualified Text.Blaze.Html5.Attributes as HA
2019-09-08 15:27:38 +00:00
import qualified Data.Text as T
2019-09-08 15:27:38 +00:00
import Data.Text.I18n
import Data.String (fromString)
import Data.Maybe (isJust, fromJust, fromMaybe)
2019-09-11 04:27:54 +00:00
2019-09-08 15:27:38 +00:00
-- imports from mateamt
import qualified "mateamt" Types as MT
-- internal imports
2019-09-08 10:48:57 +00:00
2019-09-11 04:27:54 +00:00
import Util
2019-09-08 10:48:57 +00:00
import Types
2019-09-08 15:27:38 +00:00
import View.Scaffold
2019-09-16 07:44:46 +00:00
import API
2019-09-08 10:48:57 +00:00
2019-09-11 04:27:54 +00:00
userSelectPage
2019-09-08 15:27:38 +00:00
:: L10n
-> Locale
-> [MT.UserSummary]
2019-09-11 04:27:54 +00:00
-> UserSelectPage
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
2019-09-16 07:44:46 +00:00
(translate "Matebeamter") <>
2019-09-11 04:27:54 +00:00
" - " <>
2019-09-16 07:44:46 +00:00
(translate "Home")
) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
userOverviewLink uid Nothing)) $
H.toHtml ident
2019-09-16 07:44:46 +00:00
) uss
2019-09-17 19:29:56 +00:00
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
H.toHtml $ translate "New user"
2019-09-16 07:44:46 +00:00
where
translate = localize l10n locale . gettext
2019-09-11 04:27:54 +00:00
userOverviewPage
:: L10n
-> Locale
-> MT.AuthMethod
2019-09-11 04:27:54 +00:00
-> MT.UserDetails
-> [MT.ProductShortOverview]
-> UserOverviewPage
userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
2019-09-11 04:27:54 +00:00
(localize l10n locale $ gettext "Matebeamter") <>
" - " <>
(localize l10n locale $ gettext "User Menu for ") <>
(MT.userDetailsIdent ud)
) $ do
H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud)
<> "!"
2019-09-17 19:29:56 +00:00
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
2019-09-11 04:27:54 +00:00
(translate "Your current balance is") <>
": " <>
(formatMoney $ MT.userDetailsBalance ud)
-- TODO: Add currency symbol
2019-10-14 18:10:30 +00:00
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.button
H.! HA.class_ "btn btn-default"
H.! HA.type_ "submit"
$ H.toHtml $ translate "Logout"
case method of
MT.PrimaryPass ->
2019-10-15 06:38:32 +00:00
userSettingsPointer l10n locale (MT.userDetailsId ud)
MT.SecondaryPass ->
2019-10-14 18:11:45 +00:00
productList pos
MT.ChallengeResponse -> do
2019-10-15 06:38:32 +00:00
userSettingsPointer l10n locale (MT.userDetailsId ud)
2019-10-14 18:11:45 +00:00
productList pos
2019-09-11 04:27:54 +00:00
where
translate = localize l10n locale . gettext
2019-10-14 18:11:45 +00:00
userSettingsPointer
:: L10n
-> Locale
2019-10-15 06:38:32 +00:00
-> Int
2019-10-14 18:11:45 +00:00
-> H.Html
2019-10-15 06:38:32 +00:00
userSettingsPointer l10n locale uid =
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink uid)) $
2019-10-14 18:11:45 +00:00
H.toHtml $ translate "Manage user settings"
where
translate = localize l10n locale . gettext
productList
:: [MT.ProductShortOverview]
-> H.Html
productList pos =
H.p $
H.ul H.! HA.class_ "product_list" $
mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
H.li H.! HA.class_ "product" H.!?
(isJust avatarid
, productBgStyle (fromString $ show $ fromJust avatarid)
) $
H.a H.! HA.href ("#" <> fromString (show pid)) $
H.toHtml ident
)
pos
where
2019-09-17 19:29:56 +00:00
productBgStyle aid = HA.style $ mconcat
2019-09-11 04:27:54 +00:00
[ "background-image: url(#" <> aid <> ");" -- FILLME
, "backgronud-color: blue;"
, "text-shadow:"
, " -1px 0 1px black,"
, " 0 1px 1px black,"
, " 1px 0 1px black,"
, " 0 -1px 1px black;"
]
2019-09-17 19:29:56 +00:00
userNewPage
:: L10n
-> Locale
-> UserNewPage
userNewPage l10n locale = scaffold l10n locale (initPage $
(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"
where
translate = localize l10n locale . gettext
userManagePage
:: L10n
-> Locale
-> MT.UserDetails
-> [MT.AuthOverview]
-> UserManagePage
userManagePage l10n locale userDetails authOverviews =
scaffold l10n locale (initPage $
(translate "Matebeamter") <>
" - " <>
(translate "Manage user data")
) $ do
H.p $ H.form
H.! HA.method "post"
H.! HA.action ("/" <>
2019-10-15 06:38:32 +00:00
(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
H.! HA.method "post"
H.! HA.action ("/" <>
2019-10-15 06:38:32 +00:00
(fromString $ show $ linkURI $
userManageAuthDeleteLink (MT.userDetailsId userDetails)))
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
2019-10-14 15:40:20 +00:00
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" $ do
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" $ do
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 ("/" <>
2019-10-15 06:38:32 +00:00
(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) $
2019-10-14 15:40:20 +00:00
H.toHtml $ translate "Secondary password"
H.option H.!
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
2019-10-14 15:40:20 +00:00
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
translate = localize l10n locale . gettext