fix redirectson errors

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]

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