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
:<|> "user" :> Capture "id" Int :> QueryParam "refine" MT.ProductRefine
:> 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" :> ReqBody '[FormUrlEncoded] MT.UserSubmit
:> 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"
:> QueryParam "destination" T.Text
:> Get '[HTML]
@ -62,12 +63,12 @@ type UserAPI =
( userSelectLink :<|>
userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
userManageLink :<|>
userManageDetailsSubmitLink :<|>
userManageAuthCreateLink :<|>
userManageAuthDeleteLink :<|>
userNewLink :<|>
userNewPostLink :<|>
authLink :<|>
authPostLink :<|>
authLogoutLink

View File

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

View File

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

View File

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