From c8fa509ace7cc0746ac1df5678b49e393f39d397 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 30 Jan 2024 05:06:06 +0000 Subject: [PATCH] feat(auth): tokens can be stored & refreshed --- src/Application.hs | 4 +-- src/Auth/OAuth2.hs | 70 ++++++++++++++++++++++++++++++++++---------- src/Utils/Session.hs | 3 +- 3 files changed, 58 insertions(+), 19 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index e4c75668b..08fef42ee 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -62,7 +62,7 @@ import Jobs import qualified Data.Text.Encoding as Text import qualified Data.Text as Text -import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2) +import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped) import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -338,7 +338,7 @@ makeFoundation appSettings''@AppSettings{..} = do appAuthPlugins <- liftIO $ sequence [ (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT" - , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" + , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2" ] diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 8be0e5111..e4dc20433 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -9,9 +9,10 @@ module Auth.OAuth2 , azurePluginName , oauth2MockServer , mockPluginName -, queryOauth2User +, queryOAuth2User ) where +import Data.Maybe (fromJust) import Data.Text import Import.NoFoundation hiding (unpack) @@ -21,7 +22,7 @@ import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException) import System.Environment (lookupEnv) import Yesod.Auth.OAuth2 -import Yesod.Auth.OAuth2.Prelude +import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8) data AzureUserException = AzureUserError @@ -73,21 +74,58 @@ data UserData = UD instance FromJSON UserData where parseJSON _ = pure UD -queryOauth2User :: forall m . (MonadIO m, MonadThrow m) +queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m) => Text -> Text -> m (Either JSONException UserData) -queryOauth2User authPlugin userID = do - baseUrl <- liftIO mkBaseUrl - req <- parseRequest $ "GET " ++ baseUrl ++ unpack userID - -- TODO get new token & put token in auth header - getResponseBody <$> httpJSONEither @m @UserData req - where - mkBaseUrl :: IO String - mkBaseUrl - | authPlugin == azurePluginName = return "https://graph.microsoft.com/v1.0/users/" - | authPlugin == mockPluginName = do - Just port <- lookupEnv "OAUTH2_SERVER_PORT" - return $ "http://localhost:" ++ port ++ "/users/query?id=" - | otherwise = fail $ unpack authPlugin +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" + 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 + { secure = authPlugin == azurePluginName + , requestHeaders = [("Authorization", encodeUtf8 . atoken . fromJust $ fst newTokens)] }) + +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 + + +refreshOAuth2Token :: forall m x. (MonadIO m, MonadThrow m, MonadHandler m, MonadFail m, x ~ (Maybe AccessToken, Maybe RefreshToken)) + => x + -> String + -> Bool + -> m (Either JSONException x) +refreshOAuth2Token (_, refreshToken) url secure + | isJust refreshToken = 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 + ] + 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." + diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs index ef104b29c..4b5e5c378 100644 --- a/src/Utils/Session.hs +++ b/src/Utils/Session.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -20,6 +20,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags | SessionLang | SessionError | SessionFiles + | SessionOAuth2Token deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite)