ms-auth (empty) → 0.1.0.0
raw patch · 8 files changed
+884/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, hoauth2, http-client, http-types, jwt, scientific, scotty, text, time, transformers, unliftio, uri-bytestring, validation-micro
Files
- CHANGELOG.md +13/−0
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- ms-auth.cabal +52/−0
- src/Network/OAuth2/JWT.hs +233/−0
- src/Network/OAuth2/Provider/AzureAD.hs +153/−0
- src/Network/OAuth2/Session.hs +396/−0
+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog for `ms-auth`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0++Network.OAuth2.Session : Add App-only functionality
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# ms-auth++[](https://travis-ci.org/githubuser/ms-auth)++TODO Description.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ms-auth.cabal view
@@ -0,0 +1,52 @@+name: ms-auth+version: 0.1.0.0+synopsis: Microsoft Authentication API+description: Bindings to the Microsoft Identity API / Active Directory (AD) for building applications that use either Delegated or App-only permissions. Helper functions are provided for building OAuth2 authentication flows and keep tokens transactionally secure and up to date.+homepage: https://github.com/unfoldml/ms-auth+license: BSD3+license-file: LICENSE+author: Marco Zocca+maintainer: oss@unfoldml.com+copyright: 2023 Marco Zocca, UnfoldML+category: Web+build-type: Simple+extra-source-files: README.md+ CHANGELOG.md+cabal-version: >=1.10+tested-with: GHC == 9.2.8++library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules: Network.OAuth2.JWT+ Network.OAuth2.Session+ Network.OAuth2.Provider.AzureAD+ build-depends: base >= 4.7 && < 5+ , aeson+ , bytestring+ , containers+ , hoauth2 == 2.6.0+ , http-client+ , http-types+ , jwt+ , scientific+ , scotty+ , text+ , time+ , transformers+ , uri-bytestring+ , validation-micro+ , unliftio+ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wmissing-export-lists+ -Wmissing-home-modules+ -Wpartial-fields+ -Wredundant-constraints++source-repository head+ type: git+ location: https://github.com/unfoldml/ms-auth
+ src/Network/OAuth2/JWT.hs view
@@ -0,0 +1,233 @@+{-# Language DeriveFunctor #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# language OverloadedStrings #-}+{-# options_ghc -Wno-unused-top-binds #-}+-- | Decode and validate a JWT token+--+-- provides 'Validation' function for the individual fields as well+module Network.OAuth2.JWT (+ -- * 1) Decode a string into claims+ jwtClaims+ -- * 2) Extract and validate the individual claims+ , decValidSub, decValidExp, decValidNbf, decValidEmail, decValidAud+ , UserSub, userSub, UserEmail, userEmail, ApiAudience, apiAudience+ , JWTException(..)+ ) 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(..), bindValidation, 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++-- | Decode a string into a 'J.JWTClaimsSet'+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)++-- | @sub@+decValidSub :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserSub+decValidSub jc = decSub (J.sub jc)++-- | @exp@+decValidExp :: Maybe NominalDiffTime+ -> UTCTime -- ^ current time+ -> J.JWTClaimsSet+ -> Validation (NE.NonEmpty JWTException) UTCTime+decValidExp nsecs t jc = decExp (J.exp jc) `bindValidation` validateExp nsecs t++-- | @nbf@+decValidNbf :: UTCTime -- ^ current time+ -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UTCTime+decValidNbf t jc = decNbf (J.nbf jc) `bindValidation` validateNbf t++-- | @email@+decValidEmail :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserEmail+decValidEmail jc = decEmail (J.unClaimsMap $ J.unregisteredClaims jc)++-- | @aud@+decValidAud :: ApiAudience -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) T.Text+decValidAud a jc = decAud (J.aud jc) `bindValidation` validateAud 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+
+ src/Network/OAuth2/Provider/AzureAD.hs view
@@ -0,0 +1,153 @@+{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies #-}+{-# LANGUAGE QuasiQuotes, RecordWildCards #-}+{-# language OverloadedStrings #-}+{-# language DataKinds, TypeFamilies, TypeApplications #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# options_ghc -Wno-ambiguous-fields #-}+-- | Settings for using Azure Active Directory as OAuth identity provider+--+-- Both @Delegated@ (On-Behalf-Of) and @App-only@ (i.e. Client Credentials) authentication flows are supported. The former is useful when a user needs to login and delegate some permissions to the application (i.e. accessing personal data), whereas the second is for server processes and automation accounts.+module Network.OAuth2.Provider.AzureAD (+ AzureAD+ -- * App flow+ , azureADApp+ -- * Delegated permissions OAuth2 flow+ , OAuthCfg(..)+ , AzureADUser+ , azureOAuthADApp+ ) 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)+++-- * App-only flow++-- | Azure OAuth application (i.e. with user consent screen)+--+-- NB : scope @offline_access@ is ALWAYS requested+--+-- 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+azureADApp :: TL.Text -- ^ application name+ -> ClientId -> ClientSecret+ -> [Scope] -- ^ scopes+ -> IdpApplication 'ClientCredentials AzureAD+azureADApp appname clid sec scopes = defaultAzureADApp{+ idpAppName = appname+ , idpAppClientId = clid+ , idpAppClientSecret = sec+ , idpAppScope = Set.fromList (scopes <> ["offline_access"])+ }++defaultAzureADApp :: IdpApplication 'ClientCredentials AzureAD+defaultAzureADApp =+ ClientCredentialsIDPAppConfig+ { idpAppClientId = ""+ , idpAppClientSecret = ""+ , idpAppScope = Set.fromList ["offline_access"] -- https://learn.microsoft.com/EN-US/azure/active-directory/develop/scopes-oidc#openid-connect-scopes+ , idpAppTokenRequestExtraParams = Map.empty+ , idpAppName = "default-azure-app" --+ , idp = defaultAzureADIdp+ }+++-- * Delegated permissions flow++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+ }++-- | Azure OAuth application (i.e. with user consent screen)+--+-- 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+--+-- 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+azureOAuthADApp :: OAuthCfg -- ^ OAuth configuration+ -> IdpApplication 'AuthorizationCode AzureAD+azureOAuthADApp (OAuthCfg appname clid sec scopes authstate reduri) = defaultAzureOAuthADApp{+ idpAppName = appname+ , idpAppClientId = clid+ , idpAppClientSecret = sec+ , idpAppScope = Set.fromList (scopes <> ["openid", "offline_access"])+ , idpAppAuthorizeState = authstate+ , idpAppRedirectUri = reduri+ }++defaultAzureOAuthADApp :: IdpApplication 'AuthorizationCode AzureAD+defaultAzureOAuthADApp =+ 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 '_'}+
+ src/Network/OAuth2/Session.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds, TypeFamilies #-}+{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies, DeriveDataTypeable #-}+{-# language OverloadedStrings #-}+{-# options_ghc -Wno-unused-imports #-}+-- | MS Identity user session based on OAuth tokens+--+-- provides both Delegated permission flow (user-based) and App-only (e.g. server-server and automation accounts)+module Network.OAuth2.Session (+ -- * Azure App Service+ withAADUser+ -- * App-only flow+ , Token+ , newNoToken+ , expireToken+ , readToken+ , fetchUpdateToken+ -- * Delegated permissions flow+ -- ** OAuth 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.Functor (void)+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+++-- * App-only authorization scenarios (i.e via automation accounts. Human users not involved)+++-- app has one token at a time+type Token t = TVar (Maybe t)++newNoToken :: MonadIO m => m (Token t)+newNoToken = newTVarIO Nothing+expireToken :: MonadIO m => TVar (Maybe a) -> m ()+expireToken ts = atomically $ modifyTVar ts (const Nothing)+readToken :: MonadIO m => Token t -> m (Maybe t)+readToken ts = atomically $ readTVar ts++-- | Fetch an OAuth token and keep it updated. Should be called as a first thing in the app+--+-- NB : forks a thread in the background+--+-- https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow+fetchUpdateToken :: MonadIO m =>+ IdpApplication 'ClientCredentials AzureAD+ -> Token OAuth2Token+ -> Manager+ -> m ()+fetchUpdateToken idpApp ts mgr = liftIO $ void $ forkFinally loop cleanup+ where+ cleanup = \case+ Left e -> throwIO e+ Right _ -> pure ()+ loop = do+ tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr -- OAuth2 token+ case tokenResp of+ Left es -> throwIO (OASEOAuth2Errors es)+ Right oat -> do+ ein <- updateToken ts oat+ let+ dtSecs = (round ein - 30) -- 30 seconds before expiry+ threadDelay (dtSecs * 1000000) -- pause thread+ loop++updateToken :: (MonadIO m) =>+ Token OAuth2Token -> OAuth2Token -> m NominalDiffTime+updateToken ts oat = do+ let+ ein = fromIntegral $ fromMaybe 3600 (expiresIn oat) -- expires in [sec]+ atomically $ do+ writeTVar ts (Just oat)+ pure ein+++++-- * Delegated permission flow (i.e. human user involved)++-- | 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+--+-- NB : forks a thread per logged in user to keep their tokens up to date+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+ _ <- fetchUpdateTokenDeleg 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+fetchUpdateTokenDeleg :: MonadIO m =>+ Tokens UserSub OAuth2Token+ -> IdpApplication 'AuthorizationCode AzureAD+ -> Manager+ -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes+ -> ExceptT OAuthSessionError m OAuth2Token+fetchUpdateTokenDeleg 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+ _ <- refreshLoopDeleg 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@+refreshLoopDeleg :: (MonadIO m, Ord uid, HasRefreshTokenRequest a) =>+ Tokens uid OAuth2Token+ -> IdpApplication a i+ -> Manager+ -> uid -- ^ user ID+ -> OAuth2Token+ -> m ThreadId+refreshLoopDeleg ts idpApp mgr uid oaToken = liftIO $ 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 <- upsertToken ts uid oat -- replace new token for user uid 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+upsertToken :: (MonadIO m, Ord uid) =>+ Tokens uid OAuth2Token+ -> uid -- ^ user id+ -> OAuth2Token -- ^ new token+ -> m NominalDiffTime -- ^ token expires in+upsertToken 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