From 453034100b38540a884ebfa4d46fdba04cf90b77 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 31 Jan 2024 14:32:49 +0000 Subject: [PATCH] feat(auth): admin handler can query user data --- shell.nix | 2 +- src/Auth/OAuth2.hs | 44 +++++++++++++++++++------------------ src/Handler/Admin/OAuth2.hs | 20 +++++++++++++---- 3 files changed, 40 insertions(+), 26 deletions(-) diff --git a/shell.nix b/shell.nix index 9c43c44cf..4b114f966 100644 --- a/shell.nix +++ b/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; diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index e4dc20433..a184d7ddd 100644 --- a/src/Auth/OAuth2.hs +++ b/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 ":(" diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index fdd8b8f63..997a61756 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -1,9 +1,9 @@ --- SPDX-FileCopyrightText: 2023 Sarah Vaupel ,David Mosbach +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel ,David Mosbach -- -- 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 ->