diff --git a/matebeamter.cabal b/matebeamter.cabal index 66d5ddf..b917d9f 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -36,6 +36,7 @@ executable matebeamter , View.Scaffold , View.Auth , View.User + , View.Buy -- other-extensions: build-depends: base ^>=4.12.0.0 , mateamt diff --git a/src/Control/User.hs b/src/Control/User.hs index f89cb9e..7b1e223 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -96,13 +96,18 @@ userOverviewControl mcookie uid mRefine = do (token, mAuthUser) = parseTokenAndUser mcookie mMethod = T.unpack <$> (lookup "x-method" =<< mParsedCookie) + getProducts = liftIO $ runClientM + (productShortList mRefine) + backend euser <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend - eproducts <- liftIO $ runClientM - (productShortList mRefine) - backend + eproducts <- case fmap toEnum (fmap read mMethod) of + Just MT.PrimaryPass -> return (Right []) + Just MT.SecondaryPass -> getProducts + Just MT.ChallengeResponse -> getProducts + _ -> return (Right []) case (euser, eproducts) of (Right ud, Right prods) -> case mMethod of @@ -210,7 +215,7 @@ userManageAuthDeleteControl -> AuthDetailId -> UserHandler UserOverviewPage userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do - (ReadState _ backend _) <- ask + backend <- asks rsBackend let (token, mAuthUser) = parseTokenAndUser mcookie eReturn <- liftIO $ runClientM (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) @@ -221,7 +226,7 @@ userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 406 then - throwError $ redirect303 $ userManageLink uid + throwError (redirect303 $ userManageLink uid) else handleErrors (fmap read mAuthUser) Nothing [Just err] _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err] diff --git a/src/Util.hs b/src/Util.hs index cfe3efe..405e362 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -10,6 +10,8 @@ import Servant hiding (addHeader) import Servant.Client import Servant.Client.Core.Request +import qualified Text.Blaze.Html5.Attributes as HA + import qualified Data.Text as T 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;" + ] diff --git a/src/View/User.hs b/src/View/User.hs index d67a0da..98bf418 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -24,6 +24,7 @@ import qualified "mateamt" Types as MT import Util import Types import View.Scaffold +import View.Buy import API userSelectPage @@ -79,10 +80,10 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $ MT.PrimaryPass -> userSettingsPointer l10n locale (MT.userDetailsId ud) MT.SecondaryPass -> - productList pos + buyProductsForm l10n locale pos MT.ChallengeResponse -> do userSettingsPointer l10n locale (MT.userDetailsId ud) - productList pos + buyProductsForm l10n locale pos where translate = localize l10n locale . gettext @@ -113,16 +114,6 @@ productList pos = H.toHtml ident ) 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 :: L10n @@ -182,115 +173,117 @@ userManagePage l10n locale userDetails authOverviews = translate "Matebeamter" <> " - " <> 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.p $ do + 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 + H.toHtml $ translate "Authentication details" + mapM_ + (\(MT.AuthOverview aoid comment method) -> H.form H.! HA.method "post" H.! HA.action ("/" <> fromString (show $ linkURI $ - userManageAuthCreateLink (MT.userDetailsId userDetails))) + userManageAuthDeleteLink (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.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.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.name "unId" + H.! HA.type_ "hidden" 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.! 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 "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 translate = localize l10n locale . gettext