From 9774e2bdcdfa52ee321af820ca79c0b4dbf94b7c Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Fri, 11 Aug 2023 13:54:57 +0200 Subject: [PATCH] adding stuff --- ms-auth/CHANGELOG.md | 11 +- ms-auth/ms-auth.cabal | 3 +- ms-auth/src/MSAuth.hs | 13 +-- .../src/Network/OAuth2/Provider/AzureAD.hs | 73 +++++++------ ms-auth/src/Network/OAuth2/Session.hs | 100 +++++++++--------- ms-azure-api-test/Setup.hs | 2 + ms-azure-api-test/app/Main.hs | 28 +++++ ms-azure-api-test/ms-azure-api-test.cabal | 59 +++++++++++ ms-azure-api-test/src/Lib.hs | 1 + ms-azure-api-test/stack.yaml | 44 ++++++++ ms-azure-api/ms-azure-api.cabal | 1 + ms-azure-api/src/MSAzureAPI.hs | 10 +- ms-azure-api/src/MSAzureAPI/BotService.hs | 83 +++++++++++++-- .../src/MSAzureAPI/Internal/Common.hs | 43 ++++++-- ms-graph-api-test/app/Main.hs | 6 +- ms-graph-api-test/ms-graph-api-test.cabal | 7 +- ms-graph-api-test/stack.yaml | 1 + stack.yaml | 2 + 18 files changed, 369 insertions(+), 118 deletions(-) create mode 100644 ms-azure-api-test/Setup.hs create mode 100644 ms-azure-api-test/app/Main.hs create mode 100644 ms-azure-api-test/ms-azure-api-test.cabal create mode 100644 ms-azure-api-test/src/Lib.hs create mode 100644 ms-azure-api-test/stack.yaml diff --git a/ms-auth/CHANGELOG.md b/ms-auth/CHANGELOG.md index b8791ee..e1e4625 100644 --- a/ms-auth/CHANGELOG.md +++ b/ms-auth/CHANGELOG.md @@ -8,6 +8,16 @@ and this project adheres to the ## Unreleased + +## 0.4.0.0 + +Add Bot Framework support + +Breaking changes: +- MSAuth is the only public interface module +- 'newNoToken' and 'fetchUpdateToken' are not expored anymore from Session and MSAuth, in favor of a single function 'tokenUpdateLoop' which does both the initialization and the refresh loop +- 'applyDotEnv' and the 'DotEnv' module are gone. Please use the equivalent package 'dotenv-micro' + ## 0.3.0.0 defaultAzureCredential - simplified version of the Microsoft Identity SDK @@ -15,7 +25,6 @@ defaultAzureCredential - simplified version of the Microsoft Identity SDK introduced MSAuth module that re-exports internal functions Breaking changes: - - module Network.OAuth2.JWT is not exposed anymore - OAuthCfg does not contain fields for client ID and secret anymore - client ID and client secret can only be loaded from environment variables diff --git a/ms-auth/ms-auth.cabal b/ms-auth/ms-auth.cabal index 413ed74..b118de0 100644 --- a/ms-auth/ms-auth.cabal +++ b/ms-auth/ms-auth.cabal @@ -19,10 +19,9 @@ library default-language: Haskell2010 hs-source-dirs: src exposed-modules: MSAuth - Network.OAuth2.Session Network.OAuth2.Provider.AzureAD other-modules: Network.OAuth2.JWT - DotEnv + Network.OAuth2.Session build-depends: aeson , base >= 4.7 && < 5 , bytestring diff --git a/ms-auth/src/MSAuth.hs b/ms-auth/src/MSAuth.hs index d6cabab..12aea94 100644 --- a/ms-auth/src/MSAuth.hs +++ b/ms-auth/src/MSAuth.hs @@ -1,14 +1,12 @@ -- | Functions for implementing Azure AD-based authentication -- --- Both @Auth Code Grant@ (i.e. with browser client interaction) 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. +-- Both @Auth Code Grant@ (i.e. with a user involved in the autorization loop) and @Client Credentials Grant@ (i.e. app only) 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 MSAuth ( - applyDotEnv - -- * A App-only flow (server-to-server) - , Token - , newNoToken + -- * A Client Credentials flow (server-to-server) + Token + , tokenUpdateLoop , expireToken , readToken - , fetchUpdateToken -- ** Default Azure Credential , defaultAzureCredential -- * B Auth code grant flow (interactive) @@ -27,7 +25,6 @@ module MSAuth ( , withAADUser , Scotty , Action - ) where + ) where import Network.OAuth2.Session -import DotEnv (applyDotEnv) diff --git a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs index f1b5ae7..22f35c9 100644 --- a/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs +++ b/ms-auth/src/Network/OAuth2/Provider/AzureAD.hs @@ -7,9 +7,9 @@ {-# options_ghc -Wno-ambiguous-fields #-} -- | Settings for using Azure Active Directory as OAuth identity provider -- --- Both @Auth Code Grant@ (i.e. with browser client interaction) 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. +-- Both @Auth Code Grant@ (i.e. with browser client interaction) and @Client Credentials Grant@ 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. -- --- Azure Bot Framework is supported since v 0. +-- Azure Bot Framework is supported since v 0.4 module Network.OAuth2.Provider.AzureAD ( AzureAD , AzureBotFramework @@ -17,10 +17,10 @@ module Network.OAuth2.Provider.AzureAD ( , envClientId , envClientSecret , envTenantId - -- * App flow + -- * Client Credentials auth flow , azureADApp - , azureBotFrameworkOAuthADApp - -- * Delegated permissions OAuth2 flow + , azureBotFrameworkADApp + -- * Auth Code Grant auth flow , OAuthCfg(..) , AzureADUser , azureOAuthADApp @@ -79,9 +79,9 @@ instance Show AzureADException where show = \case AADNoEnvVar e -> unwords ["Env var", e, "not found"] --- * App-only flow +-- * Client Credentials Grant flow --- | Azure OAuth application (i.e. with user consent screen) +-- | Azure OAuth application -- -- NB : scope @offline_access@ is ALWAYS requested -- @@ -117,8 +117,42 @@ defaultAzureADApp = , idp = defaultAzureADIdp } +-- | Initialize an Client Credentials token exchange application for the Bot Framework +-- +-- +-- Throws 'AzureADException' if @AZURE_CLIENT_ID@ and/or @AZURE_CLIENT_SECRET@ credentials are not found in the environment +azureBotFrameworkADApp :: MonadIO m => + TL.Text -- ^ app name + -> m (IdpApplication 'ClientCredentials AzureBotFramework) +azureBotFrameworkADApp appname = do + clid <- envClientId + sec <- envClientSecret + pure $ ClientCredentialsIDPAppConfig {idpAppClientId = clid, + idpAppClientSecret = sec, + idpAppName = appname, + idpAppScope = Set.fromList ["https://api.botframework.com/.default"], + idpAppTokenRequestExtraParams = mempty, + idp = defaultAzureBotFrameworkIdp + } + + +data AzureBotFramework = AzureBotFramework deriving (Eq, Show) + +defaultAzureBotFrameworkIdp :: Idp AzureBotFramework +defaultAzureBotFrameworkIdp = Idp { + idpFetchUserInfo = authGetJSON @(IdpUserInfo AzureBotFramework) + , idpTokenEndpoint = [uri|https://login.microsoftonline.com/botframework.com/oauth2/v2.0/token|] + , idpUserInfoEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth user info endpoint is not defined"] + , idpAuthorizeEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth authorize endpoint is not defined"] + } + + --- * Delegated permissions flow + + + + +-- * Authorization Code Grant flow type instance IdpUserInfo AzureAD = AzureADUser @@ -182,31 +216,8 @@ defaultAzureADIdp = , idpTokenEndpoint = [uri|https://login.microsoftonline.com/common/oauth2/v2.0/token|] } --- | -azureBotFrameworkOAuthADApp :: ClientId - -> ClientSecret - -> TL.Text -- ^ app name - -> IdpApplication 'ClientCredentials AzureBotFramework -azureBotFrameworkOAuthADApp clid sec appname = ClientCredentialsIDPAppConfig { - idpAppClientId = clid, - idpAppClientSecret = sec, - idpAppName = appname, - idpAppScope = Set.fromList ["https://api.botframework.com/.default"], - idpAppTokenRequestExtraParams = mempty, - idp = defaultAzureBotFrameworkIdp - } -data AzureBotFramework = AzureBotFramework - -defaultAzureBotFrameworkIdp :: Idp AzureBotFramework -defaultAzureBotFrameworkIdp = Idp { - idpFetchUserInfo = authGetJSON @(IdpUserInfo AzureBotFramework) - , idpTokenEndpoint = [uri|https://login.microsoftonline.com/botframework.com/oauth2/v2.0/token|] - , idpUserInfoEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth user info endpoint is not defined"] - , idpAuthorizeEndpoint = error $ unwords ["Azure Bot Framework Idp:", "OAuth authorize endpoint is not defined"] - } - -- | https://learn.microsoft.com/en-us/azure/active-directory/develop/userinfo data AzureADUser = AzureADUser { sub :: T.Text diff --git a/ms-auth/src/Network/OAuth2/Session.hs b/ms-auth/src/Network/OAuth2/Session.hs index 1e896b1..43893d8 100644 --- a/ms-auth/src/Network/OAuth2/Session.hs +++ b/ms-auth/src/Network/OAuth2/Session.hs @@ -7,21 +7,22 @@ -- -- The library supports the following authentication scenarios : -- --- * [Client Credentials](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow) (server/server or automation accounts) +-- * [Client Credentials](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow) (server/server or automation accounts), see also https://oauth.net/2/grant-types/client-credentials/ -- --- * [Authorization Code](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-auth-code-flow) (with human users being prompted to delegate some access rights to the app) +-- * [Authorization Code](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-auth-code-flow) (with human users being prompted to delegate some access rights to the app), see also https://oauth.net/2/grant-types/authorization-code/ -- -- and provides functions to keep tokens up to date in the background. module Network.OAuth2.Session ( - -- * A App-only flow (server-to-server) + -- * A Client Credentials Grant (i.e. server-to-server) Token - , newNoToken + -- , newNoToken + , tokenUpdateLoop , expireToken , readToken - , fetchUpdateToken + -- , fetchUpdateToken -- ** Default Azure Credential , defaultAzureCredential - -- * B Auth code grant flow (interactive) + -- * B Auth Code Grant (i.e. with user auth in the loop) -- ** OAuth endpoints , loginEndpoint , replyEndpoint @@ -145,7 +146,7 @@ withAADUser ts loginURI act = aadHeaderIdToken $ \usub -> do --- * App-only authorization scenarios (i.e via automation accounts. Human users not involved) +-- * App-only authorization scenarios, called "CLient credentials grant" https://oauth.net/2/grant-types/client-credentials/ (i.e via automation accounts. Human users not involved) @@ -162,6 +163,26 @@ expireToken ts = atomically $ modifyTVar ts (const Nothing) readToken :: MonadIO m => Token t -> m (Maybe t) readToken ts = atomically $ readTVar ts +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 + +-- | Forks a thread and keeps the OAuth token up to date inside a TVar +tokenUpdateLoop :: MonadIO m => + IdpApplication 'ClientCredentials AzureAD -- ^ client credentials grant only + -> Manager + -> m (Token OAuth2Token) +tokenUpdateLoop idp mgr = do + t <- newNoToken + fetchUpdateToken idp t mgr + pure t + + fetchUpdateTokenWith :: MonadIO m => (t1 -> t2 -> ExceptT [String] IO OAuth2Token) -> t1 -> Token OAuth2Token -> t2 -> m () @@ -207,15 +228,17 @@ tokenRequestNoExchange :: (MonadIO m) => -> ExceptT [String] m OAuth2Token tokenRequestNoExchange ip mgr = withExceptT (pure . show) (conduitTokenRequest ip mgr) --- | Fetch an OAuth token and keep it updated. Should be called as a first thing in the app +-- | Token refresh loop for Client Credentials Grant scenarios (Bot Framework auth etc) +-- +-- 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 -- ^ token TVar - -> Manager + -> Token OAuth2Token -- ^ the app manages a single token at a time + -> Manager -- ^ HTTP connection manager -> m () fetchUpdateToken idpApp ts mgr = liftIO $ void $ forkFinally loop cleanup where @@ -233,14 +256,7 @@ fetchUpdateToken idpApp ts mgr = liftIO $ void $ forkFinally loop cleanup 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 + @@ -350,14 +366,16 @@ replyH idpApp ts mgr = do -- bslToText = T.pack . BSL.unpack --- | 1) the ExchangeToken arrives with the redirect once the user has approved the scopes in the browser +-- | Token refresh loop for Auth Code Grant scenarios +-- +-- 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 fetchUpdateTokenACG :: MonadIO m => - Tokens UserSub OAuth2Token - -> IdpApplication 'AuthorizationCode AzureAD - -> Manager - -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes - -> ExceptT OAuthSessionError m OAuth2Token + Tokens UserSub OAuth2Token -- ^ the app manages one token per user + -> IdpApplication 'AuthorizationCode AzureAD + -> Manager -- ^ HTTP connection manager + -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes + -> ExceptT OAuthSessionError m OAuth2Token fetchUpdateTokenACG ts idpApp mgr etoken = ExceptT $ do tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr etoken -- OAuth2 token case tokenResp of @@ -373,34 +391,16 @@ fetchUpdateTokenACG ts idpApp mgr etoken = ExceptT $ do Left es -> pure $ Left (OASEOAuth2Errors es) --- -- -- for Bot Framework auth etc --- fetchUpdateToken' :: MonadIO m => --- Tokens UserSub OAuth2Token --- -> IdpApplication 'ClientCredentials i --- -> Manager --- -> ExceptT OAuthSessionError m OAuth2Token --- fetchUpdateToken' ts idpApp mgr = ExceptT $ do --- tokenResp <- runExceptT $ conduitTokenRequest idpApp mgr -- 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 --- _ <- refreshLoopACG ts idpApp mgr uid oat -- fork a thread and start refresh loop for this user --- pure $ Right oat - - - -- | 2) fork a thread and start token refresh loop for user @uid@ +-- +-- ACG stands for "authorization code grant" flow, i.e. the user consent is in the auth loop. refreshLoopACG :: (MonadIO m, Ord uid, HasRefreshTokenRequest a) => - Tokens uid OAuth2Token - -> IdpApplication a i - -> Manager - -> uid -- ^ user ID - -> OAuth2Token - -> m ThreadId + Tokens uid OAuth2Token + -> IdpApplication a i + -> Manager + -> uid -- ^ user ID + -> OAuth2Token + -> m ThreadId refreshLoopACG ts idpApp mgr uid oaToken = liftIO $ forkFinally (act oaToken) cleanup where cleanup = \case diff --git a/ms-azure-api-test/Setup.hs b/ms-azure-api-test/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/ms-azure-api-test/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ms-azure-api-test/app/Main.hs b/ms-azure-api-test/app/Main.hs new file mode 100644 index 0000000..17930d7 --- /dev/null +++ b/ms-azure-api-test/app/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# language OverloadedStrings #-} +{-# language QuasiQuotes #-} +module Main (main) where + +import Control.Monad.IO.Class (MonadIO(..)) +-- hoauth2 +import Network.OAuth.OAuth2 (OAuth2Token(..)) +import Network.OAuth2.Experiment (IdpApplication, GrantTypeFlow(..)) +-- unliftio +import UnliftIO (MonadUnliftIO(..)) +import UnliftIO.Exception (throwIO) +import UnliftIO.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar) +-- uri-bytestring +import URI.ByteString.QQ (uri) + +import Network.OAuth2.Provider.AzureAD (azureBotFrameworkADApp, AzureBotFramework) +import MSAuth (Token, tokenUpdateLoop, readToken, UserSub, Scotty, Action) +import MSAzureAPI (tryReq) + +main :: IO () +main = pure () + + +-- also double check https://stackoverflow.com/a/63929994/2890063 in the AAD app manifest +idpApp :: MonadIO m => m (IdpApplication 'ClientCredentials AzureBotFramework) +idpApp = azureBotFrameworkADApp "ms-azure-bot-framework-api-test" + diff --git a/ms-azure-api-test/ms-azure-api-test.cabal b/ms-azure-api-test/ms-azure-api-test.cabal new file mode 100644 index 0000000..82fbdda --- /dev/null +++ b/ms-azure-api-test/ms-azure-api-test.cabal @@ -0,0 +1,59 @@ +name: ms-azure-api-test +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/unfoldml/ms-graph-api +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2023 Author name here +category: Acme +build-type: Simple +extra-source-files: README.md + CHANGELOG.md +cabal-version: >=1.10 +tested-with: GHC == 7.10.2 + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Lib + build-depends: base >= 4.7 && < 5 + ghc-options: -Wall + -Wcompat + +executable ms-azure-api-test + default-language: Haskell2010 + hs-source-dirs: app + main-is: Main.hs + build-depends: aeson + , aeson-pretty + , base + , bytestring + , directory >= 1.3.6.2 + , dotenv-micro == 0.1.0.1 + , hoauth2 == 2.6.0 + , http-client + , http-client-tls >= 0.3 + , ms-azure-api-test + , ms-auth + , ms-azure-api + , req + , scotty + , text >= 1.2.5.0 + , transformers >= 0.5.6.2 + , unliftio + , uri-bytestring + , wai-extra >= 3.1.13.0 + ghc-options: -Wall + -Wcompat + -threaded + -rtsopts + -with-rtsopts=-N + + + +source-repository head + type: git + location: https://github.com/unfoldml/ms-azure-api diff --git a/ms-azure-api-test/src/Lib.hs b/ms-azure-api-test/src/Lib.hs new file mode 100644 index 0000000..6d85a26 --- /dev/null +++ b/ms-azure-api-test/src/Lib.hs @@ -0,0 +1 @@ +module Lib where diff --git a/ms-azure-api-test/stack.yaml b/ms-azure-api-test/stack.yaml new file mode 100644 index 0000000..482c651 --- /dev/null +++ b/ms-azure-api-test/stack.yaml @@ -0,0 +1,44 @@ +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/25.yaml + +packages: + - . + - ../ms-auth + - ../ms-azure-api + +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: + - validation-micro-1.0.0.0 + - dotenv-micro-0.1.0.1 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of Stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.9" +# +# Override the architecture used by Stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by Stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/ms-azure-api/ms-azure-api.cabal b/ms-azure-api/ms-azure-api.cabal index f6cf371..90ae571 100644 --- a/ms-azure-api/ms-azure-api.cabal +++ b/ms-azure-api/ms-azure-api.cabal @@ -54,6 +54,7 @@ library DeriveGeneric DeriveFunctor DerivingStrategies + GeneralizedNewtypeDeriving LambdaCase DataKinds diff --git a/ms-azure-api/src/MSAzureAPI.hs b/ms-azure-api/src/MSAzureAPI.hs index b2db1bf..d9aae7f 100644 --- a/ms-azure-api/src/MSAzureAPI.hs +++ b/ms-azure-api/src/MSAzureAPI.hs @@ -1,13 +1,15 @@ module MSAzureAPI ( - -- ** HTTP request helpers + -- * HTTP request helpers tryReq - -- ** Common types + -- * Common types + -- ** Collection , Collection , collectionValue , collectionNextLink - -- *** Location + -- ** Location , Location(..) , showLocation - ) where + , locationDisplayName + ) where import MSAzureAPI.Internal.Common diff --git a/ms-azure-api/src/MSAzureAPI/BotService.hs b/ms-azure-api/src/MSAzureAPI/BotService.hs index 6fde4ef..2e2850d 100644 --- a/ms-azure-api/src/MSAzureAPI/BotService.hs +++ b/ms-azure-api/src/MSAzureAPI/BotService.hs @@ -1,9 +1,28 @@ -module MSAzureAPI.BotService where +-- | Azure Bot Framework +-- +-- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-quickstart?view=azure-bot-service-4.0 +module MSAzureAPI.BotService ( + sendMessage + , sendReply + -- * Types + , Activity(..) + , Attachment(..) + -- ** Adaptive Card + , AdaptiveCard(..) + , ACElement(..) + -- *** adaptive card elements + , Image(..) + , TextBlock(..) + , ColumnSet(..) + , Column(..) + ) where +import Data.Char (toLower) +import GHC.Exts (IsString(..)) import GHC.Generics (Generic(..)) -- aeson -import qualified Data.Aeson as A (ToJSON(..), genericToJSON, object, (.=), ToJSONKey(..), FromJSON(..), genericParseJSON, withObject, withText) +import qualified Data.Aeson as A (ToJSON(..), genericToJSON, object, (.=), encode, ToJSONKey(..), FromJSON(..), genericParseJSON, withObject, withText, Value(..)) -- hoauth2 import Network.OAuth.OAuth2.Internal (AccessToken(..)) @@ -12,19 +31,62 @@ import Network.HTTP.Req (HttpException, runReq, HttpConfig, defaultHttpConfig, R -- text import Data.Text (Text, pack, unpack) -import MSAzureAPI.Internal.Common (run, APIPlane(..), Location(..), locationDisplayName, (==:), get, getBs, post, postSBMessage, getLbs, put, tryReq, aesonOptions) +import MSAzureAPI.Internal.Common (run, APIPlane(..), Location(..), locationDisplayName, (==:), get, getBs, post, postRaw, getLbs, put, tryReq, aesonOptions) + + +-- * Send and receive messages with the Bot Framework : https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-send-and-receive-messages?view=azure-bot-service-4.0 + +-- | Send a reply to a user message +-- +-- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-send-and-receive-messages?view=azure-bot-service-4.0#create-a-reply +sendReply :: Activity -- ^ data from the user + -> Text -- ^ reply text + -> [Attachment] -- ^ reply attachments + -> AccessToken -> Req () +sendReply acti txt atts atok = + case aReplyToId acti of + Nothing -> pure () + Just aid -> postRaw urib ["v3", "conversations", cid, "activities", aid] mempty actO atok + where + urib = aServiceUrl acti + cid = coaId $ aConversation acti + actO = mkReplyActivity acti txt atts + +mkReplyActivity :: Activity -- ^ coming from the user + -> Text -- ^ reply text + -> [Attachment] -- ^ reply attachments + -> Activity +mkReplyActivity actI = Activity ATMessage Nothing Nothing conO froO recO surl replid + where + conO = aConversation actI + froO = aRecipient actI + recO = aFrom actI + surl = aServiceUrl actI + replid = aReplyToId actI + +-- | Send a standalone message +-- +-- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-send-and-receive-messages?view=azure-bot-service-4.0#send-a-non-reply-message +sendMessage :: (A.FromJSON b) => + Text + -> Text + -> Activity + -> AccessToken -> Req b +sendMessage urib cid = + postRaw urib ["v3", "conversations", cid, "activities"] mempty -- | Activity object. Defines a message that is exchanged between bot and user. -- -- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#activity-object data Activity = Activity { aType :: ActivityType - , aId :: Text - , aChannelId :: Text + , aId :: Maybe Text + , aChannelId :: Maybe Text , aConversation :: ConversationAccount , aFrom :: ChannelAccount , aRecipient :: ChannelAccount , aServiceUrl :: Text -- ^ URL that specifies the channel's service endpoint. Set by the channel. + , aReplyToId :: Maybe Text , aText :: Text , aAttachments :: [Attachment] } deriving (Show, Generic) @@ -77,8 +139,8 @@ data Image = Image { imgUrl :: Text } deriving (Show, Generic) instance A.ToJSON Image where toJSON = A.genericToJSON (aesonOptions "img") -data TextBlock = TextBlock { - tbText :: Text } deriving (Show, Generic) +newtype TextBlock = TextBlock { + tbText :: Text } deriving (Show, Generic) deriving newtype (IsString) instance A.ToJSON TextBlock where toJSON = A.genericToJSON (aesonOptions "tb") data ColumnSet = ColumnSet { @@ -152,6 +214,7 @@ instance A.FromJSON ActivityType where "handoff" -> pure ATHandoff errstr -> fail $ unwords [unpack errstr, "not a valid ActivityType"] instance A.ToJSON ActivityType where - toJSON = \case - ATMessage -> "message" - -- _ -> fail "unimplemented" + toJSON v = A.String $ (pack . headLower . drop 2 . show) v + where + headLower (x:xs) = toLower x : xs + headLower [] = [] diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs index f6758e5..0482330 100644 --- a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs +++ b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# language QuasiQuotes #-} {-# options_ghc -Wno-unused-imports #-} -- | Common functions for the MS Azure API -- @@ -12,6 +13,7 @@ module MSAzureAPI.Internal.Common ( , getLbs -- ** POST , post + , postRaw , postSBMessage -- ** DELETE , delete @@ -39,7 +41,7 @@ import Data.Proxy (Proxy) import GHC.Generics (Generic(..)) import Data.List (sort, sortBy, stripPrefix, uncons) -import Data.Maybe (listToMaybe, fromMaybe) +import Data.Maybe (listToMaybe, fromJust, fromMaybe) -- import Data.Ord (comparing) import Data.Char (toLower) @@ -58,9 +60,9 @@ import Network.HTTP.Client.TLS (newTlsManager) import Network.OAuth.OAuth2 (OAuth2Token(..)) import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..)) -- modern-uri --- import Text.URI (URI, mkURI) +import Text.URI (URI, mkURI) -- req -import Network.HTTP.Req (Req, runReq, HttpBody(..), HttpConfig(..), HttpException(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), PUT(..), DELETE(..), Url, Scheme(..), useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody) +import Network.HTTP.Req (Req, runReq, HttpBody(..), HttpConfig(..), HttpException(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), PUT(..), DELETE(..), Url, Scheme(..), urlQ, useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody) -- text import Data.Text (Text, pack, unpack) -- unliftio @@ -120,7 +122,6 @@ data APIPlane = APManagement -- ^ Management plane (@management.azure.com@ endpo | APData Text -- ^ Data plane e.g. FileREST API | APServiceBus Text -- ^ Data plane for Service Bus. The parameter is the service name - -- | @PUT@ put :: (A.FromJSON b, A.ToJSON a) => APIPlane @@ -152,6 +153,26 @@ post apiplane paths params bdy tok = responseBody <$> req POST url (ReqBodyJson opts = auth <> params (url, auth) = msAzureReqConfig apiplane paths tok +-- | @POST@ to a URL +-- +-- useful when the base URL is dynamic e.g. comes from an external service +postRaw :: (A.FromJSON b, A.ToJSON a) => + Text -- ^ base URL (can contain path and parameters too) + -> [Text] -- ^ additional URI path segments + -> Option 'Https + -> a -> AccessToken -> Req b +postRaw uraw paths params bdy atok = do + uriBase <- mkURI uraw + let + auth = bearerAuth atok + (u, uparams) = fromJust (useHttpsURI uriBase) + url = u //: paths + opts = auth <> params <> uparams -- NB identical keys are not overwritten + responseBody <$> req POST url (ReqBodyJson bdy) jsonResponse opts + + + + -- | Post a message or batch thereof to the Service Bus -- -- see example : https://learn.microsoft.com/en-us/rest/api/servicebus/send-message-batch#example @@ -183,15 +204,23 @@ msAzureReqConfig :: APIPlane -> [Text] -- ^ URI path segments -> AccessToken -> (Url 'Https, Option 'Https) -msAzureReqConfig apiplane uriRest (AccessToken ttok) = (url, os) +msAzureReqConfig apiplane uriRest atok = (url, os) + where + url = apiPlaneBaseURL apiplane uriRest + os = bearerAuth atok + +apiPlaneBaseURL :: APIPlane + -> [Text] -- ^ URI path segments + -> Url 'Https +apiPlaneBaseURL apiplane uriRest = (https urlBase) //: uriRest where urlBase = case apiplane of APManagement -> "management.azure.com" APData ub -> ub APServiceBus sn -> sn <> ".servicebus.windows.net" - url = (https urlBase) //: uriRest - os = oAuth2Bearer $ BS8.pack (unpack ttok) +bearerAuth :: AccessToken -> Option 'Https +bearerAuth (AccessToken ttok) = oAuth2Bearer $ BS8.pack (unpack ttok) (//:) :: Url scheme -> [Text] -> Url scheme diff --git a/ms-graph-api-test/app/Main.hs b/ms-graph-api-test/app/Main.hs index 203681a..603492e 100644 --- a/ms-graph-api-test/app/Main.hs +++ b/ms-graph-api-test/app/Main.hs @@ -11,6 +11,8 @@ import Data.Maybe (fromMaybe) import qualified Data.Aeson.Encode.Pretty as A (encodePretty) -- bytestring import qualified Data.ByteString.Lazy.Char8 as LBS (putStrLn, pack) +-- dotenv-micro +import DotEnv.Micro (loadDotEnv) -- hoauth2 import Network.OAuth.OAuth2 (OAuth2Token(..)) import Network.OAuth2.Experiment (IdpApplication, GrantTypeFlow(..)) @@ -41,7 +43,7 @@ import qualified MSGraphAPI.Files.DriveItem as MSDI (listRootChildrenMe) import qualified MSGraphAPI.Users.Group as MSGU (Group(..), listMeJoinedTeams, listGroupsDriveItems) import qualified MSGraphAPI.Users.User as MSG (getMe, User(..)) import Network.OAuth2.Provider.AzureAD (OAuthCfg(..), azureOAuthADApp, AzureAD) -import MSAuth (applyDotEnv, Tokens, newTokens, tokensToList, withAADUser, loginEndpoint, replyEndpoint, UserSub, Scotty, Action) +import MSAuth (Tokens, newTokens, tokensToList, withAADUser, loginEndpoint, replyEndpoint, UserSub, Scotty, Action) main :: IO () @@ -50,7 +52,7 @@ main = server server :: MonadIO m => m () server = do ts <- newTokens - applyDotEnv (Just ".env") + loadDotEnv Nothing ip <- idpApp MSG.withTLS $ \hc mgr -> do let diff --git a/ms-graph-api-test/ms-graph-api-test.cabal b/ms-graph-api-test/ms-graph-api-test.cabal index 46baf06..e5926a1 100644 --- a/ms-graph-api-test/ms-graph-api-test.cabal +++ b/ms-graph-api-test/ms-graph-api-test.cabal @@ -2,7 +2,7 @@ name: ms-graph-api-test version: 0.1.0.0 -- synopsis: -- description: -homepage: https://github.com/unfoldml/ms-api +homepage: https://github.com/unfoldml/ms-graph-api license: BSD3 license-file: LICENSE author: Marco Zocca @@ -32,10 +32,11 @@ executable ms-graph-api-test , base , bytestring , directory >= 1.3.6.2 + , dotenv-micro == 0.1.0.1 , hoauth2 == 2.6.0 , http-client , http-client-tls >= 0.3 - , ms-auth >= 0.2 + , ms-auth >= 0.4 , ms-graph-api , ms-graph-api-test , req @@ -54,4 +55,4 @@ executable ms-graph-api-test source-repository head type: git - location: https://github.com/githubuser/ms-graph-api-test + location: https://github.com/unfoldml/ms-graph-api diff --git a/ms-graph-api-test/stack.yaml b/ms-graph-api-test/stack.yaml index ccd6710..d890bf1 100644 --- a/ms-graph-api-test/stack.yaml +++ b/ms-graph-api-test/stack.yaml @@ -12,6 +12,7 @@ packages: extra-deps: - validation-micro-1.0.0.0 +- dotenv-micro-0.1.0.1 # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git diff --git a/stack.yaml b/stack.yaml index aa5847d..91e80d6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: - ms-graph-api - ms-graph-api-test - ms-azure-api +- ms-azure-api-test - ms-auth # Dependency packages to be pulled from upstream that are not in the resolver. @@ -13,6 +14,7 @@ packages: # extra-deps: - validation-micro-1.0.0.0 +- dotenv-micro-0.1.0.1 # extra-deps: # - acme-missiles-0.3