diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `ms-graph-api` + +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 - YYYY-MM-DD 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-graph-api + +Microsoft Graph API + +https://learn.microsoft.com/en-us/graph/api/overview?view=graph-rest-1.0 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-graph-api.cabal b/ms-graph-api.cabal new file mode 100644 --- /dev/null +++ b/ms-graph-api.cabal @@ -0,0 +1,83 @@ +name: ms-graph-api +version: 0.1.0.0 +synopsis: Microsoft Graph API +description: Bindings to the Microsoft Graph API +homepage: https://github.com/unfoldml/ms-graph-api +license: BSD3 +license-file: LICENSE +author: Marco Zocca +maintainer: oss@unfoldml.com +copyright: 2023 Marco Zocca +category: Web +build-type: Simple +extra-source-files: README.md + CHANGELOG.md +cabal-version: >=1.10 +tested-with: GHC == 9.2.7 + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: MSGraphAPI.Internal.Common + MSGraphAPI.User + MSGraphAPI.Drive + MSGraphAPI.Files.DriveItems + Network.OAuth2.Provider.AzureAD + Network.OAuth2.Session + other-modules: MSGraphAPI.Auth + Network.OAuth2.JWT + build-depends: base >= 4.7 && < 5 + , aeson + , bytestring + , containers + , hoauth2 + , http-client + , http-conduit + , http-types + , jwt + , modern-uri + , req + , retry + , scientific + , scotty + , stm + , text + , time + , transformers >= 0.5 + , unliftio + , uri-bytestring + , validation-selective + , wai + , warp + ghc-options: -Wall + -Wcompat + -Wno-unused-imports + default-extensions: OverloadedStrings + DeriveGeneric + DeriveFunctor + DerivingStrategies + + +-- test-suite spec +-- default-language: Haskell2010 +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Spec.hs +-- other-modules: LibSpec +-- build-depends: base +-- , ms-graph-api +-- , hspec +-- , QuickCheck +-- 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-graph-api diff --git a/src/MSGraphAPI/Auth.hs b/src/MSGraphAPI/Auth.hs new file mode 100644 --- /dev/null +++ b/src/MSGraphAPI/Auth.hs @@ -0,0 +1,2 @@ +module MSGraphAPI.Auth where + diff --git a/src/MSGraphAPI/Drive.hs b/src/MSGraphAPI/Drive.hs new file mode 100644 --- /dev/null +++ b/src/MSGraphAPI/Drive.hs @@ -0,0 +1,52 @@ +module MSGraphAPI.Drive where + +import Data.Int (Int64) +import GHC.Generics (Generic(..)) + +-- aeson +import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON) +-- hoauth +import Network.OAuth.OAuth2.Internal (AccessToken(..)) +-- req +import Network.HTTP.Req (Req) +-- text +import Data.Text (Text, pack, unpack) + +import qualified MSGraphAPI.Internal.Common as MSG (get, post, Collection, aesonOptions) + +-- | Get drive of current user +getDriveMe :: AccessToken -> Req Drive +getDriveMe = MSG.get ["me", "drive"] mempty + +-- | List children in the root of the current user's drive +-- +-- https://learn.microsoft.com/en-us/graph/api/driveitem-list-children?view=graph-rest-1.0&tabs=http#list-children-in-the-root-of-the-current-users-drive +getDriveItemsMe :: AccessToken -> Req (MSG.Collection DriveItem) +getDriveItemsMe = MSG.get ["me", "drive", "root", "children"] mempty + +-- | List children in the root of the current user's drive +-- +-- @GET \/drives\/{drive-id}\/items\/{item-id}\/children@ +-- +-- https://learn.microsoft.com/en-us/graph/api/driveitem-list-children?view=graph-rest-1.0&tabs=http#list-children-in-the-root-of-the-current-users-drive +getDriveItemChildren :: Text -- ^ drive ID + -> Text -- ^ item ID + -> AccessToken + -> Req (MSG.Collection DriveItem) +getDriveItemChildren did itemId = MSG.get ["drives", did, "items", itemId, "children"] mempty + +data Drive = Drive { + dId :: Text + } deriving (Eq, Show, Generic) + +instance A.FromJSON Drive where + parseJSON = A.genericParseJSON (MSG.aesonOptions "d") + + +data DriveItem = DriveItem { + diName :: Text + , diSize :: Maybe Int64 + } deriving (Eq, Show, Generic) + +instance A.FromJSON DriveItem where + parseJSON = A.genericParseJSON (MSG.aesonOptions "di") diff --git a/src/MSGraphAPI/Files/DriveItems.hs b/src/MSGraphAPI/Files/DriveItems.hs new file mode 100644 --- /dev/null +++ b/src/MSGraphAPI/Files/DriveItems.hs @@ -0,0 +1,32 @@ +module MSGraphAPI.Files.DriveItems where + +import GHC.Generics (Generic(..)) + +-- aeson +import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON) +-- bytestring +import qualified Data.ByteString.Lazy as LBS (ByteString) +-- hoauth +import Network.OAuth.OAuth2.Internal (AccessToken(..)) +-- req +import Network.HTTP.Req (Req) +-- text +import Data.Text (Text, pack, unpack) + +import qualified MSGraphAPI.Internal.Common as MSG (get, getLbs, post, Collection, aesonOptions) + +-- | download a complete file from user's directory +-- +-- @GET \/me\/drive\/items\/{item-id}\/content@ +-- +-- https://learn.microsoft.com/en-us/graph/api/driveitem-get-content?view=graph-rest-1.0&tabs=http#request +downloadFileMe :: Text -> AccessToken -> Req LBS.ByteString +downloadFileMe itemId = MSG.getLbs ["me", "drive", "items", itemId, "content"] mempty + +-- | download a file from a drive +-- +-- https://learn.microsoft.com/en-us/graph/api/driveitem-get-content?view=graph-rest-1.0&tabs=http#request +downloadFile :: Text -- ^ drive ID + -> Text -- ^ file ID + -> AccessToken -> Req LBS.ByteString +downloadFile did itemId = MSG.getLbs ["drives", did, "items", itemId, "content"] mempty diff --git a/src/MSGraphAPI/Internal/Common.hs b/src/MSGraphAPI/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/MSGraphAPI/Internal/Common.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# options_ghc -Wno-unused-imports #-} +-- | Common functions for the MS Graph API v1.0 +-- +-- https://learn.microsoft.com/en-us/graph/api/overview?view=graph-rest-1.0&preserve-view=true +module MSGraphAPI.Internal.Common ( + -- * GET + get + , getLbs + -- * POST + , post + -- * running requests + , runReq + -- * JSON : aeson helpers + , Collection(..) + , aesonOptions + ) where + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Proxy (Proxy) +import GHC.Generics (Generic(..)) + +import Data.List (sort, sortBy, stripPrefix, uncons) +import Data.Maybe (listToMaybe, fromMaybe) +-- import Data.Ord (comparing) +import Data.Char (toLower) + +-- aeson +import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=), Key, Value, camelTo2) +-- bytestring +import qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Char8 as BS8 (pack, unpack) +import qualified Data.ByteString.Lazy as LBS (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn) +-- hoauth2 +import Network.OAuth.OAuth2 (OAuth2Token(..)) +import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..)) +-- modern-uri +import Text.URI (URI, mkURI) +-- req +import Network.HTTP.Req (Req, runReq, defaultHttpConfig, req, Option, (=:), GET(..), POST(..), Url, Scheme(..), useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody) +-- text +import Data.Text (Text, pack, unpack) + +import Network.OAuth2.Session (Tokens) + + +-- -- GET, POST + +-- | @POST https:\/\/graph.microsoft.com\/v1.0\/...@ +post :: (A.FromJSON b, A.ToJSON a) => + [Text] -- ^ URI segments + -> Option 'Https + -> a -- ^ request body + -> AccessToken + -> Req b +post paths params bdy tok = responseBody <$> req POST url (ReqBodyJson bdy) jsonResponse opts + where + opts = auth <> params + (url, auth) = msGraphReqConfig tok paths + +-- | @GET https:\/\/graph.microsoft.com\/v1.0\/...@ +get :: A.FromJSON a => + [Text] -- ^ URI segments + -> Option 'Https + -> AccessToken + -> Req a +get paths params tok = responseBody <$> req GET url NoReqBody jsonResponse opts + where + opts = auth <> params + (url, auth) = msGraphReqConfig tok paths + +getLbs :: [Text] -> Option 'Https -> AccessToken -> Req LBS.ByteString +getLbs paths params tok = responseBody <$> req GET url NoReqBody lbsResponse opts + where + opts = auth <> params + (url, auth) = msGraphReqConfig tok paths + +msGraphReqConfig :: AccessToken -> [Text] -> (Url 'Https, Option 'Https) +msGraphReqConfig (AccessToken ttok) uriRest = (url, os) + where + url = (https "graph.microsoft.com" /: "v1.0") //: uriRest + os = oAuth2Bearer $ BS8.pack (unpack ttok) + +(//:) :: Url scheme -> [Text] -> Url scheme +(//:) = foldl (/:) + + +-- * aeson + +-- | a collection of items with key @value@ +data Collection a = Collection { + cValue :: [a] + } deriving (Eq, Show, Generic) +instance A.FromJSON a => A.FromJSON (Collection a) where + parseJSON = A.genericParseJSON (aesonOptions "c") + +-- | drop the prefix and lowercase first character +-- +-- e.g. @userDisplayName@ @->@ @displayName@ +aesonOptions :: String -- ^ record prefix + -> A.Options +aesonOptions pfx = A.defaultOptions { A.fieldLabelModifier = recordName pfx } + +-- | drop the prefix and lowercase first character +recordName :: String -- ^ record name prefix + -> String -- ^ JSON field name + -> String +recordName pf str = case uncons $ dropPrefix pf str of + Just (c, cs) -> toLower c : cs + _ -> error "record name cannot be empty" + +-- | Drops the given prefix from a list. +-- It returns the original sequence if the sequence doesn't start with the given prefix. +-- +-- > dropPrefix "Mr. " "Mr. Men" == "Men" +-- > dropPrefix "Mr. " "Dr. Men" == "Dr. Men" +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix a b = fromMaybe b $ stripPrefix a b diff --git a/src/MSGraphAPI/User.hs b/src/MSGraphAPI/User.hs new file mode 100644 --- /dev/null +++ b/src/MSGraphAPI/User.hs @@ -0,0 +1,47 @@ +module MSGraphAPI.User where + +import GHC.Generics (Generic(..)) + +import Data.List (sort, sortBy, stripPrefix, uncons) +import Data.Maybe (listToMaybe, fromMaybe) +-- import Data.Ord (comparing) +import Data.Char (toLower) +import Data.String (IsString(..)) +import Data.Word (Word) + +-- aeson +import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=), Key, Value, camelTo2) +import qualified Data.Aeson.Types as A (Parser, Object) +-- import qualified Data.Aeson.KeyMap as AKV (KeyMap, lookup) +-- containers +-- import qualified Data.Map as M (Map, empty, insert, lookup) +-- 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 (ZonedTime, zonedTimeToLocalTime) + +import qualified MSGraphAPI.Internal.Common as MSG (get, post, aesonOptions) + +-- | https://learn.microsoft.com/en-us/graph/api/user-get?view=graph-rest-1.0&tabs=http#request +get :: Text -- ^ user id + -> AccessToken -> Req User +get uid = MSG.get ["users", uid] mempty + +-- | get signed-in user https://learn.microsoft.com/en-us/graph/api/user-get?view=graph-rest-1.0&tabs=http#request-1 +getMe :: AccessToken -> Req User +getMe = MSG.get ["me"] mempty + + +data User = User { + uId :: Text + , uUserPrincipalName :: Text + , uDisplayName :: Text + } deriving (Eq, Ord, Show, Generic) +instance A.FromJSON User where + parseJSON = A.genericParseJSON (MSG.aesonOptions "u") + + 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,223 @@ +{-# 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) +-- -- hoauth2 +-- import Network.OAuth.OAuth2 (OAuth2Token(..), IdToken(..)) +-- 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-selective +import Validation (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 + 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,105 @@ +{-# 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 -- (authGetJSON, ClientSecretBasic) +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 + +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 : OIDC scopes @openid@ and @offline_access@ are ALWAYS requested since the library assumes we have access to refresh tokens and ID tokens +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 '_'} + 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,322 @@ +{-# 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 + , UserSub + , lookupUser + , expireUser + -- * 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) +-- -- heaps +-- import qualified Data.Heap as H (Heap, empty, null, size, insert, viewMin, deleteMin, Entry(..), ) +-- hoauth2 +import Network.OAuth.OAuth2 (OAuth2Token(..)) +import Network.OAuth2.Experiment (IdpUserInfo, conduitUserInfoRequest, mkAuthorizeRequest, conduitTokenRequest, conduitRefreshTokenRequest) +import Network.OAuth2.Experiment.Types (HasRefreshTokenRequest(..), WithExchangeToken(..), IdpApplication(..), GrantTypeFlow(..)) +import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..)) +import Network.OAuth.OAuth2.TokenRequest (Errors) +-- http-client +import Network.HTTP.Client (Manager) +-- http-conduit +import Network.HTTP.Conduit (newManager, tlsManagerSettings) +-- 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 (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 extracted from the headers 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) -- $ azureADApp oacfg) + 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 -- $ T.pack $ unwords ["cannot decode token"] + +-- + +-- 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 -- IO (Either T.Text 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) -- $ T.pack (show e) -- ^ id token validation failed + Left es -> pure $ Left (OASEOAuth2Errors es) + +refreshLoop :: (MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) => + Tokens uid OAuth2Token + -> IdpApplication a i + -> Manager + -> uid + -> OAuth2Token + -> m ThreadId +refreshLoop ts idpApp mgr uid oaToken = forkFinally (act oaToken) cleanup + where + cleanup = \case + Left _ -> pure () -- FIXME what to do in case of auth errors? + 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"] + + +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 + +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)} + +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) + +-- | transactional token store +type Tokens uid t = TVar (TokensData uid t) +data TokensData uid t = TokensData { + thUsersMap :: M.Map uid t + } + + +-- | 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