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
]
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)
}

View File

@ -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