--
-- MinIO Haskell SDK, (C) 2017-2023 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.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.ByteString
import Network.Minio.JsonParser (parseErrResponseJSON)
import Network.Minio.XmlCommon (parseErrResponse)
import qualified System.IO as IO
import qualified UnliftIO as U
import qualified UnliftIO.Async as A

allocateReadFile ::
  (MonadUnliftIO m, R.MonadResource m) =>
  FilePath ->
  m (R.ReleaseKey, Handle)
allocateReadFile :: forall (m :: * -> *).
(MonadUnliftIO m, MonadResource m) =>
FilePath -> m (ReleaseKey, Handle)
allocateReadFile FilePath
fp = do
  (ReleaseKey
rk, Either IOException Handle
hdlE) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
R.allocate (forall {e}. Exception e => FilePath -> IO (Either e Handle)
openReadFile FilePath
fp) forall {a}. Either a Handle -> IO ()
cleanup
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(IOException
e :: U.IOException) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e) (forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
U.try forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
f IOMode
IO.ReadMode
    cleanup :: Either a Handle -> IO ()
cleanup = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *). MonadUnliftIO m => Handle -> m (Maybe Int64)
getFileSize Handle
h = do
  Either IOException Int64
resE <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right Int64
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *). MonadResource m => Handle -> m Bool
isHandleSeekable Handle
h = do
  Either IOException Bool
resE <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
IO.hIsSeekable Handle
h
  case Either IOException Bool
resE of
    Left (IOException
_ :: U.IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Right Bool
v -> 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 :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
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 <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadUnliftIO m, MonadResource m) =>
FilePath -> m (ReleaseKey, Handle)
allocateReadFile FilePath
fp
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall {e}. Exception e => (ReleaseKey, Handle) -> m (Either e a)
doAction Either IOException (ReleaseKey, Handle)
handleE
  where
    doAction :: (ReleaseKey, Handle) -> m (Either e a)
doAction (ReleaseKey
rkey, Handle
h) = do
      -- fileAction may also throw MError exception, so we catch and
      -- return it.
      Either e a
resE <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ Handle -> m a
fileAction Handle
h
      forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
R.release ReleaseKey
rkey
      forall (m :: * -> *) a. Monad m => a -> m a
return Either e a
resE

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

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

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

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

-- | If the given header name has the @X-Amz-Meta-@ prefix, it is
-- stripped and a Just is returned.
userMetadataHeaderNameMaybe :: Text -> Maybe Text
userMetadataHeaderNameMaybe :: Text -> Maybe Text
userMetadataHeaderNameMaybe Text
k =
  let prefix :: Text
prefix = Text -> Text
T.toCaseFold Text
"X-Amz-Meta-"
      n :: Int
n = Text -> Int
T.length Text
prefix
   in if Text -> Text
T.toCaseFold (Int -> Text -> Text
T.take Int
n Text
k) forall a. Eq a => a -> a -> Bool
== Text
prefix
        then forall a. a -> Maybe a
Just (Int -> Text -> Text
T.drop Int
n Text
k)
        else forall a. Maybe a
Nothing

toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader (Text
k, Text
v) =
  (,Text
v) 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 =
  forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter
      ( forall a. Maybe a -> Bool
isNothing
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
userMetadataHeaderNameMaybe
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
      )

addXAmzMetaPrefix :: Text -> Text
addXAmzMetaPrefix :: Text -> Text
addXAmzMetaPrefix Text
s
  | forall a. Maybe a -> Bool
isJust (Text -> Maybe Text
userMetadataHeaderNameMaybe Text
s) = Text
s
  | Bool
otherwise = Text
"X-Amz-Meta-" forall a. Semigroup a => a -> a -> a
<> Text
s

mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
mkHeaderFromMetadata :: [(Text, Text)] -> [Header]
mkHeaderFromMetadata = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x, Text
y) -> (forall s. FoldCase s => s -> CI s
mk forall a b. (a -> b) -> a -> b
$ forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> Text
addXAmzMetaPrefix Text
x, forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
y))

