--
-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
--

module Network.Minio.Utils where

import qualified Conduit as C
import Control.Monad.IO.Unlift (MonadUnliftIO)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.CaseInsensitive (mk, original)
import qualified Data.Conduit.Binary as CB
import qualified Data.HashMap.Strict as H
import qualified Data.List as List
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Data.Time
  ( defaultTimeLocale,
    parseTimeM,
    rfc822DateFormat,
  )
import Lib.Prelude
import Network.HTTP.Conduit (Response)
import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT
import qualified Network.HTTP.Types.Header as Hdr
import Network.Minio.Data
import Network.Minio.Data.ByteString
import Network.Minio.JsonParser (parseErrResponseJSON)
import Network.Minio.XmlParser (parseErrResponse)
import qualified System.IO as IO
import qualified UnliftIO as U
import qualified UnliftIO.Async as A
import qualified UnliftIO.MVar as UM

allocateReadFile ::
  (MonadUnliftIO m, R.MonadResource m) =>
  FilePath ->
  m (R.ReleaseKey, Handle)
allocateReadFile :: FilePath -> m (ReleaseKey, Handle)
allocateReadFile FilePath
fp = do
  (ReleaseKey
rk, Either IOException Handle
hdlE) <- IO (Either IOException Handle)
-> (Either IOException Handle -> IO ())
-> m (ReleaseKey, Either IOException Handle)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
R.allocate (FilePath -> IO (Either IOException Handle)
forall e. Exception e => FilePath -> IO (Either e Handle)
openReadFile FilePath
fp) Either IOException Handle -> IO ()
forall b. Either b Handle -> IO ()
cleanup
  (IOException -> m (ReleaseKey, Handle))
-> (Handle -> m (ReleaseKey, Handle))
-> Either IOException Handle
-> m (ReleaseKey, Handle)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(IOException
e :: U.IOException) -> IOException -> m (ReleaseKey, Handle)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e) ((ReleaseKey, Handle) -> m (ReleaseKey, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ReleaseKey, Handle) -> m (ReleaseKey, Handle))
-> (Handle -> (ReleaseKey, Handle))
-> Handle
-> m (ReleaseKey, Handle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey
rk,)) Either IOException Handle
hdlE
  where
    openReadFile :: FilePath -> IO (Either e Handle)
openReadFile FilePath
f = IO Handle -> IO (Either e Handle)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
U.try (IO Handle -> IO (Either e Handle))
-> IO Handle -> IO (Either e Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
f IOMode
IO.ReadMode
    cleanup :: Either b Handle -> IO ()
cleanup = (b -> IO ()) -> (Handle -> IO ()) -> Either b Handle -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO () -> b -> IO ()
forall a b. a -> b -> a
const (IO () -> b -> IO ()) -> IO () -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Handle -> IO ()
IO.hClose

-- | Queries the file size from the handle. Catches any file operation
-- exceptions and returns Nothing instead.
getFileSize ::
  (MonadUnliftIO m) =>
  Handle ->
  m (Maybe Int64)
getFileSize :: Handle -> m (Maybe Int64)
getFileSize Handle
h = do
  Either IOException Int64
resE <- IO (Either IOException Int64) -> m (Either IOException Int64)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Int64) -> m (Either IOException Int64))
-> IO (Either IOException Int64) -> m (Either IOException Int64)
forall a b. (a -> b) -> a -> b
$ IO Int64 -> IO (Either IOException Int64)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO Int64 -> IO (Either IOException Int64))
-> IO Int64 -> IO (Either IOException Int64)
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> IO Integer -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
IO.hFileSize Handle
h
  case Either IOException Int64
resE of
    Left (IOException
_ :: U.IOException) -> Maybe Int64 -> m (Maybe Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int64
forall a. Maybe a
Nothing
    Right Int64
s -> Maybe Int64 -> m (Maybe Int64)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int64 -> m (Maybe Int64)) -> Maybe Int64 -> m (Maybe Int64)
forall a b. (a -> b) -> a -> b
$ Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
s

