more explicit routing of user enpoints

This commit is contained in:
nek0 2019-10-15 08:38:32 +02:00
parent 488c72ff09
commit 0216209c56
4 changed files with 43 additions and 33 deletions

View file

@ -32,18 +32,19 @@ type UserAPI =
Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage Header "Cookie" T.Text :> (Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine :<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> Get '[HTML] UserOverviewPage :> Get '[HTML] UserOverviewPage
:<|> "user" :> Capture "id" Int :> "manage" :> Get '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage"
:> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
:> Post '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage" :> "authcreate"
:> ReqBody '[FormUrlEncoded] AuthSubmitReturn
:> Post '[HTML] UserManagePage
:<|> "user" :> Capture "id" Int :> "manage" :> "authdelete"
:> ReqBody '[FormUrlEncoded] AuthDetailId
:> Post '[HTML] UserManagePage
:<|> "user" :> "create" :> Get '[HTML] UserNewPage :<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> Post '[HTML] UserSelectPage :> Post '[HTML] UserSelectPage
:<|> "user" :> "manage" :> Get '[HTML] UserManagePage
:<|> "user" :> "manage" :> ReqBody '[FormUrlEncoded] MT.UserDetailsSubmit
:> Post '[HTML] UserManagePage
:<|> "user" :> "manage" :> "authcreate"
:> ReqBody '[FormUrlEncoded] AuthSubmitReturn
:> Post '[HTML] UserManagePage
:<|> "user" :> "manage" :> "authdelete"
:> ReqBody '[FormUrlEncoded] AuthDetailId
:> Post '[HTML] UserManagePage
:<|> "auth" :<|> "auth"
:> QueryParam "destination" T.Text :> QueryParam "destination" T.Text
:> Get '[HTML] :> Get '[HTML]
@ -62,12 +63,12 @@ type UserAPI =
( userSelectLink :<|> ( userSelectLink :<|>
userOverviewLink :<|> userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
userManageLink :<|> userManageLink :<|>
userManageDetailsSubmitLink :<|> userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|> userManageAuthCreateLink :<|>
userManageAuthDeleteLink :<|> userManageAuthDeleteLink :<|>
userNewLink :<|>
userNewPostLink :<|>
authLink :<|> authLink :<|>
authPostLink :<|> authPostLink :<|>
authLogoutLink authLogoutLink

View file

@ -134,8 +134,9 @@ userOverviewControl mcookie uid mRefine = do
userManageControl userManageControl
:: Maybe T.Text :: Maybe T.Text
-> Int
-> UserHandler UserManagePage -> UserHandler UserManagePage
userManageControl mcookie = do userManageControl mcookie uid = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
@ -154,13 +155,17 @@ userManageControl mcookie = do
backend backend
case (eUserDetails, eAuthOverviews) of case (eUserDetails, eAuthOverviews) of
(Right userDetails, Right authOverviews) -> (Right userDetails, Right authOverviews) ->
if Just uid == fmap read mAuthUser
then
return $ userManagePage l10n loc userDetails authOverviews return $ userManagePage l10n loc userDetails authOverviews
else
redirectOverAuth (Just uid) (Just $ userManageLink uid) Nothing
err -> handleErrors err -> handleErrors
(fmap read mAuthUser) (Just uid)
(Just userManageLink) (Just $ userManageLink uid)
[leftToMaybe (fst err), leftToMaybe (snd err)] [leftToMaybe (fst err), leftToMaybe (snd err)]
userManageDetailsSubmitControl mcookie uds = do userManageDetailsSubmitControl mcookie uid uds = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
@ -173,11 +178,11 @@ userManageDetailsSubmitControl mcookie uds = do
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds) (userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
backend backend
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 userManageLink Right _ -> throwError $ redirect303 (userManageLink uid)
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
@ -194,11 +199,11 @@ userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do
) )
backend backend
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 userManageLink Right _ -> throwError $ redirect303 $ userManageLink uid
Left err -> Left err ->
handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
userManageAuthDeleteControl mcookie (AuthDetailId adid) = do userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
let loc = Locale let loc = Locale
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
@ -211,12 +216,12 @@ userManageAuthDeleteControl mcookie (AuthDetailId adid) = do
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
backend backend
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 userManageLink Right _ -> throwError $ redirect303 $ userManageLink uid
Left err -> case err of Left err -> case err of
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 406 if statusCode (responseStatusCode resp) == 406
then then
throwError $ redirect303 userManageLink 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]

View file

@ -45,12 +45,12 @@ userApp initState = serveWithContext userApi (EmptyContext) $
(`runReaderT` initState) (`runReaderT` initState)
(\mcookie -> userSelectControl mcookie (\mcookie -> userSelectControl mcookie
:<|> userOverviewControl mcookie :<|> userOverviewControl mcookie
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> userManageControl mcookie :<|> userManageControl mcookie
:<|> userManageDetailsSubmitControl mcookie :<|> userManageDetailsSubmitControl mcookie
:<|> userManageAuthCreateControl mcookie :<|> userManageAuthCreateControl mcookie
:<|> userManageAuthDeleteControl mcookie :<|> userManageAuthDeleteControl mcookie
:<|> userNewControl mcookie
:<|> userNewPostControl mcookie
:<|> authControl mcookie :<|> authControl mcookie
:<|> authPostControl mcookie :<|> authPostControl mcookie
:<|> authLogoutControl mcookie :<|> authLogoutControl mcookie

View file

@ -77,11 +77,11 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
$ H.toHtml $ translate "Logout" $ H.toHtml $ translate "Logout"
case method of case method of
MT.PrimaryPass -> MT.PrimaryPass ->
userSettingsPointer l10n locale userSettingsPointer l10n locale (MT.userDetailsId ud)
MT.SecondaryPass -> MT.SecondaryPass ->
productList pos productList pos
MT.ChallengeResponse -> do MT.ChallengeResponse -> do
userSettingsPointer l10n locale userSettingsPointer l10n locale (MT.userDetailsId ud)
productList pos productList pos
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -89,9 +89,10 @@ userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
userSettingsPointer userSettingsPointer
:: L10n :: L10n
-> Locale -> Locale
-> Int
-> H.Html -> H.Html
userSettingsPointer l10n locale = userSettingsPointer l10n locale uid =
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink)) $ H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink uid)) $
H.toHtml $ translate "Manage user settings" H.toHtml $ translate "Manage user settings"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -186,7 +187,8 @@ userManagePage l10n locale userDetails authOverviews =
H.p $ H.form H.p $ H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageDetailsSubmitLink)) (fromString $ show $ linkURI $
userManageDetailsSubmitLink (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 "User details" H.legend $ H.toHtml $ translate "User details"
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do
@ -220,7 +222,8 @@ userManagePage l10n locale userDetails authOverviews =
(\(MT.AuthOverview aoid comment method) -> H.form (\(MT.AuthOverview aoid comment method) -> H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageAuthDeleteLink)) (fromString $ show $ linkURI $
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 $ comment <> " - " <> case method of H.legend $ H.toHtml $ comment <> " - " <> case method of
MT.PrimaryPass -> MT.PrimaryPass ->
@ -246,7 +249,8 @@ userManagePage l10n locale userDetails authOverviews =
H.form H.form
H.! HA.method "post" H.! HA.method "post"
H.! HA.action ("/" <> H.! HA.action ("/" <>
(fromString $ show $ linkURI $ userManageAuthCreateLink)) (fromString $ show $ linkURI $
userManageAuthCreateLink (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 $ translate "Authentication details"
H.div H.! HA.class_ "form-group required" $ do H.div H.! HA.class_ "form-group required" $ do