diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 25b6c4d..46604c8 100644 --- a/src/Control/Auth.hs +++ b/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) } diff --git a/src/Control/User.hs b/src/Control/User.hs index 3ee402d..58ec16d 100644 --- a/src/Control/User.hs +++ b/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