add ServiceBus, v0.5

unfoldml · Aug 6, 2023 · 40d0bed · 40d0bed
1 parent caced60
commit 40d0bed
Show file tree

Hide file tree

Showing 3 changed files with 59 additions and 5 deletions.
diff --git a/ms-azure-api/ms-azure-api.cabal b/ms-azure-api/ms-azure-api.cabal
@@ -33,6 +33,7 @@ library
                      , containers
                      , exceptions >= 0.10.4
                      , hoauth2 == 2.6.0
+                     , http-client
                      , http-client-tls >= 0.3.6.1
                      , http-types
                      , modern-uri

diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
@@ -4,11 +4,17 @@
 --
 module MSAzureAPI.Internal.Common (
   APIPlane(..)
+  -- ** PUT
   , put
+  -- ** GET
   , get
   , getBs
   , getLbs
+  -- ** POST
   , post
+  , postSBMessage
+  -- ** DELETE
+  , delete
   -- * HTTP(S) connections
   , run
   , withTLS
@@ -38,12 +44,14 @@ import Data.Maybe (listToMaybe, fromMaybe)
 import Data.Char (toLower)
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=), Key, Value(..), camelTo2)
+import qualified Data.Aeson as A (ToJSON(..), encode, 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)
+-- http-client
+import qualified Network.HTTP.Client as L (RequestBody(..))
 -- http-client-tls
 import Network.HTTP.Client.TLS (newTlsManager)
 -- hoauth2
@@ -52,7 +60,7 @@ import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), Refres
 -- modern-uri
 -- import Text.URI (URI, mkURI)
 -- req
-import Network.HTTP.Req (Req, runReq, HttpConfig(..), HttpException(..), 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, 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)
 -- text
 import Data.Text (Text, pack, unpack)
 -- unliftio
@@ -110,6 +118,7 @@ tryReq = try
 -- https://learn.microsoft.com/en-us/azure/azure-resource-manager/management/control-plane-and-data-plane
 data APIPlane = APManagement -- ^ Management plane (@management.azure.com@ endpoints)
               | APData Text -- ^ Data plane e.g. FileREST API
+              | APServiceBus Text -- ^ Data plane for Service Bus. The parameter is the service name
 
 
 -- | @PUT@
@@ -118,7 +127,15 @@ put :: (A.FromJSON b, A.ToJSON a) =>
     -> [Text] -- ^ URI path segments
     -> Option 'Https -- ^ request parameters etc.
     -> a -> AccessToken -> Req b
-put apiplane paths params bdy tok = responseBody <$> req POST url (ReqBodyJson bdy) jsonResponse opts
+put apiplane paths params bdy tok = responseBody <$> req PUT url (ReqBodyJson bdy) jsonResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig apiplane paths tok
+
+-- | @DELETE@
+delete :: (A.FromJSON b, A.ToJSON a) =>
+          APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
+delete apiplane paths params bdy tok = responseBody <$> req DELETE url (ReqBodyJson bdy) jsonResponse opts
   where
     opts = auth <> params
     (url, auth) = msAzureReqConfig apiplane paths tok
@@ -135,6 +152,23 @@ post apiplane paths params bdy tok = responseBody <$> req POST url (ReqBodyJson
     opts = auth <> params
     (url, auth) = msAzureReqConfig apiplane paths tok
 
+-- | 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
+postSBMessage :: (A.FromJSON b, A.ToJSON a) =>
+                 Text
+              -> [Text]
+              -> Option 'Https -> a -> AccessToken -> Req b
+postSBMessage servName paths params bdy tok = responseBody <$> req POST url (ReqBodyServiceBusMessage bdy) jsonResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig (APServiceBus servName) paths tok
+
+data ReqBodyServiceBusMessage a = ReqBodyServiceBusMessage a
+instance A.ToJSON a => HttpBody (ReqBodyServiceBusMessage a) where
+  getRequestBody (ReqBodyServiceBusMessage a) = L.RequestBodyLBS (A.encode a)
+  getRequestContentType _ = Just "application/vnd.microsoft.servicebus.json"
+
 -- | @GET@
 get :: (A.FromJSON b) =>
        APIPlane
@@ -154,6 +188,7 @@ msAzureReqConfig apiplane uriRest (AccessToken ttok) = (url, os)
     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)
 

diff --git a/ms-azure-api/src/MSAzureAPI/ServiceBus.hs b/ms-azure-api/src/MSAzureAPI/ServiceBus.hs
@@ -3,11 +3,12 @@ module MSAzureAPI.ServiceBus where
 import GHC.Generics (Generic(..))
 
 -- aeson
-import qualified Data.Aeson as A (ToJSON(..), genericToJSON, object, (.=), ToJSONKey(..), FromJSON(..), genericParseJSON, encode)
+import qualified Data.Aeson as A (ToJSON(..), genericToJSON, object, (.=), ToJSONKey(..), FromJSON(..), genericParseJSON)
 -- containers
 import qualified Data.Map as M (Map, singleton, fromList)
 -- hoauth2
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
+
 -- req
 import Network.HTTP.Req (HttpException, runReq, HttpConfig, defaultHttpConfig, Req, Url, Option, Scheme(..), header, (=:))
 -- text
@@ -17,7 +18,24 @@ import Data.Time (UTCTime, getCurrentTime)
 import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale)
 import Data.Time.LocalTime (getZonedTime)
 
-import MSAzureAPI.Internal.Common (run, APIPlane(..), Location(..), locationDisplayName, (==:), get, getBs, post, getLbs, put, tryReq, aesonOptions)
+import MSAzureAPI.Internal.Common (run, APIPlane(..), Location(..), locationDisplayName, (==:), get, getBs, post, postSBMessage, getLbs, put, tryReq, aesonOptions)
+
+-- | Send a message batch to the service bus
+--
+-- https://learn.microsoft.com/en-us/rest/api/servicebus/send-message-batch#request
+sendMessageBatch :: (A.ToJSON a) =>
+                    Text -- ^ namespace
+                 -> Text -- ^ queue name
+                 -> Text -- ^ topic
+                 -> Option 'Https
+                 -> MessageBatch a
+                 -> AccessToken -> Req ()
+sendMessageBatch sn qname topic = postSBMessage sn [
+  qpt
+  , "messages"
+  ]
+  where
+    qpt = qname <> "|" <> topic
 
 
 newtype MessageBatch a = MessageBatch [a] deriving (Eq, Show)