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

Merge branch 'user-queries' into 'main'

Browse Source 
User Queries

See merge request mosbach/oauth2-mock-server!4
This commit is contained in:
Nora Mosbach 2024-02-18 19:38:59 +00:00
commit c17f8f1ae2
3 changed files with 76 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
src/AuthCode.hs
View File

@ -164,18 +164,17 @@ decodeToken token state = do
prKey <- atomically $ readTVar state >>= return . privateKey
jwkDecode prKey $ encodeUtf8 token
renewToken :: JWTWrapper -> AuthState user -> IO (Maybe JWTWrapper)
renewToken (JWTW _ _ rt) state = case rt >>= stripPrefix "Bearer " . pack of
Just t -> decodeToken t state >>= \case
Right (Jwe (header, body)) -> do
let jwt = fromJust . decode @JWT $ fromStrict body
now <- getCurrentTime
if now <= expiration jwt then return Nothing else do
mUser <- atomically . stateTVar state $ \s ->
let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens
in (key, s { activeTokens = tokens })
case mUser of
Just (u, scopes) -> Just <$> mkToken u scopes state
Nothing -> return Nothing
Left _ -> return Nothing
Nothing -> return Nothing
renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper)
renewToken t state = decodeToken t state >>= \case
Right (Jwe (header, body)) -> do
let jwt = fromJust . decode @JWT $ fromStrict body
now <- getCurrentTime
if now >= expiration jwt then return Nothing else do
mUser <- atomically . stateTVar state $ \s ->
let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens
in (key, s { activeTokens = tokens })
case mUser of
Just (u, scopes) -> Just <$> mkToken u scopes state
Nothing -> return Nothing
Left _ -> return Nothing

91
src/Server.hs
View File

