feat(auth): tokens can be stored & refreshed

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"
         ]
 
 

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."
+
 

src/Utils/Session.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- 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)