packages feed

ms-graph-api (empty) → 0.1.0.0

raw patch · 13 files changed

+1033/−0 lines, 13 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, hoauth2, http-client, http-conduit, http-types, jwt, modern-uri, req, retry, scientific, scotty, stm, text, time, transformers, unliftio, uri-bytestring, validation-selective, wai, warp

Files

+ CHANGELOG.md view
@@ -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
+ 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-graph-api++Microsoft Graph API++https://learn.microsoft.com/en-us/graph/api/overview?view=graph-rest-1.0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ms-graph-api.cabal view
@@ -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
+ src/MSGraphAPI/Auth.hs view
@@ -0,0 +1,2 @@+module MSGraphAPI.Auth where+
+ src/MSGraphAPI/Drive.hs view
@@ -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")
+ src/MSGraphAPI/Files/DriveItems.hs view
@@ -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
+ src/MSGraphAPI/Internal/Common.hs view
@@ -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
+ src/MSGraphAPI/User.hs view
@@ -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")++
+ src/Network/OAuth2/JWT.hs view
@@ -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+
+ src/Network/OAuth2/Provider/AzureAD.hs view
@@ -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 '_'}+
+ src/Network/OAuth2/Session.hs view
@@ -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