module MSAzureAPI.StorageServices.FileService (
getFile
, listDirectoriesAndFiles
, listDirectoriesAndFilesC
, DirItems(..)
, DirItem(..)
, 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)
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.Conduit as C (ConduitT, yield, runConduitRes)
import Data.Conduit ((.|))
import Network.OAuth.OAuth2.Internal (AccessToken(..))
import Network.HTTP.Req (HttpException, runReq, HttpConfig, defaultHttpConfig, Req, Url, Option, Scheme(..), header, (=:))
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict)
import Data.Time (UTCTime, getCurrentTime)
import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale)
import Data.Time.LocalTime (getZonedTime)
import qualified Xeno.DOM.Robust as X (Node, Content(..), name, contents, children)
import qualified Xmlbf.Xeno as XB (fromRawXml)
import qualified Xmlbf as XB (Parser, runParser, pElement, pText)
import MSAzureAPI.Internal.Common (run, APIPlane(..), (==:), get, getBs, post, getLbs, tryReq)
xMsVerHeader :: Option 'Https
= forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"x-ms-version" ByteString
"2022-11-02"
xMsDateHeader :: MonadIO m => m (Option 'Https)
= 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)
msStorageReqHeaders :: MonadIO m => m (Option 'Https)
= 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)
getFile :: Text
-> Text
-> Text
-> 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]
listDirectoriesAndFiles :: Text
-> Text
-> Text
-> Maybe Text
-> 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
listDirectoriesAndFilesC :: (MonadIO m, MonadThrow m) =>
Text
-> Text
-> Text
-> 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
data DirItem = DIFile {DirItem -> Text
diId :: Text, DirItem -> Text
diName :: Text}
| DIDirectory {diId :: Text, diName :: Text}
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)
data DirItems = DirItems {
DirItems -> [DirItem]
disItems :: [DirItem]
, DirItems -> Maybe Text
disResponseMarker :: Maybe Text
}
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"]
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 ()
= [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)
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