diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# ms-auth + +[![Build Status](https://travis-ci.org/githubuser/ms-auth.png)](https://travis-ci.org/githubuser/ms-auth) + +TODO Description. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ms-auth.cabal b/ms-auth.cabal new file mode 100644 --- /dev/null +++ b/ms-auth.cabal @@ -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 diff --git a/src/Network/OAuth2/JWT.hs b/src/Network/OAuth2/JWT.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/JWT.hs @@ -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 + diff --git a/src/Network/OAuth2/Provider/AzureAD.hs b/src/Network/OAuth2/Provider/AzureAD.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Provider/AzureAD.hs @@ -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 '_'} + diff --git a/src/Network/OAuth2/Session.hs b/src/Network/OAuth2/Session.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Session.hs @@ -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