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

ClientData type now only supports the auth code flow

Browse Source
This commit is contained in:
David Mosbach 2024-01-10 16:28:22 +01:00
parent 93093d86e4
commit 3e2d07518c
1 changed files with 18 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Server.hs
View File

@ -147,40 +147,26 @@ authServer = handleAuth
---------------------- ----------------------
data ClientData = ClientData data ClientData = ClientData --TODO support other flows
{ grantType :: GrantType { authCode :: String
, grant :: String
, userName :: Maybe String
, clientID :: Maybe String , clientID :: Maybe String
, clientSecret :: Maybe String , clientSecret :: Maybe String
, redirect :: Maybe String , redirect :: Maybe String
} deriving Show } deriving Show
data AuthFlow = AuthFlow
instance FromHttpApiData AuthFlow where
parseQueryParam "authorization_code" = Right AuthFlow
parseQueryParam x = Left x
instance FromForm ClientData where instance FromForm ClientData where
fromForm f = ClientData fromForm f = ClientData
<$> parseUnique "grant_type" f <$> ((parseUnique @AuthFlow "grant_type" f) *> parseUnique "code" f)
<*> (parseUnique @String (ps PassCreds) f --TODO add alternatives
>> parseUnique @String (ps AuthCode) f
>> parseUnique @String (ps Implicit) f
>> parseUnique @String (ps ClientCreds) f)
<*> parseMaybe "username" f
<*> parseMaybe "client_id" f <*> parseMaybe "client_id" f
<*> parseMaybe "client_secret" f <*> parseMaybe "client_secret" f
<*> parseMaybe "redirect_uri" f <*> parseMaybe "redirect_uri" f
where ps = pack . show
data GrantType = PassCreds | AuthCode | Implicit | ClientCreds deriving (Eq)
instance Show GrantType where
show PassCreds = "password"
show AuthCode = "code"
show _ = undefined --TODO support other flows
instance FromHttpApiData GrantType where
parseQueryParam s
| s == pack (show AuthCode) = Right AuthCode
| otherwise = Left $ s <> " grant type not supported yet"
data JWT = JWT data JWT = JWT
{ issuer :: Text { issuer :: Text
@ -212,22 +198,21 @@ type Token = "token"
:> ReqBody '[FormUrlEncoded] ClientData :> ReqBody '[FormUrlEncoded] ClientData
:> Post '[JSON] JWTWrapper :> Post '[JSON] JWTWrapper
tokenEndpoint :: AuthServer Token tokenEndpoint :: AuthServer Token
tokenEndpoint = provideToken tokenEndpoint = provideToken
where where
provideToken :: ClientData -> AuthHandler JWTWrapper provideToken :: ClientData -> AuthHandler JWTWrapper
provideToken client = case (grantType client) of provideToken client = do
AuthCode -> do unless (isNothing (clientID client >> clientSecret client)
unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
|| Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid client" }
throwError $ err500 { errBody = "Invalid client" } valid <- asks (verify (pack $ authCode client) (clientID client)) >>= liftIO -- TODO verify redirect url here
valid <- asks (verify (pack $ grant client) (clientID client)) >>= liftIO -- TODO verify redirect url here unless valid . throwError $ err500 { errBody = "Invalid authorisation code" }
unless valid . throwError $ err500 { errBody = "Invalid authorisation code" } -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
-- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} token <- asks mkToken >>= liftIO
token <- asks mkToken >>= liftIO liftIO . putStrLn $ "token: " ++ show token
liftIO . putStrLn $ "token: " ++ show token return token
return token
x -> error $ show x ++ " not supported yet"
mkToken :: AuthState -> IO JWTWrapper mkToken :: AuthState -> IO JWTWrapper