diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ ## Unreleased +## 0.6.0.0 + +MSAzureAPI.BotService + ## 0.5.0.0 ToJSON instance of Location renders the full name e.g. "West Europe" @@ -17,7 +21,6 @@ add 'http-client' as an explicit dependency * breaking changes - Fixed definition of 'put' to use the correct HTTP verb Add constructor to 'APIPlane' to reflect service bus usage diff --git a/ms-azure-api.cabal b/ms-azure-api.cabal --- a/ms-azure-api.cabal +++ b/ms-azure-api.cabal @@ -1,5 +1,5 @@ name: ms-azure-api -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Microsoft Azure API description: Bindings to the Microsoft Azure API homepage: https://github.com/unfoldml/ms-graph-api @@ -19,6 +19,7 @@ default-language: Haskell2010 hs-source-dirs: src exposed-modules: MSAzureAPI + MSAzureAPI.BotService MSAzureAPI.MachineLearning.Compute MSAzureAPI.MachineLearning.Jobs MSAzureAPI.MachineLearning.Usages @@ -53,6 +54,7 @@ DeriveGeneric DeriveFunctor DerivingStrategies + GeneralizedNewtypeDeriving LambdaCase DataKinds diff --git a/src/MSAzureAPI.hs b/src/MSAzureAPI.hs --- a/src/MSAzureAPI.hs +++ b/src/MSAzureAPI.hs @@ -1,13 +1,17 @@ module MSAzureAPI ( - -- ** HTTP request helpers + -- * HTTP request helpers tryReq - -- ** Common types + , run + , withTLS + -- * Common types + -- ** Collection , Collection , collectionValue , collectionNextLink - -- *** Location + -- ** Location , Location(..) , showLocation - ) where + , locationDisplayName + ) where import MSAzureAPI.Internal.Common diff --git a/src/MSAzureAPI/BotService.hs b/src/MSAzureAPI/BotService.hs new file mode 100644 --- /dev/null +++ b/src/MSAzureAPI/BotService.hs @@ -0,0 +1,228 @@ +-- | 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, (.=), encode, ToJSONKey(..), FromJSON(..), genericParseJSON, withObject, withText, Value(..)) +-- hoauth2 +import Network.OAuth.OAuth2.Internal (AccessToken(..)) + +-- req +import Network.HTTP.Req (HttpException, runReq, HttpConfig, defaultHttpConfig, Req, Url, Option, Scheme(..), header, (=:)) +-- text +import Data.Text (Text, pack, unpack) + +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 :: 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) +instance A.FromJSON Activity where + parseJSON = A.genericParseJSON (aesonOptions "a") +instance A.ToJSON Activity where + toJSON = A.genericToJSON (aesonOptions "a") + +-- | Message attachments +-- +-- https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#attachment-object +-- +-- Attachments can be of many types but we currently only support adaptive cards +data Attachment = Attachment { + attContent :: AdaptiveCard + } deriving (Show, Generic) +instance A.FromJSON Attachment where + parseJSON = A.genericParseJSON (aesonOptions "att") +instance A.ToJSON Attachment where + toJSON (Attachment ac) = A.object [ + "contentType" A..= ("application/vnd.microsoft.card.adaptive" :: String) + , "content" A..= ac + ] +-- | Adaptive Card API +-- +-- https://adaptivecards.io/explorer/AdaptiveCard.html +data AdaptiveCard = AdaptiveCard { + acBody :: [ACElement] } deriving (Show, Generic) +instance A.FromJSON AdaptiveCard where + parseJSON = A.genericParseJSON (aesonOptions "ac") +instance A.ToJSON AdaptiveCard where + toJSON = A.genericToJSON (aesonOptions "ac") + +data ACElement = ACEColumnSet ColumnSet + | ACEColumn Column + | ACETextBlock TextBlock + | ACEImage Image + deriving (Show) +instance A.FromJSON ACElement where + parseJSON j = + (ACEColumnSet <$> A.parseJSON j) -- <|> .. +instance A.ToJSON ACElement where + toJSON = \case + ACEColumnSet cs -> A.object [ + "type" A..= ("ColumnSet" :: String) + , "columns" A..= cs ] + ACEColumn c -> A.object [ + "type" A..= ("Column" :: String) + , "items" A..= c ] + ACETextBlock tb -> A.object [ + "type" A..= ("TextBlock" :: String) + , "text" A..= tb ] + ACEImage imu -> A.object [ + "type" A..= ("Image" :: String) + , "url" A..= imu ] + +data Image = Image { + imgUrl :: Text } deriving (Show, Generic) +instance A.ToJSON Image where + toJSON = A.genericToJSON (aesonOptions "img") +newtype TextBlock = TextBlock { + tbText :: Text } deriving (Show, Generic) deriving newtype (IsString) +instance A.ToJSON TextBlock where + toJSON = A.genericToJSON (aesonOptions "tb") +data ColumnSet = ColumnSet { + colsColumns :: [Column] } deriving (Show, Generic) +instance A.FromJSON ColumnSet where + parseJSON = A.genericParseJSON (aesonOptions "cols") +instance A.ToJSON ColumnSet where + toJSON = A.genericToJSON (aesonOptions "cols") +data Column = Column { + colItems :: [ACElement] } deriving (Show, Generic) +instance A.FromJSON Column where + parseJSON = A.genericParseJSON (aesonOptions "col") +instance A.ToJSON Column where + toJSON = A.genericToJSON (aesonOptions "col") + + +-- | https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#conversationaccount-object +data ConversationAccount = ConversationAccount { + coaAadObjectId :: Text + , coaId :: Text + , coaName :: Text + , coaIsGroup :: Bool + } deriving (Show, Generic) +instance A.FromJSON ConversationAccount where + parseJSON = A.genericParseJSON (aesonOptions "coa") +instance A.ToJSON ConversationAccount where + toJSON = A.genericToJSON (aesonOptions "coa") + +-- | https://learn.microsoft.com/en-us/azure/bot-service/rest-api/bot-framework-rest-connector-api-reference?view=azure-bot-service-4.0#channelaccount-object +data ChannelAccount = ChannelAccount { + caAadObjectId :: Text + , caId :: Text + , caName :: Text + } deriving (Show, Generic) +instance A.FromJSON ChannelAccount where + parseJSON = A.genericParseJSON (aesonOptions "ca") +instance A.ToJSON ChannelAccount where + toJSON = A.genericToJSON (aesonOptions "ca") + +data ActivityType = ATMessage + | ATContactRelationUpdate + | ATConversationUpdate + | ATTyping + | ATEndOfConversation + | ATEvent + | ATInvoke + | ATDeleteUserData + | ATMessageUpdate + | ATMessageDelete + | ATInstallationUpdate + | ATMessageReaction + | ATSuggestion + | ATTrace + | ATHandoff deriving (Eq, Show) +instance A.FromJSON ActivityType where + parseJSON = A.withText "ActivityType" $ \t -> case t of + "message" -> pure ATMessage + "contactRelationUpdate" -> pure ATContactRelationUpdate + "conversationUpdate" -> pure ATConversationUpdate + "typing" -> pure ATTyping + "endOfConversation" -> pure ATEndOfConversation + "event" -> pure ATEvent + "invoke" -> pure ATInvoke + "deleteUserData" -> pure ATDeleteUserData + "messageUpdate" -> pure ATMessageUpdate + "messageDelete" -> pure ATMessageDelete + "installationUpdate" -> pure ATInstallationUpdate + "messageReaction" -> pure ATMessageReaction + "suggestion" -> pure ATSuggestion + "trace" -> pure ATTrace + "handoff" -> pure ATHandoff + errstr -> fail $ unwords [unpack errstr, "not a valid ActivityType"] +instance A.ToJSON ActivityType where + toJSON v = A.String $ (pack . headLower . drop 2 . show) v + where + headLower (x:xs) = toLower x : xs + headLower [] = [] diff --git a/src/MSAzureAPI/Internal/Common.hs b/src/MSAzureAPI/Internal/Common.hs --- a/src/MSAzureAPI/Internal/Common.hs +++ b/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 @@ , getLbs -- ** POST , post + , postRaw , postSBMessage -- ** DELETE , delete @@ -39,7 +41,7 @@ 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) @@ -51,6 +53,7 @@ import qualified Data.ByteString.Lazy as LBS (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn) -- http-client +import Network.HTTP.Client (Manager) import qualified Network.HTTP.Client as L (RequestBody(..)) -- http-client-tls import Network.HTTP.Client.TLS (newTlsManager) @@ -58,9 +61,9 @@ 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 @@ -93,13 +96,13 @@ -- | Create a new TLS manager, which should be reused throughout the program withTLS :: MonadIO m => - (HttpConfig -> m b) -- ^ user program + (HttpConfig -> Manager -> m b) -- ^ user program -> m b withTLS act = do mgr <- newTlsManager let hc = defaultHttpConfig { httpConfigAltManager = Just mgr } - act hc + act hc mgr -- | Run a 'Req' computation run :: MonadIO m => @@ -120,7 +123,6 @@ | 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 +154,26 @@ 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 +205,23 @@ -> [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