From caced6042d466d30d9fe28169b0b4ecaf5504a6f Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 6 Aug 2023 12:00:03 +0200 Subject: [PATCH] saving --- ms-azure-api/CHANGELOG.md | 6 + ms-azure-api/ms-azure-api.cabal | 3 +- .../src/MSAzureAPI/Internal/Common.hs | 13 +- ms-azure-api/src/MSAzureAPI/ServiceBus.hs | 137 ++++++++++++++++++ .../src/MSGraphAPI/Internal/Common.hs | 11 ++ 5 files changed, 168 insertions(+), 2 deletions(-) create mode 100644 ms-azure-api/src/MSAzureAPI/ServiceBus.hs diff --git a/ms-azure-api/CHANGELOG.md b/ms-azure-api/CHANGELOG.md index a9a5070..e440396 100644 --- a/ms-azure-api/CHANGELOG.md +++ b/ms-azure-api/CHANGELOG.md @@ -8,6 +8,12 @@ and this project adheres to the ## Unreleased +## 0.5.0.0 + +ToJSON instance of Location renders the full name e.g. "West Europe" + +MSAzureAPI.ServiceBus + ## 0.4 TLS support diff --git a/ms-azure-api/ms-azure-api.cabal b/ms-azure-api/ms-azure-api.cabal index 7fa88e2..f745488 100644 --- a/ms-azure-api/ms-azure-api.cabal +++ b/ms-azure-api/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 @@ library MSAzureAPI.MachineLearning.Compute MSAzureAPI.MachineLearning.Jobs MSAzureAPI.MachineLearning.Usages + MSAzureAPI.ServiceBus MSAzureAPI.StorageServices MSAzureAPI.StorageServices.FileService other-modules: MSAzureAPI.Internal.Common diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs index ee38a8f..5891c74 100644 --- a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs +++ b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs @@ -23,6 +23,7 @@ module MSAzureAPI.Internal.Common ( -- *** Location , Location(..) , showLocation + , locationDisplayName -- ** JSON co\/dec , aesonOptions ) where @@ -37,7 +38,7 @@ 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(..), 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) @@ -164,6 +165,7 @@ msAzureReqConfig apiplane uriRest (AccessToken ttok) = (url, os) -- * common types +-- | Displays the short name, e.g. "westeu" showLocation :: Location -> Text showLocation = pack . show @@ -176,6 +178,15 @@ instance Show Location where 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/ms-azure-api/src/MSAzureAPI/ServiceBus.hs b/ms-azure-api/src/MSAzureAPI/ServiceBus.hs new file mode 100644 index 0000000..ad6f304 --- /dev/null +++ b/ms-azure-api/src/MSAzureAPI/ServiceBus.hs @@ -0,0 +1,137 @@ +module MSAzureAPI.ServiceBus where + +import GHC.Generics (Generic(..)) + +-- aeson +import qualified Data.Aeson as A (ToJSON(..), genericToJSON, object, (.=), ToJSONKey(..), FromJSON(..), genericParseJSON, encode) +-- 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, getLbs, put, tryReq, aesonOptions) + + +newtype MessageBatch a = MessageBatch [a] deriving (Eq, Show) +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 diff --git a/ms-graph-api/src/MSGraphAPI/Internal/Common.hs b/ms-graph-api/src/MSGraphAPI/Internal/Common.hs index 133da85..56bc326 100644 --- a/ms-graph-api/src/MSGraphAPI/Internal/Common.hs +++ b/ms-graph-api/src/MSGraphAPI/Internal/Common.hs @@ -84,6 +84,10 @@ run :: MonadIO m => run hc = runReq hc . tryReq + + + + -- * REST verbs put :: (A.FromJSON b, A.ToJSON a) => @@ -123,6 +127,13 @@ get paths params tok = responseBody <$> req GET url NoReqBody jsonResponse opts opts = auth <> params (url, auth) = msGraphReqConfig tok paths +-- getCollection paths params tok = do +-- e <- tryReq (get paths params tok) +-- case e of +-- Right (Collection xs m) -> case m of +-- Just ulink -> do +-- u <- mkURI ulink + -- -- | Like 'get' but catches 'HttpException's to allow pattern matching -- getE :: (A.FromJSON a) => -- [Text] -- ^ URI path segments