ms-graph-api 0.6.0.0 → 0.7.0.0

raw patch · 9 files changed

+98/−683 lines, 9 filesdep −http-clientdep −jwtdep −scottyPVP ok

version bump matches the API change (PVP)

Dependencies removed: http-client, jwt, scotty, uri-bytestring, validation-micro, wai, warp

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• README.md +1/−1
• ms-graph-api.cabal +6/−16
• src/MSGraphAPI/ChangeNotifications/Subscription.hs +73/−0
• src/MSGraphAPI/Internal/Common.hs +0/−1
• src/MSGraphAPI/Users/Group.hs +1/−1
• src/Network/OAuth2/JWT.hs +0/−221
• src/Network/OAuth2/Provider/AzureAD.hs +0/−108
• src/Network/OAuth2/Session.hs +0/−335

@@ -8,7 +8,24 @@  ## Unreleased ++++## 0.7.0.0++MSGraphAPI.ChangeNotifications.Subscription:+- add createSubscription++*Breaking changes*++Moved the Network/* module hierarchy to the `ms-auth` package shared with `ms-azure-api`.+ ## 0.6.0.0++MSGraphAPI.Users.Group :+- Group+- getUserJoinedTeams+- getGroupsDriveItems  Depend on `validation-micro` rather than `validation-selective`. 

@@ -24,7 +24,7 @@  Some breaking changes might also be introduced as the library matures. -We adhere to a simplified version of the [Package Versioning Policy](https://pvp.haskell.org/): breaking changes are signaled by increasing the major version number (e.g. 0.x -> 1.x ).+We adhere to the [Package Versioning Policy](https://pvp.haskell.org/): major breaking changes or API refactors are signaled by increasing the first major version number (i.e. 0.0.0.0 -> 1.0.0.0 ) whereas less significant ones are indicated by increasing the second one (0.0.0.0 -> 0.1.0.0)   ## Copyright

@@ -1,8 +1,8 @@ name:                ms-graph-api-version:             0.6.0.0+version:             0.7.0.0 synopsis:            Microsoft Graph API description:         Bindings to the Microsoft Graph API-homepage:            https://github.com/unfoldml/ms-graph-api+homepage:            https://github.com/unfoldml/ms-api license:             BSD3 license-file:        LICENSE author:              Marco Zocca@@ -13,43 +13,32 @@ extra-source-files:  README.md                      CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 9.2.7+tested-with:         GHC == 9.2.8  library   default-language:    Haskell2010   hs-source-dirs:      src-  exposed-modules:     +  exposed-modules:     MSGraphAPI.ChangeNotifications.Subscription                        MSGraphAPI.User                        MSGraphAPI.Users.User                        MSGraphAPI.Users.Group                        MSGraphAPI.Drive                        MSGraphAPI.Files.DriveItem-                       Network.OAuth2.Provider.AzureAD-                       Network.OAuth2.Session                        MSGraphAPI.Internal.Common-  other-modules:       -                       MSGraphAPI.Auth-                       Network.OAuth2.JWT+  other-modules:       MSGraphAPI.Auth   build-depends:       base >= 4.7 && < 5                      , aeson                      , bytestring                      , containers                      , hoauth2 == 2.6.0-                     , http-client                      , http-types-                     , jwt                      , modern-uri                      , req                      , scientific-                     , scotty                      , text                      , time >= 1.8                      , transformers >= 0.5                      , unliftio-                     , uri-bytestring-                     , validation-micro-                     , wai-                     , warp   ghc-options:         -Wall                        -Wcompat                        -Wno-unused-imports@@ -57,6 +46,7 @@                        DeriveGeneric                        DeriveFunctor                        DerivingStrategies+                       LambdaCase   -- test-suite spec

@@ -0,0 +1,73 @@+module MSGraphAPI.ChangeNotifications.Subscription where++import Data.List.NonEmpty (NonEmpty)+import GHC.Generics (Generic(..))++-- aeson+import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), eitherDecode, genericParseJSON, genericToEncoding, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=))+import qualified Data.Aeson.Encoding as A (text)+-- hoauth+import Network.OAuth.OAuth2.Internal (AccessToken(..))+-- req+import Network.HTTP.Req (Req)+-- text+import Data.Text (Text, pack, unpack)+-- time+import Data.Time (LocalTime)++import qualified MSGraphAPI.Internal.Common as MSG (Collection(..), get, post, aesonOptions)+import MSGraphAPI.Files.DriveItem (DriveItem)++-- | Creating a subscription requires read scope to the resource. For example, to get change notifications on messages, your app needs the Mail.Read permission.+createSubscription :: (A.FromJSON b) => Subscription -> AccessToken -> Req b+createSubscription = MSG.post ["subscriptions"] mempty++-- | A subscription allows a client app to receive change notifications about changes to data in Microsoft Graph.+--+-- https://learn.microsoft.com/en-us/graph/api/resources/subscription?view=graph-rest-1.0+data Subscription = Subscription {+  cnsId :: Text+  , cnsChangeType :: NonEmpty ChangeType+  , cnsClientState :: Text+  , cnsExpirationDateTime :: LocalTime+  , cnsNotificationUrl :: Text -- ^ The URL of the endpoint that will receive the change notifications. This URL must make use of the HTTPS protocol. Any query string parameter included in the notificationUrl property will be included in the HTTP POST request when Microsoft Graph sends the change notifications.+  , cnsResource :: Text -- ^ Specifies the resource that will be monitored for changes. Do not include the base URL (https://graph.microsoft.com/v1.0/)+  , cnsLatestSupportedTLSVersion :: LatestTLSVer+                   } deriving (Eq, Show, Generic)+instance A.FromJSON Subscription where+  parseJSON = A.genericParseJSON (MSG.aesonOptions "cns")+instance A.ToJSON Subscription where+  toEncoding = A.genericToEncoding (MSG.aesonOptions "cns")++data LatestTLSVer = LTV10 | LTV11 | LTV12 | LTV13 deriving (Eq, Show, Generic)+instance A.FromJSON LatestTLSVer where+  parseJSON = A.withText "LatestTLSVer" $ \t ->+    case t of+      "v1_0" -> pure LTV10+      "v1_1" -> pure LTV11+      "v1_2" -> pure LTV12+      "v1_3" -> pure LTV13+      x -> fail $ unwords ["LatestTLSVer : unexpected value:", unpack x]+instance A.ToJSON LatestTLSVer where+  toEncoding = \case+    LTV10 -> A.text "v1_0"+    LTV11 -> A.text "v1_1"+    LTV12 -> A.text "v1_2"+    LTV13 -> A.text "v1_3"++data ChangeType = CTCreated+                | CTUpdated+                | CTDeleted+                deriving (Eq, Show, Generic)+instance A.FromJSON ChangeType where+  parseJSON = A.withText "ChangeType" $ \t ->+    case t of+      "created" -> pure CTCreated+      "updated" -> pure CTUpdated+      "deleted" -> pure CTDeleted+      x -> fail $ unwords ["ChangeType : unexpected value:", unpack x]+instance A.ToJSON ChangeType where+  toEncoding = \case+    CTCreated -> A.text "created"+    CTUpdated -> A.text "updated"+    CTDeleted -> A.text "deleted"

