diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog for `ms-azure-api` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 + +First release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,32 @@ +# ms-azure-api + +Haskell client bindings to the [Microsoft Azure API](). + +[![Hackage](https://img.shields.io/hackage/v/ms-azure-api?style=for-the-badge)](https://hackage.haskell.org/package/ms-azure-api) + +![main](https://github.com/unfoldml/ms-graph-api/actions/workflows/haskell.yml/badge.svg?branch=main) + + +## Introduction + +This library provides the client interface (under the `MSAzureAPI` namespace). + +Authentication can be implemented with the @ms-auth@ library. + +## Status + +This library is still in development, so expect missing functionality. +If there's anything you would like to see added, feel free to +[open an issue](https://github.com/unfoldml/ms-graph-api/issues/new). +In general, since the MS Azure API is quite large, features will be added to this library on a need basis. + +## Evolution of the library + +Some breaking changes might also be introduced as the library matures. + +We adhere to a simplified version of the [Package Versioning Policy](https://pvp.haskell.org/): breaking changes are signaled by increasing the major version number (e.g. 0.x -> 1.x ). + + +## Copyright + +(c) 2023-, Marco Zocca, UnfoldML AB diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ms-azure-api.cabal b/ms-azure-api.cabal new file mode 100644 --- /dev/null +++ b/ms-azure-api.cabal @@ -0,0 +1,50 @@ +name: ms-azure-api +version: 0.1.0.0 +synopsis: Microsoft Azure API +description: Bindings to the Microsoft Azure API +homepage: https://github.com/unfoldml/ms-api +license: BSD3 +license-file: LICENSE +author: Marco Zocca +maintainer: oss@unfoldml.com +copyright: 2023 Marco Zocca +category: Web +build-type: Simple +extra-source-files: README.md + CHANGELOG.md +cabal-version: >=1.10 +tested-with: GHC == 7.10.2 + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: MSAzureAPI.Internal.Common + MSAzureAPI.StorageServices + MSAzureAPI.StorageServices.FileService + build-depends: base >= 4.7 && < 5 + , aeson + , bytestring + , containers + , hoauth2 == 2.6.0 + , http-types + , modern-uri + , req + , scientific + , text + , time >= 1.8 + , transformers >= 0.5 + , unliftio + ghc-options: -Wall + -Wcompat + -Wno-unused-imports + default-extensions: OverloadedStrings + DeriveGeneric + DeriveFunctor + DerivingStrategies + LambdaCase + DataKinds + + +source-repository head + type: git + location: https://github.com/unfoldml/ms-azure-api diff --git a/src/MSAzureAPI/Internal/Common.hs b/src/MSAzureAPI/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/MSAzureAPI/Internal/Common.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DataKinds #-} +{-# options_ghc -Wno-unused-imports #-} +-- | Common functions for the MS Azure API +-- +module MSAzureAPI.Internal.Common ( + APIPlane(..) + , get + , getLbs + , post + -- ** Helpers + , tryReq + -- ** JSON + , Collection + , aesonOptions + ) where + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Proxy (Proxy) +import GHC.Generics (Generic(..)) + +import Data.List (sort, sortBy, stripPrefix, uncons) +import Data.Maybe (listToMaybe, fromMaybe) +-- import Data.Ord (comparing) +import Data.Char (toLower) + +-- aeson +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) +import qualified Data.ByteString.Lazy as LBS (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn) +-- 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) +-- text +import Data.Text (Text, pack, unpack) +-- unliftio +import UnliftIO (MonadUnliftIO(..)) +import UnliftIO.Exception (try) + + +-- | @GET@ a 'LBS.ByteString' e.g. a file +getLbs :: APIPlane + -> [Text] -- ^ URI path segments + -> 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 +-- +-- 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 + +-- | @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 + +msAzureReqConfig :: APIPlane + -> [Text] -- ^ URI path segments + -> AccessToken + -> (Url 'Https, Option 'Https) +msAzureReqConfig apiplane uriRest (AccessToken ttok) = (url, os) + where + urlBase = case apiplane of + APManagement -> "management.azure.com" + APData ub -> ub + url = (https urlBase) //: uriRest + os = oAuth2Bearer $ BS8.pack (unpack ttok) + + + +(//:) :: Url scheme -> [Text] -> Url scheme +(//:) = foldl (/:) + + +-- * aeson + +-- | a collection of items with key @value@ +data Collection a = Collection { + cValue :: [a] + } deriving (Eq, Show, Generic) +instance A.FromJSON a => A.FromJSON (Collection a) where + parseJSON = A.genericParseJSON (aesonOptions "c") + +-- | drop the prefix and lowercase first character +-- +-- e.g. @userDisplayName@ @->@ @displayName@ +aesonOptions :: String -- ^ record prefix + -> A.Options +aesonOptions pfx = A.defaultOptions { A.fieldLabelModifier = recordName pfx } + +-- | drop the prefix and lowercase first character +recordName :: String -- ^ record name prefix + -> String -- ^ JSON field name + -> String +recordName pf str = case uncons $ dropPrefix pf str of + Just (c, cs) -> toLower c : cs + _ -> error "record name cannot be empty" + +-- | Drops the given prefix from a list. +-- It returns the original sequence if the sequence doesn't start with the given prefix. +-- +-- > dropPrefix "Mr. " "Mr. Men" == "Men" +-- > dropPrefix "Mr. " "Dr. Men" == "Dr. Men" +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix a b = fromMaybe b $ stripPrefix a b diff --git a/src/MSAzureAPI/StorageServices.hs b/src/MSAzureAPI/StorageServices.hs new file mode 100644 --- /dev/null +++ b/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 +-} + + + + diff --git a/src/MSAzureAPI/StorageServices/FileService.hs b/src/MSAzureAPI/StorageServices/FileService.hs new file mode 100644 --- /dev/null +++ b/src/MSAzureAPI/StorageServices/FileService.hs @@ -0,0 +1,107 @@ +-- | StorageServices.FileService +-- +-- authorize with AD : https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory +-- +-- permissions for calling data operations : https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory#permissions-for-calling-data-operations +module MSAzureAPI.StorageServices.FileService (getFile) where + +import Control.Monad.IO.Class (MonadIO(..)) + +-- bytestring +import qualified Data.ByteString.Char8 as BS8 (pack, unpack) +import qualified Data.ByteString.Lazy as LBS (ByteString) +-- hoauth2 +-- import Network.OAuth.OAuth2 (OAuth2Token(..)) +import Network.OAuth.OAuth2.Internal (AccessToken(..)) +-- req +import Network.HTTP.Req (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 (APIPlane(..), get, post, getLbs) + +{- | Headers: + +https://learn.microsoft.com/en-us/rest/api/storageservices/authorize-with-azure-active-directory#call-storage-operations-with-oauth-tokens + +Requests that use an OAuth 2.0 token from Azure Active Directory (Azure AD): To authorize a request with Azure AD, pass the + +x-ms-version + +header on the request with a service version of 2017-11-09 or higher. For more information, see Call storage operations with OAuth tokens in Authorize with Azure Active Directory. + +-} + +xMsVerHeader :: Option 'Https +xMsVerHeader = header "x-ms-version" "2022-11-02" + + +-- | x-ms-date header should be formatted as +-- +-- %a, %d %b %Y %H:%M:%S GMT +-- +-- e.g. Fri, 26 Jun 2015 23:39:12 GMT +xMsDateHeader :: MonadIO m => m (Option 'Https) +xMsDateHeader = do + zt <- liftIO getZonedTime + let + zth = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" zt + pure $ header "x-ms-date" (BS8.pack zth) + +-- getDateHeader :: MonadIO m => m String +-- getDateHeader = do +-- zt <- liftIO getZonedTime +-- pure $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" zt + + +-- | Configure a StorageService request +-- msStorageReqConfig :: MonadIO m => +-- AccessToken -> Text -> [Text] -> m (Url 'Https, Option 'Https) +-- msStorageReqConfig atok uriBase uriRest = do +-- dateHeader <- xMsDateHeader +-- let +-- verHeader = xMsVerHeader +-- (url, os) = msAzureDataReqConfig atok uriBase uriRest +-- pure (url, os <> verHeader <> dateHeader) + +msStorageReqHeaders :: MonadIO m => m (Option 'Https) +msStorageReqHeaders = do + dh <- xMsDateHeader + let + vh = xMsVerHeader + pure (dh <> vh) + +-- | get file https://learn.microsoft.com/en-us/rest/api/storageservices/get-file#request +-- +-- @GET https:\/\/myaccount.file.core.windows.net\/myshare\/mydirectorypath\/myfile@ +getFile :: Text -- ^ storage account + -> Text -- ^ file share + -> Text -- ^ filepath, including directories + -> AccessToken + -> Req LBS.ByteString +getFile acct fshare fpath atok = do + os <- msStorageReqHeaders + getLbs (APData domain) pth os atok + where + domain = acct <> ".file.core.windows.net" + pth = [fshare, fpath] + +-- | list directories and files https://learn.microsoft.com/en-us/rest/api/storageservices/list-directories-and-files#request +-- +-- GET https://myaccount.file.core.windows.net/myshare/mydirectorypath?restype=directory&comp=list +-- listDirectoryAndFiles + +-- +-- Path component Description +-- +-- myaccount The name of your storage account. +-- myshare The name of your file share. +-- mydirectorypath Optional. The path to the directory. +-- myfile The name of the file. + + +