diff --git a/src/Control/User.hs b/src/Control/User.hs index 97e1028..3ee402d 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -99,12 +99,12 @@ userOverviewControl mcookie uid mRefine = do Just method -> return $ userOverviewPage l10n loc (toEnum $ read method) ud prods Nothing -> - redirectOverAuth (Just uid) mRefine + redirectOverAuth (Just uid) Nothing mRefine (Left uerr, Right _) -> case uerr of FailureResponse _ resp -> if statusCode (responseStatusCode resp) == 401 then - redirectOverAuth (Just uid) mRefine + redirectOverAuth (Just uid) Nothing mRefine else throwError $ err500 { errBody = fromString (show uerr) @@ -147,6 +147,7 @@ userManageControl mcookie = do return $ userManagePage l10n loc userDetails authOverviews err -> handleErrors (fmap read mAuthUser) + (Just userManageLink) [leftToMaybe (fst err), leftToMaybe (snd err)] userManageDetailsSubmitControl mcookie uds = do @@ -163,7 +164,8 @@ userManageDetailsSubmitControl mcookie uds = do backend case eReturn of Right _ -> throwError $ redirect303 userManageLink - Left err -> handleErrors (fmap read mAuthUser) [Just err] + Left err -> + handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do (ReadState l10n backend _) <- ask @@ -183,7 +185,8 @@ userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do backend case eReturn of Right _ -> throwError $ redirect303 userManageLink - Left err -> handleErrors (fmap read mAuthUser) [Just err] + Left err -> + handleErrors (fmap read mAuthUser) (Just userManageLink) [Just err] userManageAuthDeleteControl mcookie (AuthDetailId adid) = do (ReadState l10n backend _) <- ask @@ -205,5 +208,5 @@ userManageAuthDeleteControl mcookie (AuthDetailId adid) = do then throwError $ redirect303 userManageLink else - handleErrors (fmap read mAuthUser) [Just err] - _ -> handleErrors (fmap read mAuthUser) [Just err] + handleErrors (fmap read mAuthUser) Nothing [Just err] + _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err] diff --git a/src/Util.hs b/src/Util.hs index 7c2e238..4ebed29 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -72,9 +72,10 @@ parseCookieText = map handleErrors :: (Traversable t, Show (t (Maybe ClientError))) => Maybe Int + -> Maybe Link -> t (Maybe ClientError) -> UserHandler UserOverviewPage -handleErrors mAuthUser merrs = do +handleErrors mAuthUser mLink merrs = do codes <- mapM (\eerr -> case eerr of Just (FailureResponse _ resp) -> @@ -89,7 +90,7 @@ handleErrors mAuthUser merrs = do merrs if (any (== 401) codes) then - redirectOverAuth mAuthUser Nothing + redirectOverAuth mAuthUser mLink Nothing else throwError $ err500 { errBody = fromString (show merrs) @@ -97,14 +98,16 @@ handleErrors mAuthUser merrs = do redirectOverAuth :: Maybe Int + -> Maybe Link -> Maybe (MT.ProductRefine) -> UserHandler UserOverviewPage -redirectOverAuth muid mRefine = do +redirectOverAuth muid mLink mRefine = do let redirectHeaders = errHeaders $ redirect303 (authLink (Just $ "/" <> - fromString (show $ linkURI (case muid of - Just uid -> userOverviewLink uid mRefine - Nothing -> userSelectLink + fromString (show $ linkURI (case (mLink, muid) of + (Just link, _) -> link + (Nothing, Just uid) -> userOverviewLink uid Nothing + _ -> userSelectLink )))) throwError (err303