try to fix auth info handling and redirections

This commit is contained in:
nek0 2019-10-15 07:22:04 +02:00
parent 5cab55fe9e
commit 488c72ff09
2 changed files with 33 additions and 19 deletions

View file

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

View file

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