@ -3,7 +3,16 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-}
{-# LANGUAGE
DataKinds
, TypeOperators
, OverloadedStrings
, ScopedTypeVariables
, TypeApplications
, RecordWildCards
, AllowAmbiguousTypes
, LambdaCase
#-}
module Server
{-( insecureOAuthMock'
@ -53,7 +62,7 @@ import Text.ParserCombinators.ReadPrec (look, pfail)
import qualified Text.Read.Lex as Lex
import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe)
import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..))
@ -159,7 +168,7 @@ codeServer = handleCreds
scopes' = map (readScope @user @userData) $ words scopes
[userName, password] = splitOn ":" $ decodeBase64Lenient creds
liftIO $ print userName
mUser <- liftIO $ lookupUser @user @userData userName password
mUser <- liftIO $ lookupUser @user @userData userName (Just password)
unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
let u = fromJust mUser
mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
@ -185,9 +194,11 @@ codeServer = handleCreds
----------------------
newtype ACode = ACode String deriving (Show)
newtype RToken = RToken Text deriving (Show)
data ClientData = ClientData --TODO support other flows
{ authID :: Either ACode JWTWrapper
{ authID :: Either ACode RToken
, grantType :: Text
, clientID :: Maybe String
, clientSecret :: Maybe String
, redirect :: Maybe String
@ -198,10 +209,11 @@ instance FromHttpApiData AuthFlow where
parseQueryParam "authorization_code" = Right AuthFlow
parseQueryParam x = Left x
instance FromForm ClientData where
fromForm f = ClientData
<$> ((parseUnique @AuthFlow "grant_type" f) *> ((Left . ACode <$> parseUnique "code" f)
<|> (Right <$> parseUnique "refresh_token" f)))
<$> ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f)))
<*> parseUnique "grant_type" f
<*> parseMaybe "client_id" f
<*> parseMaybe "client_secret" f
<*> parseMaybe "redirect_uri" f
@ -220,11 +232,13 @@ tokenEndpoint = provideToken
where
provideToken :: ClientData -> AuthHandler user JWTWrapper
provideToken client = do
liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client
unless (isNothing (clientID client >> clientSecret client)
|| Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
throwError $ err500 { errBody = "Invalid client" }
case authID client of
Left (ACode authCode) -> do
unless (grantType client == "authorization_code") . throwError $ err500 { errBody = "Invalid grant_type" }
mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here
unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" }
-- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
@ -232,7 +246,9 @@ tokenEndpoint = provideToken
token <- asks (mkToken @user user scopes) >>= liftIO
liftIO . putStrLn $ "token: " ++ show token
return token
Right jwtw -> do
Right (RToken jwtw) -> do
unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
liftIO $ putStrLn "... checking refresh token"
mToken <- asks (renewToken @user jwtw) >>= liftIO
case mToken of
Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
@ -250,41 +266,58 @@ type HeaderR = Header' [Strict, Required]
type Me userData = Users
:> "me"
:> HeaderR "Authorization" Text
:> Get '[JSON] (Maybe userData)
:> Get '[JSON] (QueryResult userData)
type UserList userData = Users
:> "query"
:> HeaderR "Authorization" Text
:> Get '[JSON] [userData] -- TODO support query params
:> QParam "id" Text
:> Get '[JSON] (QueryResult [userData])
data QueryResult result = QLeft QueryError | QRight result
newtype QueryError = QError Text
instance ToJSON QueryError where
toJSON (QError code) = object ["error" .= object ["code" .= code]]
instance ToJSON result => ToJSON (QueryResult result) where
toJSON (QLeft x) = toJSON x
toJSON (QRight x) = toJSON x
verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user]))
verifyToken jwtw = do
let mToken = stripPrefix "Bearer " jwtw
unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
token <- asks (decodeToken @user (fromJust mToken)) >>= liftIO
liftIO $ putStrLn "decoded token:" >> print token
case token of
Left e -> throwError $ err500 { errBody = fromString $ show e }
Right (Jwe (header, body)) -> do
let jwt = fromJust . decode @JWT $ fromStrict body
-- TODO check if token grants access, then read logged in user from cookie
liftIO $ print jwt
ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens)
userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData)
userEndpoint = handleUserData
where
handleUserData :: Text -> AuthHandler user (Maybe userData)
handleUserData jwtw = do
let mToken = stripPrefix "Bearer " jwtw
unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
token <- asks (decodeToken @user (fromJust mToken)) >>= liftIO
liftIO $ putStrLn "decoded token:" >> print token
case token of
Left e -> throwError $ err500 { errBody = fromString $ show e }
Right (Jwe (header, body)) -> do
let jwt = fromJust . decode @JWT $ fromStrict body
-- TODO check if token grants access, then read logged in user from cookie
liftIO $ print jwt
mUser <- ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens)
case mUser of
Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes
Nothing -> throwError $ err500 { errBody = "Unknown token" }
handleUserData :: Text -> AuthHandler user (QueryResult userData)
handleUserData jwtw = verifyToken @user @userData jwtw >>= \case
Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
Nothing -> return . QLeft $ QError "UnknownToken"
userListEndpoint :: forall user userData . UserData user userData => AuthServer user (UserList userData)
userListEndpoint = handleUserData
where
handleUserData :: Text -> AuthHandler user [userData]
handleUserData jwtw = do
undefined
handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData])
handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users
Nothing -> return . QLeft $ QError "UnknownToken"
Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case
Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users
Nothing -> return . QLeft $ QError "UserDoesNotExist"
-------------------
@ -296,7 +329,6 @@ type Routing user userData = Auth
:<|> Token
:<|> Me userData
:<|> UserList userData
-- :<|> "qauth" :> Get '[HTML] Html
routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
routing = loginServer @user @userData
@ -304,7 +336,6 @@ routing = loginServer @user @userData
:<|> tokenEndpoint @user @userData
:<|> userEndpoint @user @userData
:<|> userListEndpoint @user @userData
-- :<|> return (loginPage "/foobar")

2
src/User.hs
View File

@ -20,4 +20,4 @@ class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show mayb
readScope :: String -> Scope u
showScope :: Scope u -> String
userScope :: u -> Scope u -> a
lookupUser :: UserName -> Password -> IO (Maybe u)
lookupUser :: UserName -> Maybe Password -> IO (Maybe u)