-- | 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(..)
  -- * Common types
  , FSException(..)
  ) where

import Control.Applicative (Alternative(..), optional)
import Control.Exception (Exception(..))
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Foldable (asum)
import Data.Functor (void)
import Data.Maybe (listToMaybe, isJust)
import Data.Typeable (Typeable)
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, 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)
-- 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 (run, 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 :: Option 'Https
xMsVerHeader = forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"x-ms-version" ByteString
"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 :: forall (m :: * -> *). MonadIO m => m (Option 'Https)
xMsDateHeader = do
  ZonedTime
zt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
  let
    zth :: String
zth = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %H:%M:%S %Z" ZonedTime
zt
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"x-ms-date" (String -> ByteString
BS8.pack String
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 :: forall (m :: * -> *). MonadIO m => m (Option 'Https)
msStorageReqHeaders = do
  Option 'Https
dh <- forall (m :: * -> *). MonadIO m => m (Option 'Https)
xMsDateHeader
  let
    vh :: Option 'Https
vh = Option 'Https
xMsVerHeader
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Option 'Https
dh forall a. Semigroup a => a -> a -> a
<> Option 'Https
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 :: Text -> Text -> Text -> AccessToken -> Req ByteString
getFile Text
acct Text
fshare Text
fpath AccessToken
atok = do
  Option 'Https
os <- forall (m :: * -> *). MonadIO m => m (Option 'Https)
msStorageReqHeaders
  APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getLbs (Text -> APIPlane
APData Text
domain) [Text]
pth Option 'Https
os AccessToken
atok
  where
    domain :: Text
domain = Text
acct forall a. Semigroup a => a -> a -> a
<> Text
".file.core.windows.net"
    pth :: [Text]
pth = [Text
fshare, Text
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 @<NextMarker> 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 :: Text
-> Text
-> Text
-> Maybe Text
-> AccessToken
-> Req (Either String DirItems)
listDirectoriesAndFiles Text
acct Text
fshare Text
fpath Maybe Text
mm AccessToken
atok = do
  Option 'Https
os <- forall (m :: * -> *). MonadIO m => m (Option 'Https)
msStorageReqHeaders
  ByteString
bs <- APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getBs (Text -> APIPlane
APData Text
domain) [Text]
pth (Option 'Https
os forall a. Semigroup a => a -> a -> a
<> Text
"restype" Text -> Text -> Option 'Https
==: Text
"directory" forall a. Semigroup a => a -> a -> a
<> Text
"comp" Text -> Text -> Option 'Https
==: Text
"list" forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Option 'Https
mMarker Maybe Text
mm) AccessToken
atok
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. Parser b -> ByteString -> Either String b
parseXML Parser DirItems
listDirectoriesP ByteString
bs
  where
    domain :: Text
domain = Text
acct forall a. Semigroup a => a -> a -> a
<> Text
".file.core.windows.net"
    pth :: [Text]
pth = [Text
fshare, Text
fpath]
    mMarker :: Maybe Text -> Option 'Https
mMarker = \case
      Just Text
m -> (Text
"marker" Text -> Text -> Option 'Https
==: Text
m)
      Maybe Text
_ -> forall a. Monoid a => a
mempty

-- | Repeated call of 'listDirectoriesAndFiles' supporting multi-page results
--
-- throws 'FSException' if something goes wrong
listDirectoriesAndFilesC :: (MonadIO m, MonadThrow m) =>
                            Text -- ^ storage account
                         -> Text -- ^ file share
                         -> Text -- ^ directory path, including directories
                         -> HttpConfig
                         -> AccessToken
                         -> C.ConduitT i [DirItem] m ()
listDirectoriesAndFilesC :: forall (m :: * -> *) i.
(MonadIO m, MonadThrow m) =>
Text
-> Text
-> Text
-> HttpConfig
-> AccessToken
-> ConduitT i [DirItem] m ()
listDirectoriesAndFilesC Text
acct Text
fshare Text
fpath HttpConfig
hc AccessToken
atok = forall {m :: * -> *} {i}.
(MonadIO m, MonadThrow m) =>
Maybe Text -> ConduitT i [DirItem] m ()
go forall a. Maybe a
Nothing
  where
    go :: Maybe Text -> ConduitT i [DirItem] m ()
go Maybe Text
mm = do
      Either HttpException (Either String DirItems)
eres <- forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> Req a -> m (Either HttpException a)
run HttpConfig
hc forall a b. (a -> b) -> a -> b
$ Text
-> Text
-> Text
-> Maybe Text
-> AccessToken
-> Req (Either String DirItems)
listDirectoriesAndFiles Text
acct Text
fshare Text
fpath Maybe Text
mm AccessToken
atok
      case Either HttpException (Either String DirItems)
eres of
        Left HttpException
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ HttpException -> FSException
FSHttpE HttpException
e
        Right Either String DirItems
xe -> case Either String DirItems
xe of
          Left String
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> FSException
FSXMLParsingE String
e
          Right (DirItems [DirItem]
xs Maybe Text
nMarker) -> do
            forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield [DirItem]
xs
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Text
nMarker) (Maybe Text -> ConduitT i [DirItem] m ()
go Maybe Text
nMarker)

data FSException = FSXMLParsingE String
                 | FSHttpE HttpException deriving (Typeable)
instance Show FSException where
  show :: FSException -> String
show = \case
    FSXMLParsingE String
es -> [String] -> String
unwords [String
"XML parsing error:", String
es]
    FSHttpE HttpException
e -> [String] -> String
unwords [String
"HTTP exception:", forall a. Show a => a -> String
show HttpException
e]
instance Exception FSException

-- | Directory item, as returned by 'listDirectoriesAndFiles'
data DirItem = DIFile {DirItem -> Text
diId :: Text, DirItem -> Text
diName :: Text} -- ^ file
             | DIDirectory {diId :: Text, diName :: Text} -- ^ directory
             deriving (Int -> DirItem -> ShowS
[DirItem] -> ShowS
DirItem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DirItem] -> ShowS
$cshowList :: [DirItem] -> ShowS
show :: DirItem -> String
$cshow :: DirItem -> String
showsPrec :: Int -> DirItem -> ShowS
$cshowsPrec :: Int -> DirItem -> ShowS
Show)

-- | Items in the 'listDirectoriesAndFiles' response
data DirItems = DirItems {
  DirItems -> [DirItem]
disItems :: [DirItem]
  , DirItems -> Maybe Text
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 :: Parser DirItems
listDirectoriesP = do
  forall a. Text -> Parser a -> Parser a
tag Text
"EnumerationResults" forall a b. (a -> b) -> a -> b
$ do
    Parser ()
enumResultsIgnore
    [DirItem]
es <- Parser [DirItem]
entries
    Maybe Text
nm <- Parser (Maybe Text)
nextMarker
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DirItem] -> Maybe Text -> DirItems
DirItems [DirItem]
es Maybe Text
nm)

enumResultsIgnore :: XB.Parser ()
enumResultsIgnore :: Parser ()
enumResultsIgnore = [Text] -> Parser ()
ignoreList [Text
"Marker", Text
"Prefix", Text
"MaxResults", Text
"DirectoryId"] 

-- marker :: XB.Parser (Maybe Text)
-- marker = optional (TL.toStrict <$> tag "Marker" anystring)

entries :: XB.Parser [DirItem]
entries :: Parser [DirItem]
entries = forall a. Text -> Parser a -> Parser a
tag Text
"Entries" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser DirItem
file forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser DirItem
directory)

file :: XB.Parser DirItem
file :: Parser DirItem
file = forall a. Text -> Parser a -> Parser a
tag Text
"File" forall a b. (a -> b) -> a -> b
$ do
  Text
fid <- Parser Text
fileId
  Text
fname <- Parser Text
fileName
  Parser ()
properties
  Parser ()
entryFooter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> DirItem
DIFile Text
fid Text
fname

directory :: XB.Parser DirItem
directory :: Parser DirItem
directory = forall a. Text -> Parser a -> Parser a
tag Text
"Directory" forall a b. (a -> b) -> a -> b
$ do
  Text
fid <- Parser Text
fileId
  Text
fname <- Parser Text
fileName
  Parser ()
properties
  Parser ()
entryFooter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> DirItem
DIDirectory Text
fid Text
fname



entryFooter :: XB.Parser ()
entryFooter :: Parser ()
entryFooter = [Text] -> Parser ()
ignoreList [Text
"Attributes", Text
"PermissionKey"]

fileId :: XB.Parser Text
fileId :: Parser Text
fileId = Text -> Text
TL.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
tag Text
"FileId" Parser Text
anystring

fileName :: XB.Parser Text
fileName :: Parser Text
fileName = Text -> Text
TL.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
tag Text
"Name" Parser Text
anystring

properties :: XB.Parser ()
properties :: Parser ()
properties = forall a. Text -> Parser a -> Parser a
tag Text
"Properties" forall a b. (a -> b) -> a -> b
$
  [Text] -> Parser ()
ignoreList [Text
"Content-Length", Text
"CreationTime", Text
"LastAccessTime", Text
"LastWriteTime", Text
"ChangeTime", Text
"Last-Modified", Text
"Etag"]

ignoreList :: [Text] -> XB.Parser ()
ignoreList :: [Text] -> Parser ()
ignoreList [Text]
ns = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Text -> Parser a -> Parser a
`XB.pElement` Parser Text
XB.pText) [Text]
ns))

