more explicit routing of user enpoints

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

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 uid)
-      (Just userManageLink)
+      (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]

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

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 =
+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"
   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