feat(auth): admin handler can query user data

shell.nix

@@ -9,7 +9,7 @@ let
 
   haskellPackages = pkgs.haskellPackages;
 
-  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=02510301ff4536f63182b798ca3551406c7e1aab&ref=refresh-tokens").packages.x86_64-linux;
+  oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=6fc2d621573e048b7ce2dabfc4887c7876055f8d&ref=user-queries").packages.x86_64-linux;
 
   oauth2MockServer = oauth2Flake.default;
   mkOauth2DB = oauth2Flake.mkOauth2DB;

src/Auth/OAuth2.hs

@@ -70,27 +70,27 @@ oauth2MockServer port =
 ---- User Queries ----
 ----------------------
 
-data UserData = UD
+data UserData = UD deriving (Show)
 instance FromJSON UserData where
   parseJSON _ = pure UD
 
-queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m)
+queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m)
                 => Text
                 -> Text
-                -> m (Either JSONException UserData)
+                -> m (Either JSONException Value)
 queryOAuth2User authPlugin userID = do
   (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin
   req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID
   mTokens <- lookupSessionJson SessionOAuth2Token
-  unless (isJust mTokens) . fail $ "Tried to load sesion Oauth2 tokens, but there are none"
+  unless (isJust mTokens) . liftIO . fail $ "Tried to load sesion Oauth2 tokens, but there are none"
   eNewToken <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl (authPlugin == azurePluginName)
   case eNewToken of
     Left e -> return $ Left e
     Right newTokens -> do
-      setSessionJson SessionOAuth2Token newTokens
-      getResponseBody <$> httpJSONEither @m @UserData (req
+      setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
+      getResponseBody <$> httpJSONEither @m @Value (req
         { secure = authPlugin == azurePluginName
-        , requestHeaders = [("Authorization", encodeUtf8 . atoken . fromJust $ fst newTokens)] })
+        , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] })
 
 mkBaseUrls :: Text -> IO (String, String)
 mkBaseUrls authPlugin
@@ -106,26 +106,28 @@ mkBaseUrls authPlugin
   | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin
 
 
-refreshOAuth2Token :: forall m x. (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m, x ~ (Maybe AccessToken, Maybe RefreshToken))
-                   => x
+refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m)
+                   => (Maybe AccessToken, Maybe RefreshToken)
                    -> String
                    -> Bool
-                   -> m (Either JSONException x)
-refreshOAuth2Token (_, refreshToken) url secure
-  | isJust refreshToken = do
+                   -> m (Either JSONException OAuth2Token)
+refreshOAuth2Token (_, rToken) url secure
+  | isJust rToken = do
     req <- parseRequest $ "POST " ++ url
     let
       body =
         [ ("grant_type", "refresh_token")
-        , ("refresh_token", encodeUtf8 . rtoken $ fromJust refreshToken)
-        , ("scope", "") -- TODO must be subset of previously requested scopes. space separated list
+        , ("refresh_token", encodeUtf8 . rtoken $ fromJust rToken)
         ]
     body' <- if secure then do
-        Just clientID <- liftIO $ lookupEnv "CLIENT_ID"
-        Just clientSecret <- liftIO $ lookupEnv "CLIENT_SECRET"
-        return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret)]
-      else return body
-    getResponseBody <$> httpJSONEither @m @x (urlEncodedBody body' req{ secure = secure })
-  | otherwise = fail "Could not refresh access token. Refresh token is missing."
-
+        clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID"
+        clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET"
+        return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")]
+      else return $ ("scope", "ID Profile") : body
+    $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
+    getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
+  | otherwise = liftIO $ fail "Could not refresh access token. Refresh token is missing."
 
+instance Show RequestBody where
+  show (RequestBodyLBS x) = show x
+  show _ = error ":("

src/Handler/Admin/OAuth2.hs

@@ -1,9 +1,9 @@
--- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@uniworx.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Handler.Admin.OAuth2
-  (  getAdminOAuth2R
+  ( getAdminOAuth2R
   , postAdminOAuth2R
   ) where
 
@@ -15,6 +15,12 @@ import Data.Text()
 --import Foundation.Yesod.Auth (CampusUserConversionException()) 
 import Handler.Utils
 
+# ifdef DEVELOPMENT
+import Auth.OAuth2 (queryOAuth2User, mockPluginName)
+# else
+import Auth.OAuth2 (queryOAuth2User, azurePluginName)
+# endif
+
 
 getAdminOAuth2R,   postAdminOAuth2R :: Handler Html
 getAdminOAuth2R  = postAdminOAuth2R
@@ -23,8 +29,14 @@ postAdminOAuth2R = do
      flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
  
    let procFormPerson :: Text -> Handler (Maybe Text)
-       procFormPerson lid = return . Just $ "Mock reply for id " <> lid
-       -- TODO implement oauth query
+       procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid
+# ifdef DEVELOPMENT
+         let authPlugin = mockPluginName
+# else
+         let authPlugin = azurePluginName
+# endif
+         eUserData <- queryOAuth2User authPlugin lid
+         return . Just $ tshow eUserData
    mOAuth2Data <- formResultMaybe presult procFormPerson
  
    --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html ->