diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,19 @@ ## Unreleased +## 0.5.0.0 + +ToJSON instance of Location renders the full name e.g. "West Europe" + +MSAzureAPI.ServiceBus + +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 + ## 0.4 TLS support 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.4.0.0 +version: 0.5.0.0 synopsis: Microsoft Azure API description: Bindings to the Microsoft Azure API homepage: https://github.com/unfoldml/ms-graph-api @@ -22,6 +22,7 @@ MSAzureAPI.MachineLearning.Compute MSAzureAPI.MachineLearning.Jobs MSAzureAPI.MachineLearning.Usages + MSAzureAPI.ServiceBus MSAzureAPI.StorageServices MSAzureAPI.StorageServices.FileService other-modules: MSAzureAPI.Internal.Common @@ -32,6 +33,7 @@ , 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/src/MSAzureAPI/Internal/Common.hs b/src/MSAzureAPI/Internal/Common.hs --- a/src/MSAzureAPI/Internal/Common.hs +++ b/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 @@ -23,6 +29,7 @@ -- *** Location , Location(..) , showLocation + , locationDisplayName -- ** JSON co\/dec , aesonOptions ) where @@ -37,12 +44,14 @@ 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 @@ -51,7 +60,7 @@ -- 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 @@ -109,6 +118,7 @@ -- 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@ @@ -117,11 +127,19 @@ -> [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 + -- | @POST@ post :: (A.FromJSON b, A.ToJSON a) => APIPlane @@ -134,6 +152,23 @@ 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 @@ -153,6 +188,7 @@ 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) @@ -164,6 +200,7 @@ -- * common types +-- | Displays the short name, e.g. "westeu" showLocation :: Location -> Text showLocation = pack . show @@ -176,6 +213,15 @@ show = \case LNorthEU -> "northeu" LWestEU -> "westeu" +-- | Renders the full name via 'locationDisplayName' +instance A.ToJSON Location where + toJSON = A.String . locationDisplayName + +-- | Displays the full name, e.g. "West Europe" +locationDisplayName :: Location -> Text +locationDisplayName = \case + LNorthEU -> "North Europe" + LWestEU -> "West Europe" -- | a collection of items with key @value@ -- diff --git a/src/MSAzureAPI/ServiceBus.hs b/src/MSAzureAPI/ServiceBus.hs new file mode 100644 --- /dev/null +++ b/src/MSAzureAPI/ServiceBus.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +module MSAzureAPI.ServiceBus where + +import GHC.Exts (IsList(..)) +import GHC.Generics (Generic(..)) + +-- aeson +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 +import Data.Text (Text, pack, unpack) +-- time +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, 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) +instance IsList (MessageBatch a) where + type Item (MessageBatch a) = a + fromList = MessageBatch + toList (MessageBatch xs) = xs +instance A.ToJSON a => A.ToJSON (MessageBatch a) where + toJSON (MessageBatch xs) = A.toJSON $ map (\x -> M.singleton ("Body" :: String) x) xs + +-- | Create a service bus topic +-- +-- https://learn.microsoft.com/en-us/rest/api/servicebus/controlplane-stable/topics/create-or-update?tabs=HTTP +createTopic :: + Text -- ^ subscription id + -> Text -- ^ RG name + -> Text -- ^ namespace name + -> Text -- ^ topic name + -> TopicCreate + -> AccessToken -> Req () +createTopic subid rgname nname tname = put APManagement [ + "subscriptions", subid + , "resourceGroup", rgname + , "providers", "Microsoft.ServiceBus" + , "namespaces", nname + , "topicName", tname + ] ("api-version" ==: "2021-11-01") + +data TopicCreate = TopicCreate { + tcProperties :: TCProperties + } deriving (Eq, Show, Generic) + +instance A.ToJSON TopicCreate where + toJSON = A.genericToJSON (aesonOptions "tc") +data TCProperties = TCProperties { + tcpEnableBatchedOperations :: Bool -- ^ enable batched operations on the backend + } deriving (Eq, Show, Generic) +instance A.ToJSON TCProperties where + toJSON = A.genericToJSON (aesonOptions "tcp") + +-- | Create a service bus queue using default options +-- +-- https://learn.microsoft.com/en-us/rest/api/servicebus/controlplane-stable/queues/create-or-update?tabs=HTTP +createQueue :: + Text -- ^ subscription id + -> Text -- ^ RG name + -> Text -- ^ namespace name + -> Text -- ^ queue name + -> AccessToken + -> Req QueueCreateResponse +createQueue subid rgname nname qname = put APManagement [ + "subscriptions", subid + , "resourceGroup", rgname + , "providers", "Microsoft.ServiceBus" + , "namespaces", nname + , "queues", qname + ] ("api-version" ==: "2021-11-01") () + +data QueueCreateResponse = QueueCreateResponse { + qcrId :: Text + , qcrProperties :: QCRProperties + } deriving (Eq, Show, Generic) +instance A.FromJSON QueueCreateResponse where + parseJSON = A.genericParseJSON (aesonOptions "qcr") + +data QCRProperties = QCRProperties { + qcrpMaxMessageSizeInKilobytes :: Int + } deriving (Eq, Show, Generic) +instance A.FromJSON QCRProperties where + parseJSON = A.genericParseJSON (aesonOptions "qcrp") + +-- | Create a service bus namespace +-- +-- https://learn.microsoft.com/en-us/rest/api/servicebus/controlplane-stable/namespaces/create-or-update?tabs=HTTP#namespacecreate +createNamespace :: + Text -- ^ subscription id + -> Text -- ^ RG name + -> Text -- ^ namespace name + -> NameSpaceCreate + -> AccessToken + -> Req NameSpaceCreateResponse +createNamespace subid rgname nname = put APManagement [ + "subscriptions", subid + , "resourceGroup", rgname + , "providers", "Microsoft.ServiceBus" + , "namespaces", nname + ] ("api-version" ==: "2021-11-01") + +-- | https://learn.microsoft.com/en-us/rest/api/servicebus/controlplane-stable/namespaces/create-or-update?tabs=HTTP#namespacecreate +data NameSpaceCreate = NameSpaceCreate { + sku :: Sku + , location :: Location + } deriving (Eq, Show, Generic) +instance A.ToJSON NameSpaceCreate + +data NameSpaceCreateResponse = NameSpaceCreateResponse { + nscrId :: Text + , nscrProperties :: NSCRProperties + } deriving (Eq, Show, Generic) +instance A.FromJSON NameSpaceCreateResponse where + parseJSON = A.genericParseJSON (aesonOptions "nscr") + +data NSCRProperties = NSCRProperties { + nscrpCreatedAt :: UTCTime + , nscrpServiceBusEndpoint :: Text + } deriving (Eq, Show, Generic) +instance A.FromJSON NSCRProperties where + parseJSON = A.genericParseJSON (aesonOptions "nscrp") + +data Sku = Sku { + skuName :: SkuName + } deriving (Eq, Show) +-- | name and tier are rendered as the same thing +instance A.ToJSON Sku where + toJSON (Sku n) = A.object [ + "name" A..= n + , "tier" A..= n + ] + +data SkuName = Basic | Premium | Standard deriving (Eq, Show, Generic) +instance A.ToJSON SkuName