From d4cfce317d00714404ea3640cae8ad25182594b0 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 3 Feb 2024 20:48:32 +0000 Subject: [PATCH] feat(auth): formatted output of user queries --- src/Auth/OAuth2.hs | 75 +++++++++++++++++++++--------------- src/Foundation/Yesod/Auth.hs | 4 ++ src/Handler/Admin/OAuth2.hs | 24 +++++------- templates/oauth2.hamlet | 3 +- 4 files changed, 58 insertions(+), 48 deletions(-) diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index a184d7ddd..fab04ca16 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -10,6 +10,7 @@ module Auth.OAuth2 , oauth2MockServer , mockPluginName , queryOAuth2User +, UserDataException ) where import Data.Maybe (fromJust) @@ -70,47 +71,54 @@ oauth2MockServer port = ---- User Queries ---- ---------------------- -data UserData = UD deriving (Show) -instance FromJSON UserData where - parseJSON _ = pure UD +data UserDataException = UserDataJSONException JSONException + | UserDataInternalException Text + deriving Show -queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m) +instance Exception UserDataException + +queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m) => Text - -> Text - -> m (Either JSONException Value) -queryOAuth2User authPlugin userID = do - (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin + -> m (Either UserDataException j) +queryOAuth2User userID = runExceptT $ do + (queryUrl, tokenUrl) <- liftIO mkBaseUrls req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID mTokens <- lookupSessionJson SessionOAuth2Token - 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 (Just $ accessToken newTokens, refreshToken newTokens) - getResponseBody <$> httpJSONEither @m @Value (req - { secure = authPlugin == azurePluginName - , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) + unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none" +# ifdef DEVELOPMENT + let secure = False +# else + let secure = True +# endif + newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure + setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req + { secure = secure + , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x -mkBaseUrls :: Text -> IO (String, String) -mkBaseUrls authPlugin - | authPlugin == azurePluginName = do - Just tenantID <- lookupEnv "AZURE_TENANT_ID" - return ( "https://graph.microsoft.com/v1.0/users/" - , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) - | authPlugin == mockPluginName = do - Just port <- lookupEnv "OAUTH2_SERVER_PORT" - let base = "http://localhost:" ++ port - return ( base ++ "/users/query?id=" - , base ++ "/token" ) - | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin + +mkBaseUrls :: IO (String, String) +mkBaseUrls = do +# ifndef DEVELOPMENT + Just tenantID <- lookupEnv "AZURE_TENANT_ID" + return ( "https://graph.microsoft.com/v1.0/users/" + , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) +# else + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" ++ port + return ( base ++ "/users/query?id=" + , base ++ "/token" ) +# endif refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m) => (Maybe AccessToken, Maybe RefreshToken) -> String -> Bool - -> m (Either JSONException OAuth2Token) + -> ExceptT UserDataException m OAuth2Token refreshOAuth2Token (_, rToken) url secure | isJust rToken = do req <- parseRequest $ "POST " ++ url @@ -125,8 +133,11 @@ refreshOAuth2Token (_, rToken) url secure 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." + eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + | otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing." instance Show RequestBody where show (RequestBodyLBS x) = show x diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 2bd046479..7c3594a53 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -24,6 +24,7 @@ import Handler.Utils.Memcached import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message +import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) import Auth.LDAP import Auth.OAuth2 import Auth.PWHash (apHash) @@ -131,6 +132,9 @@ oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX => Creds UniWorX -> m (AuthenticationResult UniWorX) oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds) + sess <- getSession + $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" now <- liftIO getCurrentTime let diff --git a/src/Handler/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs index 997a61756..1face989f 100644 --- a/src/Handler/Admin/OAuth2.hs +++ b/src/Handler/Admin/OAuth2.hs @@ -9,17 +9,14 @@ module Handler.Admin.OAuth2 import Import -- import qualified Data.CaseInsensitive as CI -import Data.Text() ---import qualified Data.Text as Text +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T --import qualified Data.Text.Encoding as Text --import Foundation.Yesod.Auth (CampusUserConversionException()) import Handler.Utils -# ifdef DEVELOPMENT -import Auth.OAuth2 (queryOAuth2User, mockPluginName) -# else -import Auth.OAuth2 (queryOAuth2User, azurePluginName) -# endif +import Auth.OAuth2 (queryOAuth2User) getAdminOAuth2R, postAdminOAuth2R :: Handler Html @@ -28,15 +25,12 @@ postAdminOAuth2R = do ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing - let procFormPerson :: Text -> Handler (Maybe Text) + let procFormPerson :: Text -> Handler (Maybe T.Text) 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 + eUserData <- queryOAuth2User @Value lid + case eUserData of + Left e -> throwM e + Right userData -> return . Just . T.decodeUtf8 $ encodePretty userData mOAuth2Data <- formResultMaybe presult procFormPerson --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> diff --git a/templates/oauth2.hamlet b/templates/oauth2.hamlet index 23030ebd6..90711a799 100644 --- a/templates/oauth2.hamlet +++ b/templates/oauth2.hamlet @@ -13,6 +13,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Antwort: #
- #{show answers} + 
+              #{answers}