-- | Queries if handle is seekable. Catches any file operation
-- exceptions and return False instead.
isHandleSeekable ::
  (R.MonadResource m) =>
  Handle ->
  m Bool
isHandleSeekable :: Handle -> m Bool
isHandleSeekable Handle
h = do
  Either IOException Bool
resE <- IO (Either IOException Bool) -> m (Either IOException Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Bool) -> m (Either IOException Bool))
-> IO (Either IOException Bool) -> m (Either IOException Bool)
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO (Either IOException Bool)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO Bool -> IO (Either IOException Bool))
-> IO Bool -> IO (Either IOException Bool)
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
IO.hIsSeekable Handle
h
  case Either IOException Bool
resE of
    Left (IOException
_ :: U.IOException) -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Right Bool
v -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
v

-- | Helper function that opens a handle to the filepath and performs
-- the given action on it. Exceptions of type MError are caught and
-- returned - both during file handle allocation and when the action
-- is run.
withNewHandle ::
  (MonadUnliftIO m, R.MonadResource m) =>
  FilePath ->
  (Handle -> m a) ->
  m (Either U.IOException a)
withNewHandle :: FilePath -> (Handle -> m a) -> m (Either IOException a)
withNewHandle FilePath
fp Handle -> m a
fileAction = do
  -- opening a handle can throw MError exception.
  Either IOException (ReleaseKey, Handle)
handleE <- m (ReleaseKey, Handle)
-> m (Either IOException (ReleaseKey, Handle))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (m (ReleaseKey, Handle)
 -> m (Either IOException (ReleaseKey, Handle)))
-> m (ReleaseKey, Handle)
-> m (Either IOException (ReleaseKey, Handle))
forall a b. (a -> b) -> a -> b
$ FilePath -> m (ReleaseKey, Handle)
forall (m :: * -> *).
(MonadUnliftIO m, MonadResource m) =>
FilePath -> m (ReleaseKey, Handle)
allocateReadFile FilePath
fp
  (IOException -> m (Either IOException a))
-> ((ReleaseKey, Handle) -> m (Either IOException a))
-> Either IOException (ReleaseKey, Handle)
-> m (Either IOException a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either IOException a -> m (Either IOException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException a -> m (Either IOException a))
-> (IOException -> Either IOException a)
-> IOException
-> m (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Either IOException a
forall a b. a -> Either a b
Left) (ReleaseKey, Handle) -> m (Either IOException a)
doAction Either IOException (ReleaseKey, Handle)
handleE
  where
    doAction :: (ReleaseKey, Handle) -> m (Either IOException a)
doAction (ReleaseKey
rkey, Handle
h) = do
      -- fileAction may also throw MError exception, so we catch and
      -- return it.
      Either IOException a
resE <- m a -> m (Either IOException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either IOException a))
-> m a -> m (Either IOException a)
forall a b. (a -> b) -> a -> b
$ Handle -> m a
fileAction Handle
h
      ReleaseKey -> m ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
R.release ReleaseKey
rkey
      Either IOException a -> m (Either IOException a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either IOException a
resE

mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]
mkHeaderFromPairs :: [(ByteString, ByteString)] -> [Header]
mkHeaderFromPairs = ((ByteString, ByteString) -> Header)
-> [(ByteString, ByteString)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> CI ByteString) -> (ByteString, ByteString) -> Header
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk)

lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
lookupHeader :: CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
hdr = [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> ([Header] -> [ByteString]) -> [Header] -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> ByteString) -> [Header] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Header -> ByteString
forall a b. (a, b) -> b
snd ([Header] -> [ByteString])
-> ([Header] -> [Header]) -> [Header] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(CI ByteString
h, ByteString
_) -> CI ByteString
h CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
hdr)

getETagHeader :: [HT.Header] -> Maybe Text
getETagHeader :: [Header] -> Maybe Text
getETagHeader [Header]
hs = ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
Hdr.hETag [Header]
hs

