v 0.4

unfoldml · Jun 26, 2023 · 45475f9 · 45475f9
1 parent ad94588
commit 45475f9
Show file tree

Hide file tree

Showing 5 changed files with 139 additions and 29 deletions.
diff --git a/ms-azure-api/CHANGELOG.md b/ms-azure-api/CHANGELOG.md
@@ -8,6 +8,11 @@ and this project adheres to the
 
 ## Unreleased
 
+## 0.4
+
+TLS support
+
+
 ## 0.3.1.0
 
 MSAzureAPI.StorageServices.FileService : add listDirectoriesAndFilesC (stream all response pages from listDirectoriesAndFiles)

diff --git 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.3.1.0
+version:             0.4.0.0
 synopsis:            Microsoft Azure API
 description:         Bindings to the Microsoft Azure API
 homepage:            https://github.com/unfoldml/ms-graph-api
@@ -32,6 +32,7 @@ library
                      , containers
                      , exceptions >= 0.10.4
                      , hoauth2 == 2.6.0
+                     , http-client-tls >= 0.3.6.1
                      , http-types
                      , modern-uri
                      , req

diff --git a/ms-azure-api/src/MSAzureAPI/Internal/Common.hs b/ms-azure-api/src/MSAzureAPI/Internal/Common.hs
@@ -9,6 +9,9 @@ module MSAzureAPI.Internal.Common (
   , getBs
   , getLbs
   , post
+  -- * HTTP(S) connections
+  , run
+  , withTLS
   -- ** URL parameters
   , (==:)
   -- ** Helpers
@@ -40,13 +43,15 @@ 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-tls
+import Network.HTTP.Client.TLS (newTlsManager)
 -- hoauth2
 import Network.OAuth.OAuth2 (OAuth2Token(..))
 import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
 -- modern-uri
 -- import Text.URI (URI, mkURI)
 -- req
-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)
+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)
 -- text
 import Data.Text (Text, pack, unpack)
 -- unliftio
@@ -77,6 +82,21 @@ getBs apiplane paths params tok = responseBody <$> req GET url NoReqBody bsRespo
     opts = auth <> params
     (url, auth) = msAzureReqConfig apiplane paths tok
 
+-- | Create a new TLS manager, which should be reused throughout the program
+withTLS :: MonadIO m =>
+           (HttpConfig -> m b) -- ^ user program
+        -> m b
+withTLS act = do
+  mgr <- newTlsManager
+  let
+    hc = defaultHttpConfig { httpConfigAltManager = Just mgr }
+  act hc
+
+-- | Run a 'Req' computation
+run :: MonadIO m =>
+       HttpConfig -> Req a -> m (Either HttpException a)
+run hc = runReq hc . tryReq
+
 
 -- | Specialized version of 'try' to 'HttpException's
 --

diff --git a/ms-azure-api/src/MSAzureAPI/MachineLearning/Jobs.hs b/ms-azure-api/src/MSAzureAPI/MachineLearning/Jobs.hs
@@ -1,4 +1,11 @@
-module MSAzureAPI.MachineLearning.Jobs where
+module MSAzureAPI.MachineLearning.Jobs (
+  createJob
+  , listJobs
+  , JobBaseResource(..)
+  , JobBase(..)
+  , Status(..)
+  , SystemData(..)
+                                       ) where
 
 import Control.Applicative (Alternative(..))
 import Control.Monad.IO.Class (MonadIO(..))
@@ -21,8 +28,8 @@ import Network.HTTP.Req (Req, Url, Option, Scheme(..), header, (=:))
 -- text
 import Data.Text (Text, pack, unpack)
 import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict)
--- -- time
--- import Data.Time (UTCTime, getCurrentTime)
+-- time
+import Data.Time (UTCTime, getCurrentTime)
 -- import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale)
 -- import Data.Time.LocalTime (getZonedTime)
 -- -- xeno
@@ -32,36 +39,111 @@ import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict)
 -- xmlbf
 -- import qualified Xmlbf as XB (Parser, runParser, pElement, pText)
 
-import qualified MSAzureAPI.Internal.Common as MSA (APIPlane(..), (==:), put, get, getBs, post, getLbs, aesonOptions)
+import qualified MSAzureAPI.Internal.Common as MSA (APIPlane(..), Collection, (==:), put, get, getBs, post, getLbs, aesonOptions)
 
+-- | List jobs
+--
+-- @ GET https:\/\/management.azure.com\/subscriptions\/{subscriptionId}\/resourceGroups\/{resourceGroupName}\/providers\/Microsoft.MachineLearningServices\/workspaces\/{workspaceName}\/jobs?api-version=2023-04-01&$skip={$skip}&jobType={jobType}&tag={tag}&listViewType={listViewType}@
+listJobs ::
+  Text -- ^ subscription id
+  -> Text -- ^ res group id
+  -> Text -- ^ ML workspace id
+  -> AccessToken -> Req (MSA.Collection JobBaseResource)
+listJobs sid rgid wsid = MSA.get MSA.APManagement [
+    "subscriptions", sid,
+    "resourceGroups", rgid,
+    "providers", "Microsoft.MachineLearningServices",
+    "workspaces", wsid,
+    "jobs"
+    ] ("api-version" MSA.==: "2023-04-01")
 
 
--- | create a job
+-- | Create a job
 --
 -- docs: <https://learn.microsoft.com/en-us/rest/api/azureml/2023-04-01/jobs/create-or-update?tabs=HTTP>
 --
 -- @PUT https:\/\/management.azure.com\/subscriptions\/{subscriptionId}\/resourceGroups\/{resourceGroupName}\/providers\/Microsoft.MachineLearningServices\/workspaces\/{workspaceName}\/jobs\/{id}?api-version=2023-04-01@
-createJob :: (A.FromJSON b) =>
-             Text -- ^ subscription id
-          -> Text -- ^ res group id
-          -> Text -- ^ ML workspace id
-          -> Text -- ^ job id
-          -> JobBase
-          -> AccessToken -> Req b
+createJob ::
+  Text -- ^ subscription id
+  -> Text -- ^ res group id
+  -> Text -- ^ ML workspace id
+  -> Text -- ^ job id
+  -> JobBase
+  -> AccessToken -> Req JobBaseResource
 createJob sid rgid wsid jid =
-  MSA.put MSA.APManagement ["subscriptions", sid,
-                    "resourceGroups", rgid,
-                    "providers", "Microsoft.MachineLearningServices",
-                    "workspaces", wsid,
-                    "jobs", jid] ("api-version" MSA.==: "2023-04-JobBase")
+  MSA.put MSA.APManagement [
+  "subscriptions", sid,
+    "resourceGroups", rgid,
+    "providers", "Microsoft.MachineLearningServices",
+    "workspaces", wsid,
+    "jobs", jid] ("api-version" MSA.==: "2023-04-01")
+
+-- | https://learn.microsoft.com/en-us/rest/api/azureml/2023-04-01/jobs/create-or-update?tabs=HTTP#jobbaseresource
+data JobBaseResource = JobBaseResource {
+  jbrId :: Text
+  , jbrName :: Text
+  , jbrSystemData :: SystemData
+  , jbrProperties :: JobBase
+                                       } deriving (Eq, Show, Generic)
+instance A.FromJSON JobBaseResource where
+  parseJSON = A.genericParseJSON (MSA.aesonOptions "jbr")
 
--- | 01 type
+data SystemData = SystemData {
+  sdCreatedAt :: UTCTime
+  , sdCreatedBy :: Text
+  , srLastModifiedAt :: UTCTime
+  , srLastModifiedBy :: Text
+                             } deriving (Eq, Show, Generic)
+instance A.FromJSON SystemData where
+  parseJSON = A.genericParseJSON (MSA.aesonOptions "sd")
+
+-- | JobBase
 --
 -- https://learn.microsoft.com/en-us/rest/api/azureml/2023-04-01/jobs/create-or-update?tabs=HTTP
-data JobBase = JBAutoMLJob -- ^ https://learn.microsoft.com/en-us/rest/api/azureml/2023-04-01/jobs/list?tabs=HTTP#automljob
-             | JBCommandJob
-             | JBPipelineJob
-             | JBSweepJob
+-- data JobBase = JBAutoMLJob {
+--   jbStatus :: Status
+--   , jbComponentId :: Text
+--   , jb
+--                            } -- ^ https://learn.microsoft.com/en-us/rest/api/azureml/2023-04-01/jobs/list?tabs=HTTP#automljob
+--              | JBCommandJob {
+--   jbStatus :: Status
+--                            }
+--              | JBPipelineJob {
+--   jbStatus :: Status
+--                            }
+--              | JBSweepJob {
+--   jbStatus :: Status
+--                            }
+data JobBase = JobBase {
+    jbStatus :: Status
+  , jbComponentId :: Text
+  , jbComputeId :: Text
+  , jbDescription :: Text
+  , jbDisplayName :: Text
+  -- , jbInputs :: A.Value -- AutoMLJob doesn't have inputs
+  , jbOutputs :: A.Value
+  , jbProperties :: A.Value
+                       }
              deriving (Eq, Show, Generic)
+instance A.FromJSON JobBase where
+  parseJSON = A.genericParseJSON (MSA.aesonOptions "jb")
 instance A.ToJSON JobBase where
   toEncoding = A.genericToEncoding (MSA.aesonOptions "jb")
+
+data Status = CancelRequested
+            | Canceled
+            | Completed
+            | Failed
+            | Finalizing
+            | NotResponding
+            | NotStarted
+            | Paused
+            | Preparing
+            | Provisioning
+            | Queued
+            | Running
+            | Starting
+            | Unknown
+            deriving (Eq, Show, Generic)
+instance A.FromJSON Status
+instance A.ToJSON Status
diff --git a/ms-azure-api/src/MSAzureAPI/StorageServices/FileService.hs b/ms-azure-api/src/MSAzureAPI/StorageServices/FileService.hs
@@ -37,7 +37,7 @@ import Data.Conduit ((.|))
 -- import Network.OAuth.OAuth2 (OAuth2Token(..))
 import Network.OAuth.OAuth2.Internal (AccessToken(..))
 -- req
-import Network.HTTP.Req (HttpException, runReq, defaultHttpConfig, Req, Url, Option, Scheme(..), header, (=:))
+import Network.HTTP.Req (HttpException, runReq, HttpConfig, defaultHttpConfig, Req, Url, Option, Scheme(..), header, (=:))
 -- text
 import Data.Text (Text, pack, unpack)
 import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict)
@@ -52,7 +52,7 @@ import qualified Xmlbf.Xeno as XB (fromRawXml)
 -- xmlbf
 import qualified Xmlbf as XB (Parser, runParser, pElement, pText)
 
-import MSAzureAPI.Internal.Common (APIPlane(..), (==:), get, getBs, post, getLbs, tryReq)
+import MSAzureAPI.Internal.Common (run, APIPlane(..), (==:), get, getBs, post, getLbs, tryReq)
 
 
 
@@ -159,11 +159,13 @@ listDirectoriesAndFilesC :: (MonadIO m, MonadThrow m) =>
                             Text -- ^ storage account
                          -> Text -- ^ file share
                          -> Text -- ^ directory path, including directories
-                         -> AccessToken -> C.ConduitT i [DirItem] m ()
-listDirectoriesAndFilesC acct fshare fpath atok = go Nothing
+                         -> HttpConfig
+                         -> AccessToken
+                         -> C.ConduitT i [DirItem] m ()
+listDirectoriesAndFilesC acct fshare fpath hc atok = go Nothing
   where
     go mm = do
-      eres <- runReq defaultHttpConfig $ tryReq $ listDirectoriesAndFiles acct fshare fpath mm atok
+      eres <- run hc $ listDirectoriesAndFiles acct fshare fpath mm atok
       case eres of
         Left e -> throwM $ FSHttpE e
         Right xe -> case xe of