-- | 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 ( -- * Files getFile -- * Directories , listDirectoriesAndFiles -- , listDirectoriesAndFilesC , DirItems(..) , DirItem(..) ) where import Control.Applicative (Alternative(..), optional) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (asum) import Data.Functor (void) import Data.Maybe (listToMaybe, isJust) import qualified Text.ParserCombinators.ReadP as RP (ReadP, readP_to_S, choice, many, between, char, string, satisfy) -- 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) -- conduit import qualified Data.Conduit as C (ConduitT, yield, runConduitRes) import Data.Conduit ((.|)) -- hoauth2 -- import Network.OAuth.OAuth2 (OAuth2Token(..)) import Network.OAuth.OAuth2.Internal (AccessToken(..)) -- req import Network.HTTP.Req (HttpException, runReq, defaultHttpConfig, 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) import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale) import Data.Time.LocalTime (getZonedTime) -- xeno import qualified Xeno.DOM.Robust as X (Node, Content(..), name, contents, children) -- xmlbf-xeno 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) {- | 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 -- -- NB the the response list contains at most 5000 elements -- -- @GET https:\/\/myaccount.file.core.windows.net\/myshare\/mydirectorypath?restype=directory&comp=list@ -- -- === Paginated results -- -- NB : The Marker, ShareSnapshot, and MaxResults elements are present only if you specify them on the request URI. -- -- If the @ element in the @XML body has a value, it means that the result list is not complete. In that case listDirectoriesAndFiles :: Text -- ^ storage account -> Text -- ^ file share -> Text -- ^ directory path, including directories -> Maybe Text -- ^ next page marker. Use 'Nothing' to retrieve first page of results -> AccessToken -> Req (Either String DirItems) listDirectoriesAndFiles acct fshare fpath mm atok = do os <- msStorageReqHeaders bs <- getBs (APData domain) pth (os <> "restype" ==: "directory" <> "comp" ==: "list" <> mMarker mm) atok pure $ parseXML listDirectoriesP bs where domain = acct <> ".file.core.windows.net" pth = [fshare, fpath] mMarker = \case Just m -> ("marker" ==: m) _ -> mempty -- -- | Repeated call of 'listDirectoriesAndFiles' supporting multi-page results -- listDirectoriesAndFilesC :: MonadIO 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 -- where -- go mm = do -- eres <- runReq defaultHttpConfig $ tryReq $ listDirectoriesAndFiles acct fshare fpath mm atok -- case eres of -- Left _ -> undefined -- FIXME http exception -- Right xe -> case xe of -- Left _ -> undefined -- FIXME xml parsing error -- Right (DirItems xs nMarker) -> do -- C.yield xs -- when (isJust nMarker) (go nMarker) -- | Directory item, as returned by 'listDirectoriesAndFiles' data DirItem = DIFile {diId :: Text, diName :: Text} -- ^ file | DIDirectory {diId :: Text, diName :: Text} -- ^ directory deriving (Show) -- | Items in the 'listDirectoriesAndFiles' response data DirItems = DirItems { disItems :: [DirItem] , disResponseMarker :: Maybe Text -- ^ marker to request next page of results } -- | XML parser for the response body format shown here: https://learn.microsoft.com/en-us/rest/api/storageservices/list-directories-and-files#response-body listDirectoriesP :: XB.Parser DirItems listDirectoriesP = do tag "EnumerationResults" $ do enumResultsIgnore es <- entries nm <- nextMarker pure (DirItems es nm) enumResultsIgnore :: XB.Parser () enumResultsIgnore = ignoreList ["Marker", "Prefix", "MaxResults", "DirectoryId"] -- marker :: XB.Parser (Maybe Text) -- marker = optional (TL.toStrict <$> tag "Marker" anystring) entries :: XB.Parser [DirItem] entries = tag "Entries" $ many (file <|> directory) file :: XB.Parser DirItem file = tag "File" $ do fid <- fileId fname <- fileName properties entryFooter pure $ DIFile fid fname directory :: XB.Parser DirItem directory = tag "Directory" $ do fid <- fileId fname <- fileName properties entryFooter pure $ DIDirectory fid fname entryFooter :: XB.Parser () entryFooter = ignoreList ["Attributes", "PermissionKey"] fileId :: XB.Parser Text fileId = TL.toStrict <$> tag "FileId" anystring fileName :: XB.Parser Text fileName = TL.toStrict <$> tag "Name" anystring properties :: XB.Parser () properties = tag "Properties" $ ignoreList ["Content-Length", "CreationTime", "LastAccessTime", "LastWriteTime", "ChangeTime", "Last-Modified", "Etag"] ignoreList :: [Text] -> XB.Parser () ignoreList ns = void $ many (asum (map (`XB.pElement` XB.pText) ns)) nextMarker :: XB.Parser (Maybe Text) nextMarker = optional (TL.toStrict <$> tag "NextMarker" anystring) -- selfClosing :: Text -> XB.Parser () -- selfClosing t = tag t (pure ()) anystring :: XB.Parser TL.Text anystring = XB.pText tag :: Text -> XB.Parser a -> XB.Parser a tag = XB.pElement parseXML :: XB.Parser b -> BS.ByteString -> Either String b parseXML p bs = XB.fromRawXml bs >>= XB.runParser p -- -- t0, t1, tdir, tfile, tentries :: String -- t0, t1, t1', tfile :: BS.ByteString -- t0 = "datetimedatetimedatetimedatetimedatetimeetag" -- t1' = " string-value string-value int-value directory-id file-id file-name size-in-bytes datetime datetime datetime datetime datetime etag Archive|Hidden|Offline|ReadOnly 4066528134148476695*1 file-id directory-name datetime datetime datetime datetime datetime etag Archive|Hidden|Offline|ReadOnly 4066528134148476695*1 " -- t1 = "string-valuestring-valueint-valuedirectory-idfile-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" -- -- tdir = "file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" -- tfile = "file-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1" -- -- tentries = "file-idfile-namesize-in-bytesdatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1file-iddirectory-namedatetimedatetimedatetimedatetimedatetimeetagArchive|Hidden|Offline|ReadOnly4066528134148476695*1"