getMetadata :: [HT.Header] -> [(Text, Text)]
getMetadata :: [Header] -> [(Text, Text)]
getMetadata =
  (Header -> (Text, Text)) -> [Header] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(CI ByteString
x, ByteString
y) -> (ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
x, ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripBS ByteString
y))

toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader (Text
k, Text
v) =
  (,Text
v) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text
userMetadataHeaderNameMaybe Text
k

getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
getNonUserMetadataMap :: [(Text, Text)] -> HashMap Text Text
getNonUserMetadataMap =
  [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
    ([(Text, Text)] -> HashMap Text Text)
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> HashMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter
      ( Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing
          (Maybe Text -> Bool)
-> ((Text, Text) -> Maybe Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
userMetadataHeaderNameMaybe
          (Text -> Maybe Text)
-> ((Text, Text) -> Text) -> (Text, Text) -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst
      )

-- | This function collects all headers starting with `x-amz-meta-`
-- and strips off this prefix, and returns a map.
getUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
getUserMetadataMap :: [(Text, Text)] -> HashMap Text Text
getUserMetadataMap =
  [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
    ([(Text, Text)] -> HashMap Text Text)
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> HashMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Maybe (Text, Text))
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader

getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime
getLastModifiedHeader :: [Header] -> Maybe UTCTime
getLastModifiedHeader [Header]
hs = do
  Text
modTimebs <- ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
Hdr.hLastModified [Header]
hs
  Bool -> TimeLocale -> FilePath -> FilePath -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> FilePath -> FilePath -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale FilePath
rfc822DateFormat (Text -> FilePath
T.unpack Text
modTimebs)

getContentLength :: [HT.Header] -> Maybe Int64
getContentLength :: [Header] -> Maybe Int64
getContentLength [Header]
hs = do
  Text
nbs <- ByteString -> Text
decodeUtf8Lenient (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
Hdr.hContentLength [Header]
hs
  (Int64, Text) -> Int64
forall a b. (a, b) -> a
fst ((Int64, Text) -> Int64) -> Maybe (Int64, Text) -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Maybe (Int64, Text))
-> ((Int64, Text) -> Maybe (Int64, Text))
-> Either FilePath (Int64, Text)
-> Maybe (Int64, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Int64, Text) -> FilePath -> Maybe (Int64, Text)
forall a b. a -> b -> a
const Maybe (Int64, Text)
forall a. Maybe a
Nothing) (Int64, Text) -> Maybe (Int64, Text)
forall a. a -> Maybe a
Just (Reader Int64
forall a. Integral a => Reader a
decimal Text
nbs)

decodeUtf8Lenient :: ByteString -> Text
decodeUtf8Lenient :: ByteString -> Text
decodeUtf8Lenient = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode

isSuccessStatus :: HT.Status -> Bool
isSuccessStatus :: Status -> Bool
isSuccessStatus Status
sts =
  let s :: Int
s = Status -> Int
HT.statusCode Status
sts
   in (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300)

httpLbs ::
  MonadIO m =>
  NC.Request ->
  NC.Manager ->
  m (NC.Response LByteString)
httpLbs :: Request -> Manager -> m (Response LByteString)
httpLbs Request
req Manager
mgr = do
  Either HttpException (Response LByteString)
respE <- IO (Either HttpException (Response LByteString))
-> m (Either HttpException (Response LByteString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (Response LByteString))
 -> m (Either HttpException (Response LByteString)))
-> IO (Either HttpException (Response LByteString))
-> m (Either HttpException (Response LByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response LByteString)
-> IO (Either HttpException (Response LByteString))
tryHttpEx (IO (Response LByteString)
 -> IO (Either HttpException (Response LByteString)))
-> IO (Response LByteString)
-> IO (Either HttpException (Response LByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response LByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response LByteString)
NC.httpLbs Request
req Manager
mgr
  Response LByteString
resp <- (HttpException -> m (Response LByteString))
-> (Response LByteString -> m (Response LByteString))
-> Either HttpException (Response LByteString)
-> m (Response LByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HttpException -> m (Response LByteString)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Response LByteString -> m (Response LByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException (Response LByteString)
respE
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
isSuccessStatus (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response LByteString -> Status
forall body. Response body -> Status
NC.responseStatus Response LByteString
resp) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    case Response LByteString -> Maybe ByteString
forall body. Response body -> Maybe ByteString
contentTypeMay Response LByteString
resp of
      Just ByteString
"application/xml" -> do
        ServiceErr
sErr <- LByteString -> m ServiceErr
forall (m :: * -> *). MonadIO m => LByteString -> m ServiceErr
parseErrResponse (LByteString -> m ServiceErr) -> LByteString -> m ServiceErr
forall a b. (a -> b) -> a -> b
$ Response LByteString -> LByteString
forall body. Response body -> body
NC.responseBody Response LByteString
resp
        ServiceErr -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ServiceErr
sErr
      Just ByteString
"application/json" -> do
        ServiceErr
sErr <- LByteString -> m ServiceErr
forall (m :: * -> *). MonadIO m => LByteString -> m ServiceErr
parseErrResponseJSON (LByteString -> m ServiceErr) -> LByteString -> m ServiceErr
forall a b. (a -> b) -> a -> b
$ Response LByteString -> LByteString
forall body. Response body -> body
NC.responseBody Response LByteString
resp
        ServiceErr -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ServiceErr
sErr
      Maybe ByteString
_ ->
        HttpException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (HttpException -> m ()) -> HttpException -> m ()
forall a b. (a -> b) -> a -> b
$
          Request -> HttpExceptionContent -> HttpException
NC.HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$
            Response () -> ByteString -> HttpExceptionContent
NC.StatusCodeException (Response LByteString -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response LByteString
resp) (Response LByteString -> ByteString
forall a. Show a => a -> ByteString
showBS Response LByteString
resp)

  Response LByteString -> m (Response LByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Response LByteString
resp
  where
    tryHttpEx ::
      IO (NC.Response LByteString) ->
      IO (Either NC.HttpException (NC.Response LByteString))
    tryHttpEx :: IO (Response LByteString)
-> IO (Either HttpException (Response LByteString))
tryHttpEx = IO (Response LByteString)
-> IO (Either HttpException (Response LByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try
    contentTypeMay :: Response body -> Maybe ByteString
contentTypeMay Response body
resp =
      CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
Hdr.hContentType ([Header] -> Maybe ByteString) -> [Header] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
        Response body -> [Header]
forall body. Response body -> [Header]
NC.responseHeaders Response body
resp

http ::
  (MonadUnliftIO m, R.MonadResource m) =>
  NC.Request ->
  NC.Manager ->
  m (Response (C.ConduitT () ByteString m ()))
http :: Request -> Manager -> m (Response (ConduitT () ByteString m ()))
http Request
req Manager
mgr = do
  Either HttpException (Response (ConduitT () ByteString m ()))
respE <- m (Response (ConduitT () ByteString m ()))
-> m (Either
        HttpException (Response (ConduitT () ByteString m ())))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either HttpException a)
tryHttpEx (m (Response (ConduitT () ByteString m ()))
 -> m (Either
         HttpException (Response (ConduitT () ByteString m ()))))
-> m (Response (ConduitT () ByteString m ()))
-> m (Either
        HttpException (Response (ConduitT () ByteString m ())))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) i.
MonadResource m =>
Request -> Manager -> m (Response (ConduitM i ByteString m ()))
NC.http Request
req Manager
mgr
  Response (ConduitT () ByteString m ())
resp <- (HttpException -> m (Response (ConduitT () ByteString m ())))
-> (Response (ConduitT () ByteString m ())
    -> m (Response (ConduitT () ByteString m ())))
-> Either HttpException (Response (ConduitT () ByteString m ()))
-> m (Response (ConduitT () ByteString m ()))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HttpException -> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Response (ConduitT () ByteString m ())
-> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException (Response (ConduitT () ByteString m ()))
respE
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
isSuccessStatus (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response (ConduitT () ByteString m ()) -> Status
forall body. Response body -> Status
NC.responseStatus Response (ConduitT () ByteString m ())
resp) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    case Response (ConduitT () ByteString m ()) -> Maybe ByteString
forall body. Response body -> Maybe ByteString
contentTypeMay Response (ConduitT () ByteString m ())
resp of
      Just ByteString
"application/xml" -> do
        LByteString
respBody <- ConduitT () ByteString m ()
-> ConduitT ByteString Void m LByteString -> m LByteString
forall (m :: * -> *) a r.
Monad m =>
ConduitT () a m () -> ConduitT a Void m r -> m r
C.connect (Response (ConduitT () ByteString m ())
-> ConduitT () ByteString m ()
forall body. Response body -> body
NC.responseBody Response (ConduitT () ByteString m ())
resp) ConduitT ByteString Void m LByteString
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m LByteString
CB.sinkLbs
        ServiceErr
sErr <- LByteString -> m ServiceErr
forall (m :: * -> *). MonadIO m => LByteString -> m ServiceErr
parseErrResponse LByteString
respBody
        ServiceErr -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ServiceErr
sErr
      Maybe ByteString
_ -> do
        ByteString
content <- LByteString -> ByteString
LB.toStrict (LByteString -> ByteString)
-> (Response LByteString -> LByteString)
-> Response LByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response LByteString -> LByteString
forall body. Response body -> body
NC.responseBody (Response LByteString -> ByteString)
-> m (Response LByteString) -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (ConduitT () ByteString m ()) -> m (Response LByteString)
forall (m :: * -> *).
Monad m =>
Response (ConduitM () ByteString m ()) -> m (Response LByteString)
NC.lbsResponse Response (ConduitT () ByteString m ())
resp
        HttpException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (HttpException -> m ()) -> HttpException -> m ()
forall a b. (a -> b) -> a -> b
$
          Request -> HttpExceptionContent -> HttpException
NC.HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$
            Response () -> ByteString -> HttpExceptionContent
NC.StatusCodeException (Response (ConduitT () ByteString m ()) -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response (ConduitT () ByteString m ())
resp) ByteString
content

  Response (ConduitT () ByteString m ())
-> m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Response (ConduitT () ByteString m ())
resp
  where
    tryHttpEx ::
      (MonadUnliftIO m) =>
      m a ->
      m (Either NC.HttpException a)
    tryHttpEx :: m a -> m (Either HttpException a)
tryHttpEx = m a -> m (Either HttpException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try
    contentTypeMay :: Response body -> Maybe ByteString
contentTypeMay Response body
resp =
      CI ByteString -> [Header] -> Maybe ByteString
lookupHeader CI ByteString
Hdr.hContentType ([Header] -> Maybe ByteString) -> [Header] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
        Response body -> [Header]
forall body. Response body -> [Header]
NC.responseHeaders Response body
resp

-- Similar to mapConcurrently but limits the number of threads that
-- can run using a quantity semaphore.
limitedMapConcurrently ::
  MonadUnliftIO m =>
  Int ->
  (t -> m a) ->
  [t] ->
  m [a]
limitedMapConcurrently :: Int -> (t -> m a) -> [t] -> m [a]
limitedMapConcurrently Int
0 t -> m a
_ [t]
_ = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
limitedMapConcurrently Int
count t -> m a
act [t]
args = do
  TVar Int
t' <- Int -> m (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
U.newTVarIO Int
count
  [Async a]
threads <- (t -> m (Async a)) -> [t] -> m [Async a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (m a -> m (Async a)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
A.async (m a -> m (Async a)) -> (t -> m a) -> t -> m (Async a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int -> t -> m a
wThread TVar Int
t') [t]
args
  (Async a -> m a) -> [Async a] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async a -> m a
forall (m :: * -> *) a. MonadIO m => Async a -> m a
A.wait [Async a]
threads
  where
    wThread :: TVar Int -> t -> m a
wThread TVar Int
t t
arg =
      m () -> m () -> m a -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
U.bracket_ (TVar Int -> m ()
forall (m :: * -> *) a. (MonadIO m, Ord a, Num a) => TVar a -> m ()
waitSem TVar Int
t) (TVar Int -> m ()
forall (m :: * -> *) a. (MonadIO m, Num a) => TVar a -> m ()
signalSem TVar Int
t) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ t -> m a
act t
arg
    -- quantity semaphore implementation using TVar
    waitSem :: TVar a -> m ()
waitSem TVar a
t = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
U.atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      a
v <- TVar a -> STM a
forall a. TVar a -> STM a
U.readTVar TVar a
t
      if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0
        then TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
U.writeTVar TVar a
t (a
v a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
        else STM ()
forall a. STM a
U.retrySTM
    signalSem :: TVar a -> m ()
signalSem TVar a
t = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
U.atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      a
v <- TVar a -> STM a
forall a. TVar a -> STM a
U.readTVar TVar a
t
      TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
U.writeTVar TVar a
t (a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)

-- helper function to 'drop' empty optional parameter.
mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)
mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)
mkQuery Text
k Maybe Text
mv = (Text
k,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mv

-- helper function to build query parameters that are optional.
-- don't use it with mandatory query params with empty value.
mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
mkOptionalParams :: [(Text, Maybe Text)] -> Query
mkOptionalParams [(Text, Maybe Text)]
params = [Maybe (Text, Text)] -> Query
forall a. QueryLike a => a -> Query
HT.toQuery ([Maybe (Text, Text)] -> Query) -> [Maybe (Text, Text)] -> Query
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Text -> Maybe (Text, Text))
-> (Text, Maybe Text) -> Maybe (Text, Text)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Maybe Text -> Maybe (Text, Text)
mkQuery ((Text, Maybe Text) -> Maybe (Text, Text))
-> [(Text, Maybe Text)] -> [Maybe (Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Maybe Text)]
params

-- | Conduit that rechunks bytestrings into the given chunk
-- lengths. Stops after given chunk lengths are yielded. Stops if
-- there are no more chunks to yield or if a shorter chunk is
-- received. Does not throw any errors.
chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()
chunkBSConduit :: [Int] -> ConduitM ByteString ByteString m ()
chunkBSConduit [] = () -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
chunkBSConduit (Int
s : [Int]
ss) = do
  ByteString
bs <- (LByteString -> ByteString)
-> ConduitT ByteString ByteString m LByteString
-> ConduitT ByteString ByteString m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LByteString -> ByteString
LB.toStrict (ConduitT ByteString ByteString m LByteString
 -> ConduitT ByteString ByteString m ByteString)
-> ConduitT ByteString ByteString m LByteString
-> ConduitT ByteString ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ Index ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
C.takeCE Int
Index ByteString
s ConduitM ByteString ByteString m ()
-> ConduitT ByteString ByteString m LByteString
-> ConduitT ByteString ByteString m LByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
C..| ConduitT ByteString ByteString m LByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
C.sinkLazy
  if
      | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s -> ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
bs ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
-> ConduitM ByteString ByteString m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Int] -> ConduitM ByteString ByteString m ()
forall (m :: * -> *).
Monad m =>
[Int] -> ConduitM ByteString ByteString m ()
chunkBSConduit [Int]
ss
      | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> ByteString -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
bs
      | Bool
otherwise -> () -> ConduitM ByteString ByteString m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Select part sizes - the logic is that the minimum part-size will
-- be 64MiB.
selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
selectPartSizes Int64
size =
  ([Int64] -> [Int64] -> [(PartNumber, Int64, Int64)])
-> ([Int64], [Int64]) -> [(PartNumber, Int64, Int64)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([PartNumber] -> [Int64] -> [Int64] -> [(PartNumber, Int64, Int64)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
List.zip3 [PartNumber
1 ..]) (([Int64], [Int64]) -> [(PartNumber, Int64, Int64)])
-> ([Int64], [Int64]) -> [(PartNumber, Int64, Int64)]
forall a b. (a -> b) -> a -> b
$
    [(Int64, Int64)] -> ([Int64], [Int64])
forall a b. [(a, b)] -> ([a], [b])
List.unzip ([(Int64, Int64)] -> ([Int64], [Int64]))
-> [(Int64, Int64)] -> ([Int64], [Int64])
forall a b. (a -> b) -> a -> b
$
      Int64 -> Int64 -> [(Int64, Int64)]
loop Int64
0 Int64
size
  where
    ceil :: Double -> Int64
    ceil :: Double -> Int64
ceil = Double -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
ceiling
    partSize :: Int64
partSize =
      Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max
        Int64
minPartSize
        ( Double -> Int64
ceil (Double -> Int64) -> Double -> Int64
forall a b. (a -> b) -> a -> b
$
            Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
size
              Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
maxMultipartParts
        )
    m :: Int64
m = Int64
partSize
    loop :: Int64 -> Int64 -> [(Int64, Int64)]
loop Int64
st Int64
sz
      | Int64
st Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
sz = []
      | Int64
st Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
m Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
sz = [(Int64
st, Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
st)]
      | Bool
otherwise = (Int64
st, Int64
m) (Int64, Int64) -> [(Int64, Int64)] -> [(Int64, Int64)]
forall a. a -> [a] -> [a]
: Int64 -> Int64 -> [(Int64, Int64)]
loop (Int64
st Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
m) Int64
sz

lookupRegionCache :: Bucket -> Minio (Maybe Region)
lookupRegionCache :: Text -> Minio (Maybe Text)
lookupRegionCache Text
b = do
  MVar (HashMap Text Text)
rMVar <- (MinioConn -> MVar (HashMap Text Text))
-> Minio (MVar (HashMap Text Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> MVar (HashMap Text Text)
mcRegionMap
  HashMap Text Text
rMap <- MVar (HashMap Text Text) -> Minio (HashMap Text Text)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
UM.readMVar MVar (HashMap Text Text)
rMVar
  Maybe Text -> Minio (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Minio (Maybe Text))
-> Maybe Text -> Minio (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
b HashMap Text Text
rMap

addToRegionCache :: Bucket -> Region -> Minio ()
addToRegionCache :: Text -> Text -> Minio ()
addToRegionCache Text
b Text
region = do
  MVar (HashMap Text Text)
rMVar <- (MinioConn -> MVar (HashMap Text Text))
-> Minio (MVar (HashMap Text Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> MVar (HashMap Text Text)
mcRegionMap
  MVar (HashMap Text Text)
-> (HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
UM.modifyMVar_ MVar (HashMap Text Text)
rMVar ((HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ())
-> (HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ()
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> Minio (HashMap Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Text Text -> Minio (HashMap Text Text))
-> (HashMap Text Text -> HashMap Text Text)
-> HashMap Text Text
-> Minio (HashMap Text Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
b Text
region

deleteFromRegionCache :: Bucket -> Minio ()
deleteFromRegionCache :: Text -> Minio ()
deleteFromRegionCache Text
b = do
  MVar (HashMap Text Text)
rMVar <- (MinioConn -> MVar (HashMap Text Text))
-> Minio (MVar (HashMap Text Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MinioConn -> MVar (HashMap Text Text)
mcRegionMap
  MVar (HashMap Text Text)
-> (HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
UM.modifyMVar_ MVar (HashMap Text Text)
rMVar ((HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ())
-> (HashMap Text Text -> Minio (HashMap Text Text)) -> Minio ()
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> Minio (HashMap Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Text Text -> Minio (HashMap Text Text))
-> (HashMap Text Text -> HashMap Text Text)
-> HashMap Text Text
-> Minio (HashMap Text Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HashMap Text Text -> HashMap Text Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
b