fix redirectson errors

This commit is contained in:
nek0 2019-10-14 21:41:28 +02:00
parent 2854aa0021
commit 5cab55fe9e
2 changed files with 18 additions and 12 deletions

View File

@ -99,12 +99,12 @@ userOverviewControl mcookie uid mRefine = do
Just method -> Just method ->
return $ userOverviewPage l10n loc (toEnum $ read method) ud prods return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
Nothing -> Nothing ->
redirectOverAuth (Just uid) mRefine redirectOverAuth (Just uid) Nothing mRefine
(Left uerr, Right _) -> case uerr of (Left uerr, Right _) -> case uerr of
FailureResponse _ resp -> FailureResponse _ resp ->
if statusCode (responseStatusCode resp) == 401 if statusCode (responseStatusCode resp) == 401
then then
redirectOverAuth (Just uid) mRefine redirectOverAuth (Just uid) Nothing mRefine
else else
throwError $ err500 throwError $ err500
{ errBody = fromString (show uerr) { errBody = fromString (show uerr)
@ -147,6 +147,7 @@ userManageControl mcookie = do
return $ userManagePage l10n loc userDetails authOverviews return $ userManagePage l10n loc userDetails authOverviews
err -> handleErrors err -> handleErrors
(fmap read mAuthUser) (fmap read mAuthUser)
(Just userManageLink)
[leftToMaybe (fst err), leftToMaybe (snd err)] [leftToMaybe (fst err), leftToMaybe (snd err)]
userManageDetailsSubmitControl mcookie uds = do userManageDetailsSubmitControl mcookie uds = do
@ -163,7 +164,8 @@ userManageDetailsSubmitControl mcookie uds = do
backend backend
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 userManageLink 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 userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
@ -183,7 +185,8 @@ userManageAuthCreateControl mcookie (AuthSubmitReturn comment pass method) = do
backend backend
case eReturn of case eReturn of
Right _ -> throwError $ redirect303 userManageLink 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 userManageAuthDeleteControl mcookie (AuthDetailId adid) = do
(ReadState l10n backend _) <- ask (ReadState l10n backend _) <- ask
@ -205,5 +208,5 @@ userManageAuthDeleteControl mcookie (AuthDetailId adid) = do
then then
throwError $ redirect303 userManageLink throwError $ redirect303 userManageLink
else else
handleErrors (fmap read mAuthUser) [Just err] handleErrors (fmap read mAuthUser) Nothing [Just err]
_ -> handleErrors (fmap read mAuthUser) [Just err] _ -> handleErrors (fmap read mAuthUser) (Just userSelectLink) [Just err]

View File

@ -72,9 +72,10 @@ parseCookieText = map
handleErrors handleErrors
:: (Traversable t, Show (t (Maybe ClientError))) :: (Traversable t, Show (t (Maybe ClientError)))
=> Maybe Int => Maybe Int
-> Maybe Link
-> t (Maybe ClientError) -> t (Maybe ClientError)
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
handleErrors mAuthUser merrs = do handleErrors mAuthUser mLink merrs = do
codes <- mapM codes <- mapM
(\eerr -> case eerr of (\eerr -> case eerr of
Just (FailureResponse _ resp) -> Just (FailureResponse _ resp) ->
@ -89,7 +90,7 @@ handleErrors mAuthUser merrs = do
merrs merrs
if (any (== 401) codes) if (any (== 401) codes)
then then
redirectOverAuth mAuthUser Nothing redirectOverAuth mAuthUser mLink Nothing
else else
throwError $ err500 throwError $ err500
{ errBody = fromString (show merrs) { errBody = fromString (show merrs)
@ -97,14 +98,16 @@ handleErrors mAuthUser merrs = do
redirectOverAuth redirectOverAuth
:: Maybe Int :: Maybe Int
-> Maybe Link
-> Maybe (MT.ProductRefine) -> Maybe (MT.ProductRefine)
-> UserHandler UserOverviewPage -> UserHandler UserOverviewPage
redirectOverAuth muid mRefine = do redirectOverAuth muid mLink mRefine = do
let redirectHeaders = errHeaders $ let redirectHeaders = errHeaders $
redirect303 (authLink (Just $ "/" <> redirect303 (authLink (Just $ "/" <>
fromString (show $ linkURI (case muid of fromString (show $ linkURI (case (mLink, muid) of
Just uid -> userOverviewLink uid mRefine (Just link, _) -> link
Nothing -> userSelectLink (Nothing, Just uid) -> userOverviewLink uid Nothing
_ -> userSelectLink
)))) ))))
throwError throwError
(err303 (err303