diff --git a/src/API.hs b/src/API.hs index 12abf26..8e8be80 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index 58ec16d..f6f95b7 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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] diff --git a/src/Main.hs b/src/Main.hs index 9379815..a186ea3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/View/User.hs b/src/View/User.hs index c1e7ee7..42c6c88 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -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