try to fix auth info handling and redirections

src/Control/Auth.hs

@@ -44,9 +44,10 @@ authControl
        , Header "Set-Cookie" T.Text
        ]
       AuthPage)
-authControl mcookie@(Just cookie) mDestination = do
-  let mAuthUser = lookup "x-auth-user" (parseCookieText cookie)
-  let mToken = lookup "x-token" (parseCookieText cookie)
+authControl mcookie mDestination = do
+  let mParsedCookie = fmap parseCookieText mcookie
+      mAuthUser = lookup "x-auth-user" =<< mParsedCookie
+      mToken = lookup "x-token" =<< mParsedCookie
   case (mAuthUser, mToken) of
     (Just authUser, Just _) -> do
       throwError $ case mDestination of
@@ -87,10 +88,7 @@ authControl mcookie@(Just cookie) mDestination = do
         { errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
         }
     (Nothing, _) ->
-      error $ "Error handling not yet implemented properly, but here's your user: "
-        <> (fromString $ T.unpack $ fromMaybe "" $
-          lookup "x-auth-user" (parseCookieText cookie)
-          )
+      error "Error handling not yet implemented properly."
   where
     digestAuthInfo
       :: [(MT.AuthMethod, MT.AuthInfo)]
@@ -113,10 +111,6 @@ authControl mcookie@(Just cookie) mDestination = do
         addHeader (ticketHeaders !! 0) $
           addHeader (ticketHeaders !! 1) $
             authPage l10n loc mDestination
-authControl Nothing _ =
-  throwError $ err400
-    { errBody = "No cookie present."
-    }
 
 authPostControl
   :: Maybe T.Text
@@ -189,7 +183,17 @@ authLogoutControl mcookie = do
     (authLogout (mkAuthenticatedRequest token authenticateReq))
     backend
   case eReturn of
-    Right _ -> throwError $ redirect303 userSelectLink
+    Right _ -> do
+      let redirectHeaders = errHeaders (redirect303 userSelectLink)
+          unsetCookiesHeaders = map
+            (\c ->
+              ( "Set-Cookie"
+              , c <> "=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT")
+              )
+            ["x-auth-user", "x-method", "x-token"]
+      throwError $ err303
+        { errHeaders = redirectHeaders ++ unsetCookiesHeaders
+        }
     Left err -> throwError $ err500
       { errBody = fromString (show err)
       }

src/Control/User.hs

@@ -82,13 +82,16 @@ userOverviewControl mcookie uid mRefine = do
   (ReadState l10n backend _) <- ask
   let loc = Locale
         (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
-  let mMethod = T.unpack <$>
-        (lookup "x-method" =<< fmap parseCookieText mcookie)
+      mParsedCookie = fmap parseCookieText mcookie
+      token = T.unpack $ fromMaybe "secret" $
+        lookup "x-token" =<< mParsedCookie
+      mAuthUser = T.unpack <$>
+        (lookup "x-auth-user" =<< mParsedCookie)
+      mMethod = T.unpack <$>
+        (lookup "x-method" =<< mParsedCookie)
   euser <- liftIO $ do
-    let mToken = T.unpack $ fromMaybe "secret" $
-          lookup "x-token" =<< fmap parseCookieText mcookie
     runClientM
-      (userGet (mkAuthenticatedRequest mToken authenticateReq))
+      (userGet (mkAuthenticatedRequest token authenticateReq))
       backend
   eproducts <- liftIO $ runClientM
     (productShortList mRefine)
@@ -97,9 +100,16 @@ userOverviewControl mcookie uid mRefine = do
     (Right ud, Right prods) ->
       case mMethod of
         Just method ->
-          return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
+          if fmap read mAuthUser == Just uid
+          then
+            return $ userOverviewPage l10n loc (toEnum $ read method) ud prods
+          else
+            redirectOverAuth
+              (Just uid)
+              (Just $ userOverviewLink uid mRefine)
+              mRefine
         Nothing ->
-          redirectOverAuth (Just uid) Nothing mRefine
+          redirectOverAuth (read <$> mAuthUser) Nothing mRefine
     (Left uerr, Right _) -> case uerr of
       FailureResponse _ resp ->
         if statusCode (responseStatusCode resp) == 401