nextMarker :: XB.Parser (Maybe Text)
nextMarker :: Parser (Maybe Text)
nextMarker = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Text
TL.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> Parser a
tag Text
"NextMarker" Parser Text
anystring)

-- selfClosing :: Text -> XB.Parser ()
-- selfClosing t = tag t (pure ())


anystring :: XB.Parser TL.Text
anystring :: Parser Text
anystring = Parser Text
XB.pText
tag :: Text -> XB.Parser a -> XB.Parser a
tag :: forall a. Text -> Parser a -> Parser a
tag = forall a. Text -> Parser a -> Parser a
XB.pElement

parseXML :: XB.Parser b -> BS.ByteString -> Either String b
parseXML :: forall b. Parser b -> ByteString -> Either String b
parseXML Parser b
p ByteString
bs = ByteString -> Either String [Node]
XB.fromRawXml ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Parser a -> [Node] -> Either String a
XB.runParser Parser b
p



-- -- t0, t1, tdir, tfile, tentries :: String
-- t0, t1, t1', tfile :: BS.ByteString
-- t0 = "<Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties>"

-- t1' = "<?xml version=\"1.0\" encoding=\"utf-8\"?> <EnumerationResults ServiceEndpoint=\"https://myaccount.file.core.windows.net/\" ShareName=\"myshare\" ShareSnapshot=\"date-time\" DirectoryPath=\"directory-path\"> <Marker>string-value</Marker> <Prefix>string-value</Prefix> <MaxResults>int-value</MaxResults> <DirectoryId>directory-id</DirectoryId> <Entries> <File> <FileId>file-id</FileId> <Name>file-name</Name> <Properties> <Content-Length>size-in-bytes</Content-Length> <CreationTime>datetime</CreationTime> <LastAccessTime>datetime</LastAccessTime> <LastWriteTime>datetime</LastWriteTime> <ChangeTime>datetime</ChangeTime> <Last-Modified>datetime</Last-Modified> <Etag>etag</Etag> </Properties> <Attributes>Archive|Hidden|Offline|ReadOnly</Attributes> <PermissionKey>4066528134148476695*1</PermissionKey> </File> <Directory> <FileId>file-id</FileId> <Name>directory-name</Name> <Properties> <CreationTime>datetime</CreationTime> <LastAccessTime>datetime</LastAccessTime> <LastWriteTime>datetime</LastWriteTime> <ChangeTime>datetime</ChangeTime> <Last-Modified>datetime</Last-Modified> <Etag>etag</Etag> </Properties> <Attributes>Archive|Hidden|Offline|ReadOnly</Attributes> <PermissionKey>4066528134148476695*1</PermissionKey> </Directory> </Entries> <NextMarker /> </EnumerationResults>"

-- t1 = "<?xml version=\"1.0\" encoding=\"utf-8\"?><EnumerationResults ServiceEndpoint=\"https://myaccount.file.core.windows.net/\" ShareName=\"myshare\" ShareSnapshot=\"date-time\" DirectoryPath=\"directory-path\"><Marker>string-value</Marker><Prefix>string-value</Prefix><MaxResults>int-value</MaxResults><DirectoryId>directory-id</DirectoryId><Entries><File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File><Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory></Entries><NextMarker /></EnumerationResults>"

-- -- tdir = "<Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory>"

-- tfile = "<File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File>"

-- -- tentries = "<Entries><File><FileId>file-id</FileId><Name>file-name</Name><Properties><Content-Length>size-in-bytes</Content-Length><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></File><Directory><FileId>file-id</FileId><Name>directory-name</Name><Properties><CreationTime>datetime</CreationTime><LastAccessTime>datetime</LastAccessTime><LastWriteTime>datetime</LastWriteTime><ChangeTime>datetime</ChangeTime><Last-Modified>datetime</Last-Modified><Etag>etag</Etag></Properties><Attributes>Archive|Hidden|Offline|ReadOnly</Attributes><PermissionKey>4066528134148476695*1</PermissionKey></Directory></Entries>"