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

query user by email

Browse Source
This commit is contained in:
David Mosbach 2024-01-29 01:26:10 +00:00
parent 31f99eef37
commit 9f3f9d47b5
2 changed files with 32 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
src/Server.hs
View File

@ -159,7 +159,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
@ -255,7 +255,23 @@ type Me userData = Users
type UserList userData = Users
:> "query"
:> HeaderR "Authorization" Text
:> Get '[JSON] [userData] -- TODO support query params
:> QParam "id" Text
:> Get '[JSON] [userData]
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)
@ -263,28 +279,24 @@ 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" }
mUser <- verifyToken @user @userData jwtw
case mUser of
Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes
Nothing -> throwError $ err500 { errBody = "Unknown token" }
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 [userData]
handleUserData jwtw userID = do
mAdmin <- verifyToken @user @userData jwtw
unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" }
-- TODO check if this user is allowed query other users
mUser <- liftIO $ lookupUser @user @userData userID Nothing
case mUser of
Just u -> return [mconcat $ map (userScope @user @userData u) (snd $ fromJust mAdmin)] -- TODO support queries that fit for multiple users
Nothing -> throwError $ err500 { errBody = "This user does not exist" }
-------------------
@ -296,7 +308,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 +315,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)