diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ ## Unreleased +## 0.5.0.0 + +Add 'getE', 'postE', 'tryReq' to pattern match against HTTP exceptions + ## 0.4.0.0 Add Session.tokensToList and Session.newTokens diff --git a/ms-graph-api.cabal b/ms-graph-api.cabal --- a/ms-graph-api.cabal +++ b/ms-graph-api.cabal @@ -1,5 +1,5 @@ name: ms-graph-api -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Microsoft Graph API description: Bindings to the Microsoft Graph API homepage: https://github.com/unfoldml/ms-graph-api diff --git a/src/MSGraphAPI/Internal/Common.hs b/src/MSGraphAPI/Internal/Common.hs --- a/src/MSGraphAPI/Internal/Common.hs +++ b/src/MSGraphAPI/Internal/Common.hs @@ -7,10 +7,15 @@ -- * GET get , getLbs + -- ** catch HTTP exceptions + , getE -- * POST , post + -- ** catch HTTP exceptions + , postE -- * running requests , runReq + , tryReq -- * JSON : aeson helpers , Collection(..) , aesonOptions @@ -38,17 +43,27 @@ -- 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) +import Network.HTTP.Req (Req, runReq, HttpException(..), 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) +-- unliftio +import UnliftIO (MonadUnliftIO(..)) +import UnliftIO.Exception (try) import Network.OAuth2.Session (Tokens) +-- | Specialized version of 'try' to 'HttpException's +-- +-- This can be used to catch exceptions of composite 'Req' statements, e.g. around a @do@ block +tryReq :: Req a -> Req (Either HttpException a) +tryReq = try + + -- -- GET, POST -- | @POST https:\/\/graph.microsoft.com\/v1.0\/...@ -post :: (A.FromJSON b, A.ToJSON a) => +post :: (A.ToJSON a, A.FromJSON b) => [Text] -- ^ URI path segments -> Option 'Https -> a -- ^ request body @@ -59,6 +74,12 @@ opts = auth <> params (url, auth) = msGraphReqConfig tok paths +-- | Like 'post' but catches 'HttpException's to allow pattern matching +postE :: (A.ToJSON a, A.FromJSON b) => + [Text] -- ^ URI path segments + -> Option 'Https -> a -> AccessToken -> Req (Either HttpException b) +postE paths params bdy tok = tryReq (post paths params bdy tok) + -- | @GET https:\/\/graph.microsoft.com\/v1.0\/...@ get :: A.FromJSON a => [Text] -- ^ URI path segments @@ -69,6 +90,12 @@ where opts = auth <> params (url, auth) = msGraphReqConfig tok paths + +-- | Like 'get' but catches 'HttpException's to allow pattern matching +getE :: (A.FromJSON a) => + [Text] -- ^ URI path segments + -> Option 'Https -> AccessToken -> Req (Either HttpException a) +getE paths params tok = tryReq (get paths params tok) -- | @GET https:\/\/graph.microsoft.com\/v1.0\/...@ -- diff --git a/src/Network/OAuth2/Provider/AzureAD.hs b/src/Network/OAuth2/Provider/AzureAD.hs --- a/src/Network/OAuth2/Provider/AzureAD.hs +++ b/src/Network/OAuth2/Provider/AzureAD.hs @@ -34,6 +34,7 @@ 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 @@ -43,7 +44,7 @@ , 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 +-- | NB : 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{ diff --git a/src/Network/OAuth2/Session.hs b/src/Network/OAuth2/Session.hs --- a/src/Network/OAuth2/Session.hs +++ b/src/Network/OAuth2/Session.hs @@ -136,7 +136,7 @@ IdpApplication 'AuthorizationCode AzureAD -> Action m () loginH idpApp = do - setHeader "Location" (mkAuthorizeRequest idpApp) -- $ azureADApp oacfg) + 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 @@ -165,7 +165,7 @@ etoken = ExchangeToken $ TL.toStrict codeP _ <- fetchUpdateToken ts idpApp mgr etoken pure () - Nothing -> throwE OASEExchangeTokenNotFound -- $ T.pack $ unwords ["cannot decode token"] + Nothing -> throwE OASEExchangeTokenNotFound -- @@ -183,7 +183,7 @@ -> IdpApplication 'AuthorizationCode AzureAD -> Manager -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes - -> ExceptT OAuthSessionError m OAuth2Token -- IO (Either T.Text OAuth2Token) + -> ExceptT OAuthSessionError m OAuth2Token fetchUpdateToken ts idpApp mgr etoken = ExceptT $ do tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr etoken -- OAuth2 token case tokenResp of @@ -195,14 +195,15 @@ 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 (OASEJWTException es) -- id token validation failed Left es -> pure $ Left (OASEOAuth2Errors es) +-- | 2) fork a thread and start token refresh loop for user @uid@ refreshLoop :: (MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) => Tokens uid OAuth2Token -> IdpApplication a i -> Manager - -> uid + -> uid -- ^ user ID -> OAuth2Token -> m ThreadId refreshLoop ts idpApp mgr uid oaToken = forkFinally (act oaToken) cleanup