From 9f3f9d47b59294a492f6076beec38a158e2cf646 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 29 Jan 2024 01:26:10 +0000 Subject: [PATCH 1/6] query user by email --- src/Server.hs | 52 ++++++++++++++++++++++++++++++--------------------- src/User.hs | 2 +- 2 files changed, 32 insertions(+), 22 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 922d66a..7ff1de3 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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") diff --git a/src/User.hs b/src/User.hs index c49eccd..b1d0aea 100644 --- a/src/User.hs +++ b/src/User.hs @@ -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) From 3f2bf3cc6e2d26091ec7bcafd298c1c999c083ec Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 30 Jan 2024 04:30:00 +0000 Subject: [PATCH 2/6] adjusted grant type for refresh tokens --- src/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 7ff1de3..976d463 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -200,8 +200,8 @@ instance FromHttpApiData AuthFlow where instance FromForm ClientData where fromForm f = ClientData - <$> ((parseUnique @AuthFlow "grant_type" f) *> ((Left . ACode <$> parseUnique "code" f) - <|> (Right <$> parseUnique "refresh_token" f))) + <$> (((parseUnique @AuthFlow "grant_type" f) *> (Left . ACode <$> parseUnique "code" f)) + <|> ((parseUnique @String "refresh_token" f) *> (Right <$> parseUnique "refresh_token" f))) <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f From c8ed2166dc4edd5413ab08c00a8dd2cf530d2ebc Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 30 Jan 2024 20:35:12 +0000 Subject: [PATCH 3/6] renamed expected refresh token key --- src/Server.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index 976d463..dfdb44d 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -201,7 +201,7 @@ instance FromHttpApiData AuthFlow where instance FromForm ClientData where fromForm f = ClientData <$> (((parseUnique @AuthFlow "grant_type" f) *> (Left . ACode <$> parseUnique "code" f)) - <|> ((parseUnique @String "refresh_token" f) *> (Right <$> parseUnique "refresh_token" f))) + <|> ((parseUnique @String "grant_type" f >>= \p -> if p == "refresh_token" then Right p else Left (pack p)) *> (Right <$> parseUnique "refresh_token" f))) <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f @@ -220,6 +220,7 @@ 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" } From 101cf0ca99c40e25f69f44b16603e3528c0aade8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 31 Jan 2024 02:17:55 +0000 Subject: [PATCH 4/6] fixed checking refresh tokens --- src/AuthCode.hs | 29 ++++++++++++++--------------- src/Server.hs | 28 +++++++++++++++++++--------- 2 files changed, 33 insertions(+), 24 deletions(-) diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 101b232..da21caf 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -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 + diff --git a/src/Server.hs b/src/Server.hs index dfdb44d..b233fee 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -53,7 +53,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(..)) @@ -185,9 +185,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 +200,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)) - <|> ((parseUnique @String "grant_type" f >>= \p -> if p == "refresh_token" then Right p else Left (pack p)) *> (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 @@ -211,21 +214,24 @@ instance Error Text where type Token = "token" - :> ReqBody '[FormUrlEncoded] ClientData + :> ReqBody '[FormUrlEncoded] Form --ClientData :> Post '[JSON] JWTWrapper tokenEndpoint :: forall user userData . UserData user userData => AuthServer user Token tokenEndpoint = provideToken where - provideToken :: ClientData -> AuthHandler user JWTWrapper - provideToken client = do - liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client + provideToken :: Form -> AuthHandler user JWTWrapper + provideToken clienty = do + liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show clienty + liftIO . print $ fromForm @ClientData clienty + let Right client = fromForm @ClientData clienty 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} @@ -233,8 +239,11 @@ 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 + liftIO $ putStrLn "woohoo" case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -291,6 +300,7 @@ userListEndpoint = handleUserData where handleUserData :: Text -> Text -> AuthHandler user [userData] handleUserData jwtw userID = do + liftIO $ putStrLn "\nHOEHOEHOEHOEHOEHOHEHJBSDKFJBSDKGHBSDKGHBK\a\n" mAdmin <- verifyToken @user @userData jwtw unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" } -- TODO check if this user is allowed query other users From 6fc2d621573e048b7ce2dabfc4887c7876055f8d Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 31 Jan 2024 13:41:59 +0000 Subject: [PATCH 5/6] removed debuging print --- src/Server.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index b233fee..053070e 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -300,7 +300,6 @@ userListEndpoint = handleUserData where handleUserData :: Text -> Text -> AuthHandler user [userData] handleUserData jwtw userID = do - liftIO $ putStrLn "\nHOEHOEHOEHOEHOEHOHEHJBSDKFJBSDKGHBSDKGHBK\a\n" mAdmin <- verifyToken @user @userData jwtw unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" } -- TODO check if this user is allowed query other users From d47908b4f7883b4b485abf1ee06645495ccdc7b3 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 9 Feb 2024 17:10:34 +0000 Subject: [PATCH 6/6] query related errors are now returned as json --- src/Server.hs | 61 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 25 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 053070e..6942e9b 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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' @@ -214,18 +223,16 @@ instance Error Text where type Token = "token" - :> ReqBody '[FormUrlEncoded] Form --ClientData + :> ReqBody '[FormUrlEncoded] ClientData :> Post '[JSON] JWTWrapper tokenEndpoint :: forall user userData . UserData user userData => AuthServer user Token tokenEndpoint = provideToken where - provideToken :: Form -> AuthHandler user JWTWrapper - provideToken clienty = do - liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show clienty - liftIO . print $ fromForm @ClientData clienty - let Right client = fromForm @ClientData clienty + 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" } @@ -243,7 +250,6 @@ tokenEndpoint = provideToken unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } liftIO $ putStrLn "... checking refresh token" mToken <- asks (renewToken @user jwtw) >>= liftIO - liftIO $ putStrLn "woohoo" case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -260,13 +266,23 @@ 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 :> QParam "id" Text - :> Get '[JSON] [userData] + :> 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])) @@ -287,26 +303,21 @@ verifyToken jwtw = do userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData) userEndpoint = handleUserData where - handleUserData :: Text -> AuthHandler user (Maybe userData) - handleUserData jwtw = do - 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" } + 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 -> 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" } + 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" -------------------