@@ -50,7 +50,6 @@ import UnliftIO (MonadUnliftIO(..)) import UnliftIO.Exception (try) -import Network.OAuth2.Session (Tokens)   -- | Specialized version of 'try' to 'HttpException's

@@ -17,7 +17,7 @@  -- | Groups are collections of principals with shared access to resources in Microsoft services or in your app. Different principals such as users, other groups, devices, and applications can be part of groups.  ----- httpstea://learn.microsoft.com/en-us/graph/api/resources/groups-overview?view=graph-rest-1.0&tabs=http+-- https://learn.microsoft.com/en-us/graph/api/resources/groups-overview?view=graph-rest-1.0&tabs=http data Group = Group {   gId :: Text   , gDisplayName :: Text

@@ -1,221 +0,0 @@-{-# Language DeriveFunctor #-}-{-# language DeriveGeneric #-}-{-# language DerivingStrategies #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# language OverloadedStrings #-}-module Network.OAuth2.JWT where--import Control.Monad.IO.Class (MonadIO(..))-import qualified Data.List.NonEmpty as NE (NonEmpty(..))-import GHC.Exception (Exception(..))-import GHC.Generics (Generic)-import Data.Maybe (fromMaybe)-import Data.String (IsString(..))-import Data.Typeable---- aeson-import qualified Data.Aeson as A (FromJSON(..), ToJSON(..), ToJSONKey(..), FromJSON(..), FromJSONKey(..), Value(..))--- containers-import qualified Data.Map.Strict as M (Map, lookup)--- jwt-import qualified Web.JWT as J (decode, claims, JWTClaimsSet(..), StringOrURI, NumericDate, ClaimsMap(..))--- scientific-import Data.Scientific (coefficient)--- text-import qualified Data.Text as T (Text, unpack)--- time-import Data.Time (UTCTime(..), NominalDiffTime, getCurrentTime, fromGregorian, addUTCTime, diffUTCTime)--- validation-micro-import Validation.Micro (Validation(..), failure, validationToEither, maybeToSuccess)----- | 'sub' field-newtype UserSub = UserSub { userSub :: T.Text }-  deriving (Eq, Ord, Generic, IsString)-  deriving newtype (Show, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey)--newtype UserEmail = UserEmail { userEmail :: T.Text }-  deriving (Eq, Ord, Generic, IsString)-  deriving newtype (Show, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey)---- | intended audience of the token (== API key ID )-newtype ApiAudience = ApiAudience { apiAudience :: T.Text } deriving (Eq, Ord, Show, Generic, Typeable, IsString)-instance A.ToJSON ApiAudience--jwtClaims :: T.Text -> Maybe J.JWTClaimsSet-jwtClaims t = J.claims <$> J.decode t---- | decoded claims from the JWT token, valid (at least) for the Google OpenID implementation as of February 2021----data JWTClaims =-  JWTClaims {-    jcAud :: T.Text -- "aud"ience field-  , jcExp :: UTCTime -- "exp"iry date-  , jcIat :: UTCTime -- Issued AT-  , jcNbf :: UTCTime -- Not BeFore-  , jcSub :: UserSub -- "sub"ject-  , jcEmail :: UserEmail-            } deriving (Eq, Show)--decValidSub :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserSub-decValidSub jc = decSub (J.sub jc)--decValidExp :: Maybe NominalDiffTime-            -> UTCTime-            -> J.JWTClaimsSet-            -> Validation (NE.NonEmpty JWTException) UTCTime-decValidExp nsecs t jc = decExp (J.exp jc) `bindValidation` validateExp nsecs t--decValidNbf :: UTCTime -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UTCTime-decValidNbf t jc = decNbf (J.nbf jc) `bindValidation` validateNbf t--decValidEmail :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserEmail-decValidEmail jc = decEmail (J.unClaimsMap $ J.unregisteredClaims jc)--decValidAud :: ApiAudience -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) T.Text-decValidAud a jc = decAud (J.aud jc) `bindValidation` validateAud a---- | NB Validation is not a monad though-bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b-bindValidation v f = case v of-  Failure e -> Failure e-  Success a -> f a----- | Decode and validate the 'aud', 'exp' and 'nbf' fields of the JWT-decodeValidateJWT :: MonadIO f =>-                     ApiAudience -- ^ intended token audience (its meaning depends on the OAuth identity provider )-                  -> Maybe NominalDiffTime -- ^ buffer period to allow for API roundtrip delays (defaults to 0 if Nothing)-                  -> T.Text -- ^ JWT-encoded string, e.g. the contents of the id_token field-                  -> f (Either (NE.NonEmpty JWTException) JWTClaims)-decodeValidateJWT iaud nsecs jstr = case validationToEither $ decodeJWT jstr of-  Right jwc -> validationToEither <$> validateJWT iaud nsecs jwc-  Left e -> pure $ Left e----- | Validate the 'aud', 'exp' and 'nbf' fields-validateJWT :: MonadIO m =>-               ApiAudience -- ^ intended token audience (its meaning depends on the OAuth identity provider )-            -> Maybe NominalDiffTime-            -> JWTClaims-            -> m (Validation (NE.NonEmpty JWTException) JWTClaims)-validateJWT a nsecs j = do-  t <- liftIO getCurrentTime-  pure (-    JWTClaims <$>-      validateAud a (jcAud j) <*>-      validateExp nsecs t (jcExp j) <*>-      pure (jcIat j) <*>-      validateNbf t (jcNbf j) <*>-      pure (jcSub j) <*>-      pure (jcEmail j)-       )---- | Fails if the 'exp'iry field is not at least 'nsecs' seconds in the future-validateExp :: Maybe NominalDiffTime -- ^ defaults to 0 if Nothing-            -> UTCTime -> UTCTime -> Validation (NE.NonEmpty JWTException) UTCTime-validateExp nsecs t texp = do-  if fromMaybe 0 nsecs `addUTCTime` texp > t then-    Success texp-    else failure (JEExpiredToken texp)----- | Fails if the current time is before the 'nbf' time (= token is not yet valid)-validateNbf :: UTCTime -> UTCTime -> Validation (NE.NonEmpty JWTException) UTCTime-validateNbf t tnbf = do-  if t `diffUTCTime` tnbf > 0 then-    Success tnbf-    else failure (JENotYetValid tnbf)---- | Fails if the 'aud'ience field is not equal to the supplied ApiAudience-validateAud :: ApiAudience -- ^ intended audience of the token (== API key ID )-            -> T.Text -- ^ decoded from the JWT-            -> Validation (NE.NonEmpty JWTException) T.Text-validateAud aa@(ApiAudience a) audt-  | a == audt = Success audt-  | otherwise = failure $ JEAudienceNotFound aa--decodeJWT :: T.Text-          -> Validation (NE.NonEmpty JWTException) JWTClaims-decodeJWT jwts = case J.claims <$> J.decode jwts of-  Nothing -> failure $ JEMalformedJWT jwts-  Just (J.JWTClaimsSet _ subm audm expm nbfm iatm _ (J.ClaimsMap cms)) ->-    JWTClaims <$>-      decAud audm <*>-      decExp expm <*>-      decIat iatm <*>-      decNbf nbfm <*>-      decSub subm <*>-      decEmail cms--decAud :: Maybe (Either J.StringOrURI [J.StringOrURI])-       -> Validation (NE.NonEmpty JWTException) T.Text-decAud aam = claimNotFound "aud" (fromAud aam)--decExp :: Maybe J.NumericDate -> Validation (NE.NonEmpty JWTException) UTCTime-decExp em = claimNotFound "exp" (fromNumericDate em)--decIat :: Maybe J.NumericDate -> Validation (NE.NonEmpty JWTException) UTCTime-decIat im = claimNotFound "iat" (fromNumericDate im)--decNbf :: Maybe J.NumericDate-       -> Validation (NE.NonEmpty JWTException) UTCTime-decNbf im = claimNotFound "nbf" (fromNumericDate im)--decSub :: A.ToJSON a =>-          Maybe a -> Validation (NE.NonEmpty JWTException) UserSub-decSub sm = claimNotFound "sub" (UserSub <$> fromStringOrUri sm)--decEmail :: (Ord k, IsString k) =>-            M.Map k A.Value -> Validation (NE.NonEmpty JWTException) UserEmail-decEmail cms = claimNotFound "email" (case M.lookup "email" cms of-                                           Just (A.String ems) -> Just $ UserEmail ems-                                           _ -> Nothing)--claimNotFound :: String -> Maybe a -> Validation (NE.NonEmpty JWTException) a-claimNotFound c = maybeToSuccess (JEClaimNotFound c NE.:| [])---- | Possible exception states of authentication request-data JWTException = JEMalformedJWT T.Text-                   | JEClaimNotFound String-                   | JEAudienceNotFound ApiAudience-                   | JEExpiredToken UTCTime-                   | JENotYetValid UTCTime-                   | JENoToken-                   deriving (Eq, Ord, Generic, Typeable)--instance Show JWTException where-  show = \case-    JEMalformedJWT jt -> unwords ["Cannot decode JWT token :", T.unpack jt]-    JEClaimNotFound c -> unwords ["JWT claim not found :", c]-    JEAudienceNotFound a -> unwords ["audience", show a, "not found"]-    JEExpiredToken t -> unwords ["JWT token expired on", show t]-    JENotYetValid t -> unwords ["JWT token not yet valid:", show t]-    JENoToken -> "No token found"-instance Exception JWTException-instance A.ToJSON JWTException--fromAud :: Maybe (Either J.StringOrURI [J.StringOrURI]) -> Maybe T.Text-fromAud mm = maybe Nothing f mm-  where-    g str = case A.toJSON str of-      A.String s -> Just s-      _ -> Nothing-    f = \case-      Left sou -> g sou-      Right sous -> mconcat <$> traverse g sous--fromNumericDate :: Maybe J.NumericDate -> Maybe UTCTime-fromNumericDate tjm = case A.toJSON tjm of-  A.Number x -> Just $ addUTCTime (fromIntegral $ coefficient x) epoch-  _ -> Nothing--fromStringOrUri :: (A.ToJSON a) => Maybe a -> Maybe T.Text-fromStringOrUri sm = case A.toJSON sm of-  A.String t -> Just t-  _ -> Nothing--epoch :: UTCTime-epoch = UTCTime (fromGregorian 1970 1 1) 0-

@@ -1,108 +0,0 @@-{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies #-}-{-# LANGUAGE QuasiQuotes, RecordWildCards #-}-{-# language OverloadedStrings #-}-{-# language DataKinds, TypeFamilies, TypeApplications #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# options_ghc -Wno-ambiguous-fields #-}-module Network.OAuth2.Provider.AzureAD (-  -- * OAuth2 configuration-  OAuthCfg(..)-  , AzureAD-  , AzureADUser-  , azureADApp) where---- import Data.String (IsString(..))--- import GHC.Generics---- aeson-import Data.Aeson--- containers-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set--- hoauth2-import Network.OAuth.OAuth2 (ClientAuthenticationMethod(..), authGetJSON)-import Network.OAuth2.Experiment (IdpApplication(..), Idp(..), IdpUserInfo, GrantTypeFlow(..), ClientId(..), ClientSecret, Scope, AuthorizeState)--- text-import qualified Data.Text as T (Text)-import qualified Data.Text.Lazy as TL (Text)--- uri-bytestring-import URI.ByteString (URI)-import URI.ByteString.QQ (uri)---data AzureAD = AzureAD deriving (Eq, Show)--type instance IdpUserInfo AzureAD = AzureADUser---- | Configuration object of the OAuth2 application-data OAuthCfg = OAuthCfg {-  oacAppName :: TL.Text -- ^ application name-  , oacClientId :: ClientId -- ^ app client ID : see https://stackoverflow.com/a/70670961-  , oacClientSecret :: ClientSecret -- ^ app client secret "-  , oacScopes :: [Scope]  -- ^ OAuth2 and OIDC scopes-  , oacAuthState :: AuthorizeState -- ^ OAuth2 'state' (a random string, https://www.rfc-editor.org/rfc/rfc6749#section-10.12 )-  , oacRedirectURI :: URI -- ^ OAuth2 redirect URI-                         }---- | NB : scopes @openid@ and @offline_access@ are ALWAYS requested since the library assumes we have access to refresh tokens and ID tokens------ Reference on Microsoft Graph permissions : https://learn.microsoft.com/en-us/graph/permissions-reference-azureADApp :: OAuthCfg -- ^ OAuth configuration-           -> IdpApplication 'AuthorizationCode AzureAD-azureADApp (OAuthCfg appname clid sec scopes authstate reduri) = defaultAzureADApp{-  idpAppName = appname-  , idpAppClientId = clid-  , idpAppClientSecret = sec-  , idpAppScope = Set.fromList (scopes <> ["openid", "offline_access"])-  , idpAppAuthorizeState = authstate-  , idpAppRedirectUri = reduri-  }---- create app at https://go.microsoft.com/fwlink/?linkid=2083908------ also be aware to find the right client id.--- see https://stackoverflow.com/a/70670961-defaultAzureADApp :: IdpApplication 'AuthorizationCode AzureAD-defaultAzureADApp =-  AuthorizationCodeIdpApplication-    { idpAppClientId = ""-    , idpAppClientSecret = ""-    , idpAppScope = Set.fromList ["openid", "offline_access", "profile", "email"] -- https://learn.microsoft.com/EN-US/azure/active-directory/develop/scopes-oidc#openid-connect-scopes-    , idpAppAuthorizeState = "CHANGE_ME" -- https://stackoverflow.com/questions/26132066/what-is-the-purpose-of-the-state-parameter-in-oauth-authorization-request-    , idpAppAuthorizeExtraParams = Map.empty-    , idpAppRedirectUri = [uri|http://localhost|] ---    , idpAppName = "default-azure-app" ---    , idpAppTokenRequestAuthenticationMethod = ClientSecretBasic-    , idp = defaultAzureADIdp-    }---- | https://login.microsoftonline.com/common/v2.0/.well-known/openid-configuration-defaultAzureADIdp :: Idp AzureAD-defaultAzureADIdp =-  Idp-    { idpFetchUserInfo = authGetJSON @(IdpUserInfo AzureAD)-    , idpUserInfoEndpoint = [uri|https://graph.microsoft.com/oidc/userinfo|]-    , idpAuthorizeEndpoint = [uri|https://login.microsoftonline.com/common/oauth2/v2.0/authorize|]-    , idpTokenEndpoint = [uri|https://login.microsoftonline.com/common/oauth2/v2.0/token|]-    }---- | https://learn.microsoft.com/en-us/azure/active-directory/develop/userinfo-data AzureADUser = AzureADUser-  { sub :: T.Text-  , email :: Maybe T.Text -- requires the “email” OIDC scope.-  , familyName :: Maybe T.Text -- all names require the “profile” OIDC scope.-  , givenName :: Maybe T.Text-  , name :: Maybe T.Text-  }-  deriving (Eq, Ord, Show)--instance FromJSON AzureADUser where-  parseJSON = withObject "AzureADUser" $ \o -> AzureADUser <$>-    o .: "sub" <*>-    o .:? "email" <*>-    o .:? "family_name" <*>-    o .:? "given_name" <*>-    o .:? "name"----   parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}-

@@ -1,335 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DataKinds #-}-{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies, DeriveDataTypeable  #-}-{-# language OverloadedStrings #-}-{-# options_ghc -Wno-unused-imports #-}--- | OAuth user session-module Network.OAuth2.Session (-  -- * Azure App Service-  withAADUser-  -- * OAuth2 endpoints-  , loginEndpoint-  , replyEndpoint-  -- * In-memory user session-  , Tokens-  , newTokens-  , UserSub-  , lookupUser-  , expireUser-  , tokensToList-  -- * Scotty misc-  , Scotty-  , Action-                              ) where--import Control.Exception (Exception(..), SomeException(..))-import Control.Monad.IO.Class (MonadIO(..))-import Data.List.NonEmpty (NonEmpty)-import Data.Maybe (fromMaybe)-import Data.String (IsString(..))-import Data.Typeable (Typeable)-import GHC.Exception (SomeException)---- aeson-import Data.Aeson--- bytestring-import qualified Data.ByteString.Lazy.Char8 as BSL--- containers-import qualified Data.Map as M (Map, insert, lookup, alter, toList)--- -- heaps--- import qualified Data.Heap as H (Heap, empty, null, size, insert, viewMin, deleteMin, Entry(..), )--- hoauth2-import Network.OAuth.OAuth2 (OAuth2Token(..), AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))-import Network.OAuth2.Experiment (IdpUserInfo, conduitUserInfoRequest, mkAuthorizeRequest, conduitTokenRequest, conduitRefreshTokenRequest, HasRefreshTokenRequest(..), WithExchangeToken, IdpApplication(..), GrantTypeFlow(..))-import Network.OAuth.OAuth2.TokenRequest (Errors)--- http-client-import Network.HTTP.Client (Manager)--- http-types-import Network.HTTP.Types (status302, status400, status401)--- scotty-import Web.Scotty (scotty, RoutePattern)-import Web.Scotty.Trans (scottyT, ActionT, ScottyT, get, raise, redirect, params, header, setHeader, status, text)--- text-import qualified Data.Text as T (Text, pack, unwords)-import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict, takeWhile, fromStrict)--- time-import Data.Time (UTCTime(..), getCurrentTime, fromGregorian, diffUTCTime, addUTCTime, Day, NominalDiffTime)-import Data.Time.Format (FormatTime, formatTime, iso8601DateFormat, defaultTimeLocale)--- transformers-import Control.Monad.Trans.Except (ExceptT(..), withExceptT, runExceptT, throwE)--- unliftio-import UnliftIO (MonadUnliftIO(..))-import UnliftIO.Concurrent (ThreadId, forkFinally, threadDelay)-import UnliftIO.Exception (throwIO)-import UnliftIO.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar)--- uri-bytestring-import URI.ByteString (URI)--- validation-selective-import Validation.Micro (Validation, failure, validationToEither)--import Network.OAuth2.Provider.AzureAD (OAuthCfg, azureADApp, AzureAD)-import Network.OAuth2.JWT (jwtClaims, UserSub(..), userSub, ApiAudience, apiAudience, decValidSub, decValidExp, decValidNbf, JWTException(..))--type Action = ActionT TL.Text-type Scotty = ScottyT TL.Text---- * Azure App Service adds headers into each request, which the backend can access to identify the user------ https://learn.microsoft.com/en-us/azure/app-service/configure-authentication-user-identities#access-user-claims-in-app-code---- | The JWT identity token from the @X-MS-TOKEN-AAD-ID-TOKEN@ header injected by App Service can be decoded for its claims e.g. @sub@ (which is unique for each user for a given app)------ https://bogdan.bynapse.com/azure/the-app-service-token-store-was-added-to-app-service-authentication-authorization-and-it-is-a-repository-of-oauth-tokens-associated-with-your-app-users-when-a-user-logs-into-your-app-via-an-iden/------ https://stackoverflow.com/questions/46757665/authentication-for-azure-functions/-aadHeaderIdToken :: (MonadIO m) =>-                    (UserSub -> Action m ()) -- ^ look up the UserSub's token, do stuff with it-                 -> Action m ()-aadHeaderIdToken act = do-  let-    hdrName = "X-MS-TOKEN-AAD-ID-TOKEN"-  mh <- header hdrName-  case mh of-    Nothing -> do-      text $ TL.pack $ unwords ["header", TL.unpack hdrName, "not found in request"]-      status status400-    Just h -> do-      let-        idt = IdToken $ TL.toStrict h-      ide <- decValidIdToken idt-      case ide of-        Right usub -> act usub-        Left e -> do-          text $ TL.pack $ unwords ["AAD header ID token validation exception:", show e]-          status status401---- | Decode the App Service ID token header @X-MS-TOKEN-AAD-ID-TOKEN@, look its user up in the local token store, supply token @t@ to continuation. If the user @sub@ cannot be found in the token store the browser is redirected to the login URI.------ Special case of 'aadHeaderIdToken'-withAADUser :: MonadIO m =>-               Tokens UserSub t-            -> TL.Text -- ^ login URI-            -> (t -> Action m ()) -- ^ call MSGraph APIs with token @t@, etc.-            -> Action m ()-withAADUser ts loginURI act = aadHeaderIdToken $ \usub -> do-  mt <- lookupUser ts usub-  case mt of-    Just t -> act t-    _ -> do-      liftIO $ putStrLn $ unwords ["User", show usub, "not authenticated. Redirecting to login:", TL.unpack loginURI]-      redirect loginURI----- * OAuth flow---- | Login endpoint------ see 'azureADApp'-loginEndpoint :: (MonadIO m) =>-                 IdpApplication 'AuthorizationCode AzureAD-              -> RoutePattern -- ^ e.g. @"/login"@-              -> Scotty m ()-loginEndpoint idpApp path = get path (loginH idpApp)---- | login endpoint handler-loginH :: Monad m =>-          IdpApplication 'AuthorizationCode AzureAD-       -> Action m ()-loginH idpApp = do-  setHeader "Location" (mkAuthorizeRequest idpApp) -- redirect to OAuth consent screen-  status status302---- | The identity provider redirects the client to the 'reply' endpoint as part of the OAuth flow : https://learn.microsoft.com/en-us/graph/auth-v2-user?view=graph-rest-1.0&tabs=http#authorization-response------ see 'azureADApp'-replyEndpoint :: MonadIO m =>-                 IdpApplication 'AuthorizationCode AzureAD-              -> Tokens UserSub OAuth2Token-              -> Manager-              -> RoutePattern -- ^ e.g. @"/oauth\/reply"@-              -> Scotty m ()-replyEndpoint idpApp ts mgr path =-  get path (replyH idpApp ts mgr)--replyH :: MonadIO m =>-          IdpApplication 'AuthorizationCode AzureAD-       -> Tokens UserSub OAuth2Token-       -> Manager-       -> Action m ()-replyH idpApp ts mgr = do-  ps <- params-  excepttToActionM $ do-       case lookup "code" ps of-         Just codeP -> do-           let-             etoken = ExchangeToken $ TL.toStrict codeP-           _ <- fetchUpdateToken ts idpApp mgr etoken-           pure ()-         Nothing -> throwE OASEExchangeTokenNotFound-------- oauth2ErrorToText :: Show a => a -> T.Text--- oauth2ErrorToText e = T.pack $ "Unable to fetch access token. Details : " ++ show e---- bslToText :: BSL.ByteString -> T.Text--- bslToText = T.pack . BSL.unpack----- | 1) the ExchangeToken arrives with the redirect once the user has approved the scopes in the browser--- https://learn.microsoft.com/en-us/graph/auth-v2-user?view=graph-rest-1.0&tabs=http#authorization-response-fetchUpdateToken :: MonadUnliftIO m =>-                    Tokens UserSub OAuth2Token-                 -> IdpApplication 'AuthorizationCode AzureAD-                 -> Manager-                 -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes-                 -> ExceptT OAuthSessionError m OAuth2Token-fetchUpdateToken ts idpApp mgr etoken = ExceptT $ do-  tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr etoken -- OAuth2 token-  case tokenResp of-    Right oat -> case idToken oat of-      Nothing -> pure $ Left OASENoOpenID-      Just idt -> do-        idtClaimsE <- decValidIdToken idt -- decode and validate ID token-        case idtClaimsE of-          Right uid -> do-            _ <- refreshLoop ts idpApp mgr uid oat -- fork a thread and start refresh loop for this user-            pure $ Right oat-          Left es -> pure $ Left (OASEJWTException es) -- id token validation failed-    Left es -> pure $ Left (OASEOAuth2Errors es)---- | 2) fork a thread and start token refresh loop for user @uid@-refreshLoop :: (MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) =>-               Tokens uid OAuth2Token-            -> IdpApplication a i-            -> Manager-            -> uid -- ^ user ID-            -> OAuth2Token-            -> m ThreadId-refreshLoop ts idpApp mgr uid oaToken = forkFinally (act oaToken) cleanup-  where-    cleanup = \case-      Left _ -> do-        expireUser ts uid -- auth error(s), remove user from memory-      Right _ -> pure ()-    act oat = do-      ein <- updateToken ts uid oat -- replace new token in memory-      let-        dtSecs = (round ein - 30) -- 30 seconds before expiry-      threadDelay (dtSecs * 1000000) -- pause thread-      case refreshToken oat of-        Nothing -> do-          expireUser ts uid -- cannot refresh, remove user from memory-          throwIO OASERefreshTokenNotFound -- no refresh token-        Just rt -> do-          eo' <- runExceptT $ conduitRefreshTokenRequest idpApp mgr rt -- get a new OAuth2 token-          case eo' of-            Right oat' -> do-              act oat' -- loop-            Left e -> throwIO (OASEOAuth2Errors e) -- refresh token request failed--data OAuthSessionError = OASERefreshTokenNotFound-                       | OASEExchangeTokenNotFound-                       | OASEOAuth2Errors (OAuth2Error Errors)-                       | OASEJWTException (NonEmpty JWTException)-                       | OASENoOpenID-                       deriving (Eq, Typeable)-instance Exception OAuthSessionError-instance Show OAuthSessionError where-  show = \case-    OASERefreshTokenNotFound -> unwords ["Refresh token not found in OAT"]-    OASEExchangeTokenNotFound -> unwords ["Exchange token not found. This shouldn't happen"]-    OASEOAuth2Errors oerrs ->-      unwords ["OAuth2 error(s):", show oerrs]-    OASEJWTException jwtes -> unwords ["JWT error(s):", show jwtes]-    OASENoOpenID -> unwords ["No ID token found. Ensure 'openid' scope appears in token request"]---- | Insert or update a token in the 'Tokens' object-updateToken :: (MonadIO m, Ord uid) =>-               Tokens uid OAuth2Token-            -> uid -- ^ user id-            -> OAuth2Token -- ^ new token-            -> m NominalDiffTime -- ^ token expires in-updateToken ts uid oat = do-  let-    ein = fromIntegral $ fromMaybe 3600 (expiresIn oat) -- expires in [sec]-  atomically $ do-    thp <- readTVar ts-    let-      m' = M.insert uid oat (thUsersMap thp)-    writeTVar ts (TokensData m')-    pure ein---- | Remove a user, i.e. they will have to authenticate once more-expireUser :: (MonadIO m, Ord uid) =>-              Tokens uid t-           -> uid -- ^ user identifier e.g. @sub@-           -> m ()-expireUser ts uid =-  atomically $ modifyTVar ts $ \td -> td{ thUsersMap = M.alter (const Nothing) uid (thUsersMap td)}---- | Look up a user identifier and return their current token, if any-lookupUser :: (MonadIO m, Ord uid) =>-              Tokens uid t-           -> uid -- ^ user identifier e.g. @sub@-           -> m (Maybe t)-lookupUser ts uid = atomically $ do-  thp <- readTVar ts-  pure $ M.lookup uid (thUsersMap thp)---- | return a list representation of the 'Tokens' object-tokensToList :: MonadIO m => Tokens k a -> m [(k, a)]-tokensToList ts = atomically $ do-  (TokensData m) <- readTVar ts-  pure $ M.toList m---- | Create an empty 'Tokens' object-newTokens :: (MonadIO m, Ord uid) => m (Tokens uid t)-newTokens = newTVarIO (TokensData mempty)---- | transactional token store-type Tokens uid t = TVar (TokensData uid t)-newtype TokensData uid t = TokensData {-  thUsersMap :: M.Map uid t-  } deriving (Eq, Show)------ | Decode and validate ID token--- https://learn.microsoft.com/en-us/azure/active-directory/develop/userinfo#consider-using-an-id-token-instead-decValidIdToken :: MonadIO m =>-                   IdToken -- ^ appears in the OAuth2Token if scopes include @openid@-                -> m (Either (NonEmpty JWTException) UserSub) -- ^ (sub)-decValidIdToken (IdToken idt) = do-  t <- liftIO getCurrentTime-  let-    ve = validationToEither $-         case jwtClaims idt of-           Just c -> (,,) <$> decValidSub c <*> decValidExp Nothing t c <*> decValidNbf t c-           _ -> failure $ JEMalformedJWT (T.unwords ["cannot decode token string"])-  case ve of-    Right (usub, _, _) -> pure $ Right usub-    Left e -> pure $ Left e------ | Lift ExceptT to ActionM which is basically the handler Monad in Scotty.-excepttToActionM :: (MonadIO m, Show e) =>-                    ExceptT e IO b -> Action m b-excepttToActionM e = do-  result <- liftIO $ runExceptT e-  either (raise . TL.pack . show) pure result----- playground---- atomicallyWithAfter :: MonadUnliftIO m =>---                        TVar a---                     -> Int -- ^ delay in microseconds (see 'threadDelay')---                     -> (a -> a)---                     -> m ThreadId--- atomicallyWithAfter tv dt f = forkFinally act (\_ -> pure ())---   where---     act = do---       threadDelay dt---       atomically $ modifyTVar tv f