From ff6e4e932a40392ac3c6c30c4a5b09b79a985cb4 Mon Sep 17 00:00:00 2001
From: Marco Zocca <marco.zocca@unfoldml.com>
Date: Tue, 20 Jun 2023 13:17:55 +0200
Subject: [PATCH] add stuff

---
 ms-azure-api/ms-azure-api.cabal               |  2 +
 .../src/MSAzureAPI/Internal/Common.hs         | 69 +++++++++++++++++--
 .../src/MSAzureAPI/StorageServices.hs         | 11 +++
 3 files changed, 76 insertions(+), 6 deletions(-)
 create mode 100644 ms-azure-api/src/MSAzureAPI/StorageServices.hs

diff --git a/ms-azure-api/ms-azure-api.cabal b/ms-azure-api/ms-azure-api.cabal
index d4ef1d7..f93c195 100644
--- a/ms-azure-api/ms-azure-api.cabal
+++ b/ms-azure-api/ms-azure-api.cabal
@@ -19,6 +19,7 @@ library
   default-language:    Haskell2010
   hs-source-dirs:      src
   exposed-modules:     MSAzureAPI.Internal.Common
+                       MSAzureAPI.StorageServices
   build-depends:       base >= 4.7 && < 5
                      , aeson
                      , bytestring
@@ -40,6 +41,7 @@ library
                        DeriveFunctor
                        DerivingStrategies
                        LambdaCase
+                       DataKinds
 
 
 source-repository head
diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
index ca1b340..d01c45a 100644
--- a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
+++ b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
@@ -2,7 +2,17 @@
 {-# options_ghc -Wno-unused-imports #-}
 -- | Common functions for the MS Azure API
 --
-module MSAzureAPI.Internal.Common where
+module MSAzureAPI.Internal.Common (
+  APIPlane(..)
+  , get
+  , getLbs
+  , post
+  -- ** Helpers
+  , tryReq
+  -- ** JSON
+  , Collection
+  , aesonOptions
+  ) where
 
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.Proxy (Proxy)
@@ -29,18 +39,65 @@ import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), Refres
 import Network.HTTP.Req (Req, runReq, HttpException(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), Url, Scheme(..), useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody)
 -- text
 import Data.Text (Text, pack, unpack)
+-- unliftio
+import UnliftIO (MonadUnliftIO(..))
+import UnliftIO.Exception (try)
 
 
+getLbs :: APIPlane
+       -> [Text] -> Option 'Https -> AccessToken -> Req LBS.ByteString
+getLbs apiplane paths params tok = responseBody <$> req GET url NoReqBody lbsResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig apiplane paths tok
+
+
+-- | Specialized version of 'try' to 'HttpException's
+--
+-- This can be used to catch exceptions of composite 'Req' statements, e.g. around a @do@ block
+tryReq :: Req a -> Req (Either HttpException a)
+tryReq = try
+
+-- | API control planes
+data APIPlane = APManagement -- ^ Management plane (@management.azure.com@ endpoints)
+              | APData Text -- ^ Data plane e.g. FileREST API
 
--- | Data plane e.g for FileREST API
+-- | @POST@
+post :: (A.FromJSON b, A.ToJSON a) =>
+        APIPlane
+     -> [Text] -- ^ URI path segments
+     -> Option 'Https
+     -> a -- ^ request body
+     -> AccessToken -> Req b
+post apiplane paths params bdy tok = responseBody <$> req POST url (ReqBodyJson bdy) jsonResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig apiplane paths tok
+
+-- | @GET@
+get :: (A.FromJSON b) =>
+       APIPlane
+    -> [Text] -- ^ URI path segments
+    -> Option 'Https -> AccessToken -> Req b
+get apiplane paths params tok = responseBody <$> req GET url NoReqBody jsonResponse opts
+  where
+    opts = auth <> params
+    (url, auth) = msAzureReqConfig apiplane paths tok
 
--- | Control plane
-msAzureManagementReqConfig :: AccessToken -> [Text] -> (Url 'Https, Option 'Https)
-msAzureManagementReqConfig (AccessToken ttok) uriRest = (url, os)
+msAzureReqConfig :: APIPlane
+                 -> [Text] -- ^ URI path segments
+                 -> AccessToken
+                 -> (Url 'Https, Option 'Https)
+msAzureReqConfig apiplane uriRest (AccessToken ttok) = (url, os)
   where
-    url = (https "management.azure.com") //: uriRest
+    urlBase = \case
+      APManagement -> "management.azure.com"
+      APData ub -> ub
+    url = (https $ urlBase apiplane) //: uriRest
     os = oAuth2Bearer $ BS8.pack (unpack ttok)
 
+
+
 (//:) :: Url scheme -> [Text] -> Url scheme
 (//:) = foldl (/:)
 
diff --git a/ms-azure-api/src/MSAzureAPI/StorageServices.hs b/ms-azure-api/src/MSAzureAPI/StorageServices.hs
new file mode 100644
index 0000000..ef5dbbc
--- /dev/null
+++ b/ms-azure-api/src/MSAzureAPI/StorageServices.hs
@@ -0,0 +1,11 @@
+module MSAzureAPI.StorageServices where
+
+{- Permissions that an Azure AD entity (user or service principal) needs to perform file service operations:
+
+
+https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory#permissions-for-calling-data-operations
+-}
+
+
+
+