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

preapre buy page(s)

Browse source
This commit is contained in:
nek0 2019-10-21 20:41:58 +02:00
parent 18571fa201
commit 6ba45b564e
4 changed files with 127 additions and 116 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
matebeamter.cabal
View file

@ -36,6 +36,7 @@ executable matebeamter
, View.Scaffold , View.Scaffold
, View.Auth , View.Auth
, View.User , View.User
, View.Buy
-- other-extensions: -- other-extensions:
build-depends: base ^>=4.12.0.0 build-depends: base ^>=4.12.0.0
, mateamt , mateamt

15
src/Control/User.hs
View file

@ -96,13 +96,18 @@ userOverviewControl mcookie uid mRefine = do
(token, mAuthUser) = parseTokenAndUser mcookie (token, mAuthUser) = parseTokenAndUser mcookie
mMethod = T.unpack <$> mMethod = T.unpack <$>
(lookup "x-method" =<< mParsedCookie) (lookup "x-method" =<< mParsedCookie)
getProducts = liftIO $ runClientM
(productShortList mRefine)
backend
euser <- liftIO $ euser <- liftIO $
runClientM runClientM
(userGet (mkAuthenticatedRequest token authenticateReq)) (userGet (mkAuthenticatedRequest token authenticateReq))
backend backend
eproducts <- liftIO $ runClientM eproducts <- case fmap toEnum (fmap read mMethod) of
(productShortList mRefine) Just MT.PrimaryPass -> return (Right [])
backend Just MT.SecondaryPass -> getProducts
Just MT.ChallengeResponse -> getProducts
_ -> return (Right [])
case (euser, eproducts) of case (euser, eproducts) of
(Right ud, Right prods) -> (Right ud, Right prods) ->
case mMethod of case mMethod of
@ -210,7 +215,7 @@ userManageAuthDeleteControl
-> AuthDetailId -> AuthDetailId
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
(ReadState _ backend _) <- ask backend <- asks rsBackend
let (token, mAuthUser) = parseTokenAndUser mcookie let (token, mAuthUser) = parseTokenAndUser mcookie
eReturn <- liftIO $ runClientM eReturn <- liftIO $ runClientM
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
@ -221,7 +226,7 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 406 if statusCode (responseStatusCode resp) == 406
then then
throwError $ redirect303 $ userManageLink uid throwError (redirect303 $ userManageLink uid)
else else
handleErrors (fmap read mAuthUser) Nothing [Just err] handleErrors (fmap read mAuthUser) Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err] _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]

12
src/Util.hs
View file

@ -10,6 +10,8 @@ import Servant hiding (addHeader)
import Servant.Client import Servant.Client
import Servant.Client.Core.Request import Servant.Client.Core.Request
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Lazy.Encoding import Data.Text.Lazy.Encoding
@ -131,3 +133,13 @@ redirectOverAuth muid mLink mRefine = do
] ]
} }
) )
productBgStyle aid = HA.style $ mconcat
[ "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;"
]

215
src/View/User.hs
View file

