uniworx/oauth2-mock-server
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow combined response types

Browse Source
This commit is contained in:
David Mosbach 2024-03-05 23:58:39 +00:00
parent 3d8f77861a
commit 8fb2d81ac0
1 changed files with 6 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Server.hs
View File

@ -34,7 +34,7 @@ import Control.Concurrent
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar)
import Control.Exception (bracket)
import Control.Monad (unless, (>=>))
import Control.Monad (unless, (>=>), foldM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Error (Error(..))
import Control.Monad.Trans.Reader
@ -151,17 +151,16 @@ loginServer = decideLogin
| Nothing <- mPrompt = if isJust mCreds then handleSSO else handleLogin
| otherwise = throwError err401 { errBody = "Prompt not supported" }
where
responseType' = readMaybe @ResponseType responseType
responseType' = foldM (\acc x -> readMaybe @ResponseType x >>= return . (: acc)) [] $ words responseType
mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c
validOIDC :: Bool
validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes
in (Left OpenID `elem` scopes') == (responseType' == Just IDToken)
in (Left OpenID `elem` scopes') == (IDToken `elem` fromJust responseType')
-- | Retrieve user id from cookie
handleSSO :: AuthHandler user Html
handleSSO = do -- TODO check openid scope
liftIO $ putStrLn "login via SSO..."
liftIO . putStrLn $ "creds: " ++ show mCreds
unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" }
unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" }
url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce
liftIO $ putStrLn "SSO successful"
@ -169,7 +168,8 @@ loginServer = decideLogin
-- | Html login form
handleLogin :: AuthHandler user Html
handleLogin =
handleLogin = do
unless (Code `elem` fromJust responseType') $ throwError err401 { errBody = "response type 'code' missing" }
let headers = Map.fromList @Text @Text $
[ ("OA2_Scope", pack scopes)
, ("OA2_Client_ID", pack client)
@ -178,7 +178,7 @@ loginServer = decideLogin
[ ("OA2_State", mState)
, ("OA2_Nonce", mNonce)
]]
in return $ loginPage headers
return $ loginPage headers
codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode