diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,11 @@ ## 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.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.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 @@ , containers , exceptions >= 0.10.4 , hoauth2 == 2.6.0 + , http-client-tls >= 0.3.6.1 , http-types , modern-uri , req 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 @@ -9,6 +9,9 @@ , getBs , getLbs , post + -- * HTTP(S) connections + , run + , withTLS -- ** URL parameters , (==:) -- ** Helpers @@ -40,13 +43,15 @@ 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 @@ -76,6 +81,21 @@ where 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/src/MSAzureAPI/MachineLearning/Jobs.hs b/src/MSAzureAPI/MachineLearning/Jobs.hs --- a/src/MSAzureAPI/MachineLearning/Jobs.hs +++ b/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 @@ -- 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 @@ -- 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: -- -- @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") --- | 01 type +-- | 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") + +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/src/MSAzureAPI/StorageServices/FileService.hs b/src/MSAzureAPI/StorageServices/FileService.hs --- a/src/MSAzureAPI/StorageServices/FileService.hs +++ b/src/MSAzureAPI/StorageServices/FileService.hs @@ -37,7 +37,7 @@ -- 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 @@ -- 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 @@ 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