preapre buy page(s)
This commit is contained in:
parent
18571fa201
commit
6ba45b564e
4 changed files with 127 additions and 116 deletions
|
|
@ -36,6 +36,7 @@ executable matebeamter
|
|||
, View.Scaffold
|
||||
, View.Auth
|
||||
, View.User
|
||||
, View.Buy
|
||||
-- other-extensions:
|
||||
build-depends: base ^>=4.12.0.0
|
||||
, mateamt
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
12
src/Util.hs
12
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;"
|
||||
]
|
||||
|
|
|
|||
215
src/View/User.hs
215
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue