ms-azure-api 0.5.0.0 → 0.6.0.0

raw patch · 5 files changed

+282/−15 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−1
• ms-azure-api.cabal +3/−1
• src/MSAzureAPI.hs +8/−4
• src/MSAzureAPI/BotService.hs +228/−0
• src/MSAzureAPI/Internal/Common.hs +39/−9

@@ -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 

@@ -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 

@@ -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

@@ -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 [] = []

@@ -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