-- | 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 =
  forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Text) -> Maybe (Text, Text)
toMaybeMetadataHeader

getHostHeader :: (ByteString, Int) -> ByteString
getHostHeader :: (ByteString, Int) -> ByteString
getHostHeader (ByteString
host_, Int
port_) =
  if Int
port_ forall a. Eq a => a -> a -> Bool
== Int
80 Bool -> Bool -> Bool
|| Int
port_ forall a. Eq a => a -> a -> Bool
== Int
443
    then ByteString
host_
    else ByteString
host_ forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
port_

getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime
getLastModifiedHeader :: [Header] -> Maybe UTCTime
getLastModifiedHeader [Header]
hs = do
  Text
modTimebs <- ByteString -> Text
decodeUtf8Lenient forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
lookupHeader HeaderName
Hdr.hLastModified [Header]
hs
  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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> [Header] -> Maybe ByteString
lookupHeader HeaderName
Hdr.hContentLength [Header]
hs
  forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (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 forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
s forall a. Ord a => a -> a -> Bool
< Int
300)

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

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

  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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either HttpException a)
tryHttpEx = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try
    contentTypeMay :: Response body -> Maybe ByteString
contentTypeMay Response body
resp =
      HeaderName -> [Header] -> Maybe ByteString
lookupHeader HeaderName
Hdr.hContentType forall a b. (a -> b) -> a -> b
$
        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 :: forall (m :: * -> *) t a.
MonadUnliftIO m =>
Int -> (t -> m a) -> [t] -> m [a]
limitedMapConcurrently Int
0 t -> m a
_ [t]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
limitedMapConcurrently Int
count t -> m a
act [t]
args = do
  TVar Int
t' <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
U.newTVarIO Int
count
  [Async a]
threads <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
A.async forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Ord a, Num a) => TVar a -> t -> m a
wThread TVar Int
t') [t]
args
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a. MonadIO m => Async a -> m a
A.wait [Async a]
threads
  where
    wThread :: TVar a -> t -> m a
wThread TVar a
t t
arg =
      forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
U.bracket_ (forall {m :: * -> *} {a}.
(MonadIO m, Ord a, Num a) =>
TVar a -> m ()
waitSem TVar a
t) (forall {m :: * -> *} {a}. (MonadIO m, Num a) => TVar a -> m ()
signalSem TVar a
t) 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 = forall (m :: * -> *) a. MonadIO m => STM a -> m a
U.atomically forall a b. (a -> b) -> a -> b
$ do
      a
v <- forall a. TVar a -> STM a
U.readTVar TVar a
t
      if a
v forall a. Ord a => a -> a -> Bool
> a
0
        then forall a. TVar a -> a -> STM ()
U.writeTVar TVar a
t (a
v forall a. Num a => a -> a -> a
- a
1)
        else forall a. STM a
U.retrySTM
    signalSem :: TVar a -> m ()
signalSem TVar a
t = forall (m :: * -> *) a. MonadIO m => STM a -> m a
U.atomically forall a b. (a -> b) -> a -> b
$ do
      a
v <- forall a. TVar a -> STM a
U.readTVar TVar a
t
      forall a. TVar a -> a -> STM ()
U.writeTVar TVar a
t (a
v 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,) 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 = forall a. QueryLike a => a -> Query
HT.toQuery forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Maybe Text -> Maybe (Text, Text)
mkQuery 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 :: forall (m :: * -> *).
Monad m =>
[Int] -> ConduitM ByteString ByteString m ()
chunkBSConduit [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
chunkBSConduit (Int
s : [Int]
ss) = do
  ByteString
bs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LByteString -> ByteString
LB.toStrict forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
C.takeCE Int
s forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
C..| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
C.sinkLazy
  if
      | ByteString -> Int
B.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int
s -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
Monad m =>
[Int] -> ConduitM ByteString ByteString m ()
chunkBSConduit [Int]
ss
      | ByteString -> Int
B.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
0 -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield ByteString
bs
      | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()