Merge branch 'user-queries' into 'main'

User Queries

See merge request mosbach/oauth2-mock-server!4

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

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'
@@ -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)
+    <$>  ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f)))
-                                                <|> (Right <$> 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 :: Text -> AuthHandler user (QueryResult userData)
-    handleUserData jwtw = do
+    handleUserData jwtw = verifyToken @user @userData jwtw >>= \case
-      let mToken = stripPrefix "Bearer " jwtw
+      Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
-      unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
+      Nothing -> return . QLeft $ QError "UnknownToken"
-      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" }
       
 
 userListEndpoint :: forall user userData . UserData user userData => AuthServer user (UserList userData)
 userListEndpoint = handleUserData
   where
-    handleUserData :: Text -> AuthHandler user [userData]
+    handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData])
-    handleUserData jwtw = do
+    handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users
-      undefined
+      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")
 
 
 

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)