@ -24,6 +24,7 @@ import qualified "mateamt" Types as MT
import Util import Util
import Types import Types
import View.Scaffold import View.Scaffold
import View.Buy
import API import API
userSelectPage userSelectPage
@ -79,10 +80,10 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
MT.PrimaryPass -> MT.PrimaryPass ->
userSettingsPointer l10n locale (MT.userDetailsId ud) userSettingsPointer l10n locale (MT.userDetailsId ud)
MT.SecondaryPass -> MT.SecondaryPass ->
productList pos buyProductsForm l10n locale pos
MT.ChallengeResponse -> do MT.ChallengeResponse -> do
userSettingsPointer l10n locale (MT.userDetailsId ud) userSettingsPointer l10n locale (MT.userDetailsId ud)
productList pos buyProductsForm l10n locale pos
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -113,16 +114,6 @@ productList pos =
H.toHtml ident H.toHtml ident
) )
pos pos
where
productBgStyle aid = HA.style $ mconcat
[ "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;"
]
userNewPage userNewPage
:: L10n :: L10n
@ -182,115 +173,117 @@ userManagePage l10n locale userDetails authOverviews =
translate "Matebeamter" <> translate "Matebeamter" <>
" - " <> " - " <>
translate "Manage user data" translate "Manage user data"
) $ H.p $ H.form ) $ H.p $ do
H.! HA.method "post" H.form
H.! HA.action ("/" <> H.! HA.method "post"
fromString (show $ linkURI $ H.! HA.action ("/" <>
userManageDetailsSubmitLink (MT.userDetailsId userDetails))) fromString (show $ linkURI $
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do userManageDetailsSubmitLink (MT.userDetailsId userDetails)))
H.legend $ H.toHtml $ translate "User details" H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
H.div H.! HA.class_ "form-group required" $ do H.legend $ H.toHtml $ translate "User details"
H.label H.! HA.for "username" $ H.toHtml $ translate "Username" H.div H.! HA.class_ "form-group required" $ do
H.input H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
H.! HA.id "username" H.input
H.! HA.class_ "form-control" H.! HA.id "username"
H.! HA.name "userDetailsSubmitIdent" H.! HA.class_ "form-control"
H.! HA.type_ "text" H.! HA.name "userDetailsSubmitIdent"
H.! HA.required "" H.! HA.type_ "text"
H.! HA.value H.! HA.required ""
(fromString $ T.unpack $ MT.userDetailsIdent userDetails) H.! HA.value
H.div H.! HA.class_ "form-group optional" $ do (fromString $ T.unpack $ MT.userDetailsIdent userDetails)
H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" H.div H.! HA.class_ "form-group optional" $ do
H.input H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email"
H.! HA.id "useremail" H.input
H.! HA.class_ "form-control" H.! HA.id "useremail"
H.! HA.name "userDetailsSubmitEmail" H.! HA.class_ "form-control"
H.! HA.type_ "email" H.! HA.name "userDetailsSubmitEmail"
H.! HA.required "" H.! HA.type_ "email"
H.! HA.value H.! HA.required ""
(maybe "" (fromString . T.unpack) H.! HA.value
(MT.userDetailsEmail userDetails)) (maybe "" (fromString . T.unpack)
H.div H.! HA.class_ "form-group optional" $ (MT.userDetailsEmail userDetails))
H.button H.div H.! HA.class_ "form-group optional" $
H.! HA.class_ "btn btn-default" H.button
H.! HA.type_ "submit" H.! HA.class_ "btn btn-default"
$ H.toHtml $ translate "Submit" H.! HA.type_ "submit"
H.p $ do $ H.toHtml $ translate "Submit"
mapM_ H.p $ do
(\(MT.AuthOverview aoid comment method) -> H.form H.toHtml $ translate "Authentication details"
H.! HA.method "post" mapM_
H.! HA.action ("/" <> (\(MT.AuthOverview aoid comment method) -> H.form
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 $
userManageAuthCreateLink (MT.userDetailsId userDetails))) userManageAuthDeleteLink (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 "Authentication details" H.legend $ H.toHtml (comment <> " - " <> case method of
H.div H.! HA.class_ "form-group required" $ do MT.PrimaryPass ->
H.label H.! HA.for "comment" $ H.toHtml $ translate "Primary password"
translate "Comment" MT.SecondaryPass ->
translate "Secondary password"
MT.ChallengeResponse ->
translate "Challenge response authentication"
)
H.div H.! HA.class_ "form-group required" $
H.input 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.class_ "form-control"
H.! HA.name "authSubmitReturnMethod" H.! HA.name "unId"
H.! HA.type_ "hidden"
H.! HA.required "" H.! HA.required ""
H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do H.! HA.value (fromString $ show aoid)
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.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 "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 "New authentication"
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" $
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