{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE StandaloneDeriving    #-}
module Network.HTTP.Download.Verified
  ( verifiedDownload
  , recoveringHttp
  , drRetryPolicyDefault
  , HashCheck(..)
  , CheckHexDigest(..)
  , LengthCheck
  , VerifiedDownloadException(..)
  -- * DownloadRequest construction
  , DownloadRequest
  , mkDownloadRequest
  , modifyRequest
  , setHashChecks
  , setLengthCheck
  , setRetryPolicy
  , setForceDownload
  ) where

import qualified    Data.List as List
import qualified    Data.ByteString.Base64 as B64
import              Conduit (sinkHandle)
import qualified    Data.Conduit.Binary as CB
import qualified    Data.Conduit.List as CL

import              Control.Monad
import              Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself
import              Control.Retry (recovering,limitRetries,RetryPolicy,exponentialBackoff,RetryStatus(..))
import              Crypto.Hash
import              Crypto.Hash.Conduit (sinkHash)
import              Data.ByteArray as Mem (convert)
import              Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
import              Data.ByteString.Char8 (readInteger)
import              Data.Conduit
import              Data.Conduit.Binary (sourceHandle)
import              Data.Monoid (Sum(..))
import              GHC.IO.Exception (IOException(..),IOErrorType(..))
import              Network.HTTP.Client (Request, HttpException, getUri, path)
import              Network.HTTP.Simple (getResponseHeaders, httpSink)
import              Network.HTTP.Types (hContentLength, hContentMD5)
import              Path
import              RIO hiding (Handler)
import              RIO.PrettyPrint
import qualified    RIO.ByteString as ByteString
import qualified    RIO.Text as Text
import              System.Directory
import qualified    System.FilePath as FP
import              System.IO (openTempFileWithDefaultPermissions)

-- | A request together with some checks to perform.
--
-- Construct using the 'downloadRequest' smart constructor and associated
-- setters. The constructor itself is not exposed to avoid breaking changes
-- with additional fields.
--
-- @since 0.2.0.0
data DownloadRequest = DownloadRequest
    { DownloadRequest -> Request
drRequest :: Request
    , DownloadRequest -> [HashCheck]
drHashChecks :: [HashCheck]
    , DownloadRequest -> Maybe LengthCheck
drLengthCheck :: Maybe LengthCheck
    , DownloadRequest -> forall (m :: * -> *). Monad m => RetryPolicyM m
drRetryPolicy :: RetryPolicy
    , DownloadRequest -> Bool
drForceDownload :: Bool -- ^ whether to redownload or not if file exists
    }

-- | Construct a new 'DownloadRequest' from the given 'Request'. Use associated
-- setters to modify the value further.
--
-- @since 0.2.0.0
mkDownloadRequest :: Request -> DownloadRequest
mkDownloadRequest :: Request -> DownloadRequest
mkDownloadRequest Request
req = Request
-> [HashCheck]
-> Maybe LengthCheck
-> (forall (m :: * -> *). Monad m => RetryPolicyM m)
-> Bool
-> DownloadRequest
DownloadRequest Request
req [] Maybe LengthCheck
forall a. Maybe a
Nothing forall (m :: * -> *). Monad m => RetryPolicyM m
drRetryPolicyDefault Bool
False

-- | Modify the 'Request' inside a 'DownloadRequest'. Especially intended for modifying the @User-Agent@ request header.
--
-- @since 0.2.0.0
modifyRequest :: (Request -> Request) -> DownloadRequest -> DownloadRequest
modifyRequest :: (Request -> Request) -> DownloadRequest -> DownloadRequest
modifyRequest Request -> Request
f DownloadRequest
dr = DownloadRequest
dr { drRequest :: Request
drRequest = Request -> Request
f (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ DownloadRequest -> Request
drRequest DownloadRequest
dr }

-- | Set the hash checks to be run when verifying.
--
-- @since 0.2.0.0
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks [HashCheck]
x DownloadRequest
dr = DownloadRequest
dr { drHashChecks :: [HashCheck]
drHashChecks = [HashCheck]
x }

-- | Set the length check to be run when verifying.
--
-- @since 0.2.0.0
setLengthCheck :: Maybe LengthCheck -> DownloadRequest -> DownloadRequest
setLengthCheck :: Maybe LengthCheck -> DownloadRequest -> DownloadRequest
setLengthCheck Maybe LengthCheck
x DownloadRequest
dr = DownloadRequest
dr { drLengthCheck :: Maybe LengthCheck
drLengthCheck = Maybe LengthCheck
x }

-- | Set the retry policy to be used when downloading.
--
-- @since 0.2.0.0
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy :: (forall (m :: * -> *). Monad m => RetryPolicyM m)
-> DownloadRequest -> DownloadRequest
setRetryPolicy forall (m :: * -> *). Monad m => RetryPolicyM m
x DownloadRequest
dr = DownloadRequest
dr { drRetryPolicy :: forall (m :: * -> *). Monad m => RetryPolicyM m
drRetryPolicy = forall (m :: * -> *). Monad m => RetryPolicyM m
x }

-- | If 'True', force download even if the file already exists. Useful for
-- download a resource which may change over time.
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
x DownloadRequest
dr = DownloadRequest
dr { drForceDownload :: Bool
drForceDownload = Bool
x }

-- | Default to retrying seven times with exponential backoff starting from
-- one hundred milliseconds.
--
-- This means the tries will occur after these delays if necessary:
--
-- * 0.1s
-- * 0.2s
-- * 0.4s
-- * 0.8s
-- * 1.6s
-- * 3.2s
-- * 6.4s
drRetryPolicyDefault :: RetryPolicy
drRetryPolicyDefault :: RetryPolicyM m
drRetryPolicyDefault = LengthCheck -> forall (m :: * -> *). Monad m => RetryPolicyM m
limitRetries LengthCheck
7 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> LengthCheck -> forall (m :: * -> *). Monad m => RetryPolicyM m
exponentialBackoff LengthCheck
onehundredMilliseconds
  where onehundredMilliseconds :: LengthCheck
onehundredMilliseconds = LengthCheck
100000

data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck
  { ()
hashCheckAlgorithm :: a
  , HashCheck -> CheckHexDigest
hashCheckHexDigest :: CheckHexDigest
  }
deriving instance Show HashCheck

data CheckHexDigest
  = CheckHexDigestString String
  | CheckHexDigestByteString ByteString
  | CheckHexDigestHeader ByteString
  deriving LengthCheck -> CheckHexDigest -> ShowS
[CheckHexDigest] -> ShowS
CheckHexDigest -> String
(LengthCheck -> CheckHexDigest -> ShowS)
-> (CheckHexDigest -> String)
-> ([CheckHexDigest] -> ShowS)
-> Show CheckHexDigest
forall a.
(LengthCheck -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckHexDigest] -> ShowS
$cshowList :: [CheckHexDigest] -> ShowS
show :: CheckHexDigest -> String
$cshow :: CheckHexDigest -> String
showsPrec :: LengthCheck -> CheckHexDigest -> ShowS
$cshowsPrec :: LengthCheck -> CheckHexDigest -> ShowS
Show
instance IsString CheckHexDigest where
  fromString :: String -> CheckHexDigest
fromString = String -> CheckHexDigest
CheckHexDigestString

type LengthCheck = Int

-- | An exception regarding verification of a download.
data VerifiedDownloadException
    = WrongContentLength
          Request
          Int -- expected
          ByteString -- actual (as listed in the header)
    | WrongStreamLength
          Request
          Int -- expected
          Int -- actual
    | WrongDigest
          Request
          String -- algorithm
          CheckHexDigest -- expected
          String -- actual (shown)
    | DownloadHttpError
          HttpException
  deriving (Typeable)
instance Show VerifiedDownloadException where
    show :: VerifiedDownloadException -> String
show (WrongContentLength Request
req LengthCheck
expected ByteString
actual) =
        String
"Download expectation failure: ContentLength header\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LengthCheck -> String
forall a. Show a => a -> String
show LengthCheck
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Actual:   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
displayByteString ByteString
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
    show (WrongStreamLength Request
req LengthCheck
expected LengthCheck
actual) =
        String
"Download expectation failure: download size\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LengthCheck -> String
forall a. Show a => a -> String
show LengthCheck
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Actual:   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LengthCheck -> String
forall a. Show a => a -> String
show LengthCheck
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
    show (WrongDigest Request
req String
algo CheckHexDigest
expected String
actual) =
        String
"Download expectation failure: content hash (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
")\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CheckHexDigest -> String
displayCheckHexDigest CheckHexDigest
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Actual:   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
    show (DownloadHttpError HttpException
exception) =
      String
"Download expectation failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpException -> String
forall a. Show a => a -> String
show HttpException
exception

instance Exception VerifiedDownloadException

-- This exception is always caught and never thrown outside of this module.
data VerifyFileException
    = WrongFileSize
          Int -- expected
          Integer -- actual (as listed by hFileSize)
  deriving (LengthCheck -> VerifyFileException -> ShowS
[VerifyFileException] -> ShowS
VerifyFileException -> String
(LengthCheck -> VerifyFileException -> ShowS)
-> (VerifyFileException -> String)
-> ([VerifyFileException] -> ShowS)
-> Show VerifyFileException
forall a.
(LengthCheck -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerifyFileException] -> ShowS
$cshowList :: [VerifyFileException] -> ShowS
show :: VerifyFileException -> String
$cshow :: VerifyFileException -> String
showsPrec :: LengthCheck -> VerifyFileException -> ShowS
$cshowsPrec :: LengthCheck -> VerifyFileException -> ShowS
Show, Typeable)
instance Exception VerifyFileException

-- Show a ByteString that is known to be UTF8 encoded.
displayByteString :: ByteString -> String
displayByteString :: ByteString -> String
displayByteString =
    Text -> String
Text.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8Lenient

-- Show a CheckHexDigest in human-readable format.
displayCheckHexDigest :: CheckHexDigest -> String
displayCheckHexDigest :: CheckHexDigest -> String
displayCheckHexDigest (CheckHexDigestString String
s) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (String)"
displayCheckHexDigest (CheckHexDigestByteString ByteString
s) = ByteString -> String
displayByteString ByteString
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (ByteString)"
displayCheckHexDigest (CheckHexDigestHeader ByteString
h) =
      ByteString -> String
forall a. Show a => a -> String
show (ByteString -> ByteString
B64.decodeLenient ByteString
h) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (Header. unencoded: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"


-- | Make sure that the hash digest for a finite stream of bytes
-- is as expected.
--
-- Throws WrongDigest (VerifiedDownloadException)
sinkCheckHash :: MonadThrow m
    => Request
    -> HashCheck
    -> ConduitM ByteString o m ()
sinkCheckHash :: Request -> HashCheck -> ConduitM ByteString o m ()
sinkCheckHash Request
req HashCheck{a
CheckHexDigest
hashCheckHexDigest :: CheckHexDigest
hashCheckAlgorithm :: a
hashCheckHexDigest :: HashCheck -> CheckHexDigest
hashCheckAlgorithm :: ()
..} = do
    Digest a
digest <- a -> ConduitM ByteString o m (Digest a)
forall (m :: * -> *) a o.
(Monad m, HashAlgorithm a) =>
a -> ConduitM ByteString o m (Digest a)
sinkHashUsing a
hashCheckAlgorithm
    let actualDigestString :: String
actualDigestString = Digest a -> String
forall a. Show a => a -> String
show Digest a
digest
    let actualDigestHexByteString :: ByteString
actualDigestHexByteString = Base -> Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
Mem.convertToBase Base
Mem.Base16 Digest a
digest
    let actualDigestBytes :: ByteString
actualDigestBytes = Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Mem.convert Digest a
digest

    let passedCheck :: Bool
passedCheck = case CheckHexDigest
hashCheckHexDigest of
          CheckHexDigestString String
s -> String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
actualDigestString
          CheckHexDigestByteString ByteString
b -> ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString
          CheckHexDigestHeader ByteString
b -> ByteString -> ByteString
B64.decodeLenient ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString
            Bool -> Bool -> Bool
|| ByteString -> ByteString
B64.decodeLenient ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestBytes
            -- A hack to allow hackage tarballs to download.
            -- They should really base64-encode their md5 header as per rfc2616#sec14.15.
            -- https://github.com/commercialhaskell/stack/issues/240
            Bool -> Bool -> Bool
|| ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString

    Bool -> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
passedCheck (ConduitM ByteString o m () -> ConduitM ByteString o m ())
-> ConduitM ByteString o m () -> ConduitM ByteString o m ()
forall a b. (a -> b) -> a -> b
$
        VerifiedDownloadException -> ConduitM ByteString o m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifiedDownloadException -> ConduitM ByteString o m ())
-> VerifiedDownloadException -> ConduitM ByteString o m ()
forall a b. (a -> b) -> a -> b
$ Request
-> String -> CheckHexDigest -> String -> VerifiedDownloadException
WrongDigest Request
req (a -> String
forall a. Show a => a -> String
show a
hashCheckAlgorithm) CheckHexDigest
hashCheckHexDigest String
actualDigestString

assertLengthSink :: MonadThrow m
    => Request
    -> LengthCheck
    -> ZipSink ByteString m ()
assertLengthSink :: Request -> LengthCheck -> ZipSink ByteString m ()
assertLengthSink Request
req LengthCheck
expectedStreamLength = Sink ByteString m () -> ZipSink ByteString m ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Sink ByteString m () -> ZipSink ByteString m ())
-> Sink ByteString m () -> ZipSink ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
  Sum LengthCheck
actualStreamLength <- (ByteString -> Sum LengthCheck)
-> ConduitT ByteString Void m (Sum LengthCheck)
forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
CL.foldMap (LengthCheck -> Sum LengthCheck
forall a. a -> Sum a
Sum (LengthCheck -> Sum LengthCheck)
-> (ByteString -> LengthCheck) -> ByteString -> Sum LengthCheck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LengthCheck
ByteString.length)
  Bool -> Sink ByteString m () -> Sink ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LengthCheck
actualStreamLength LengthCheck -> LengthCheck -> Bool
forall a. Eq a => a -> a -> Bool
/= LengthCheck
expectedStreamLength) (Sink ByteString m () -> Sink ByteString m ())
-> Sink ByteString m () -> Sink ByteString m ()
forall a b. (a -> b) -> a -> b
$
    VerifiedDownloadException -> Sink ByteString m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifiedDownloadException -> Sink ByteString m ())
-> VerifiedDownloadException -> Sink ByteString m ()
forall a b. (a -> b) -> a -> b
$ Request -> LengthCheck -> LengthCheck -> VerifiedDownloadException
WrongStreamLength Request
req LengthCheck
expectedStreamLength LengthCheck
actualStreamLength

-- | A more explicitly type-guided sinkHash.
sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)
sinkHashUsing :: a -> ConduitM ByteString o m (Digest a)
sinkHashUsing a
_ = ConduitM ByteString o m (Digest a)
forall (m :: * -> *) hash.
(Monad m, HashAlgorithm hash) =>
Consumer ByteString m (Digest hash)
sinkHash

-- | Turns a list of hash checks into a ZipSink that checks all of them.
hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink :: Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink Request
req = (HashCheck -> ZipSink ByteString m ())
-> [HashCheck] -> ZipSink ByteString m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Sink ByteString m () -> ZipSink ByteString m ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Sink ByteString m () -> ZipSink ByteString m ())
-> (HashCheck -> Sink ByteString m ())
-> HashCheck
-> ZipSink ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HashCheck -> Sink ByteString m ()
forall (m :: * -> *) o.
MonadThrow m =>
Request -> HashCheck -> ConduitM ByteString o m ()
sinkCheckHash Request
req)

-- 'Control.Retry.recovering' customized for HTTP failures
recoveringHttp :: forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp :: (forall (m :: * -> *). Monad m => RetryPolicyM m)
-> RIO env a -> RIO env a
recoveringHttp forall (m :: * -> *). Monad m => RetryPolicyM m
retryPolicy =
    (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
helper ((UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a)
-> (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ \UnliftIO (RIO env)
run -> RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO a)
-> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicyM IO
forall (m :: * -> *). Monad m => RetryPolicyM m
retryPolicy (UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]
handlers UnliftIO (RIO env)
run) ((RetryStatus -> IO a) -> IO a)
-> (IO a -> RetryStatus -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> RetryStatus -> IO a
forall a b. a -> b -> a
const
  where
    helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
    helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
helper UnliftIO (RIO env) -> IO a -> IO a
wrapper RIO env a
action = (UnliftIO (RIO env) -> IO a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO (RIO env) -> IO a) -> RIO env a)
-> (UnliftIO (RIO env) -> IO a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \UnliftIO (RIO env)
run -> UnliftIO (RIO env) -> IO a -> IO a
wrapper UnliftIO (RIO env)
run (UnliftIO (RIO env) -> RIO env a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO env)
run RIO env a
action)

    handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]
    handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]
handlers UnliftIO (RIO env)
u = [(HttpException -> IO Bool) -> Handler IO Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((HttpException -> IO Bool) -> Handler IO Bool)
-> (RetryStatus -> HttpException -> IO Bool)
-> RetryStatus
-> Handler IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool
alwaysRetryHttp UnliftIO (RIO env)
u,Handler IO Bool -> RetryStatus -> Handler IO Bool
forall a b. a -> b -> a
const (Handler IO Bool -> RetryStatus -> Handler IO Bool)
-> Handler IO Bool -> RetryStatus -> Handler IO Bool
forall a b. (a -> b) -> a -> b
$ (IOException -> IO Bool) -> Handler IO Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler IOException -> IO Bool
forall (m :: * -> *). Monad m => IOException -> m Bool
retrySomeIO]

    alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool
    alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool
alwaysRetryHttp UnliftIO (RIO env)
u RetryStatus
rs HttpException
_ = do
      UnliftIO (RIO env) -> forall a. RIO env a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO env)
u (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vcat
          [ String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"Retry number"
            , LengthCheck -> String
forall a. Show a => a -> String
show (RetryStatus -> LengthCheck
rsIterNumber RetryStatus
rs)
            , String
"after a total delay of"
            , LengthCheck -> String
forall a. Show a => a -> String
show (RetryStatus -> LengthCheck
rsCumulativeDelay RetryStatus
rs)
            , String
"us"
            ]
          , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"If you see this warning and stack fails to download,"
            , String
"but running the command again solves the problem,"
            , String
"please report here: https://github.com/commercialhaskell/stack/issues/3510"
            , String
"Make sure to paste the output of 'stack --version'"
            ]
          ]
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    retrySomeIO :: Monad m => IOException -> m Bool
    retrySomeIO :: IOException -> m Bool
retrySomeIO IOException
e = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case IOException -> IOErrorType
ioe_type IOException
e of
                               -- hGetBuf: resource vanished (Connection reset by peer)
                               IOErrorType
ResourceVanished -> Bool
True
                               -- conservatively exclude all others
                               IOErrorType
_ -> Bool
False

-- | Copied and extended version of Network.HTTP.Download.download.
--
-- Has the following additional features:
-- * Verifies that response content-length header (if present)
--     matches expected length
-- * Limits the download to (close to) the expected # of bytes
-- * Verifies that the expected # bytes were downloaded (not too few)
-- * Verifies md5 if response includes content-md5 header
-- * Verifies the expected hashes
--
-- Throws VerifiedDownloadException.
-- Throws IOExceptions related to file system operations.
-- Throws HttpException.
verifiedDownload
         :: HasTerm env
         => DownloadRequest
         -> Path Abs File -- ^ destination
         -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress
         -> RIO env Bool -- ^ Whether a download was performed
verifiedDownload :: DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload DownloadRequest{Bool
[HashCheck]
Maybe LengthCheck
Request
forall (m :: * -> *). Monad m => RetryPolicyM m
drForceDownload :: Bool
drRetryPolicy :: forall (m :: * -> *). Monad m => RetryPolicyM m
drLengthCheck :: Maybe LengthCheck
drHashChecks :: [HashCheck]
drRequest :: Request
drForceDownload :: DownloadRequest -> Bool
drRetryPolicy :: DownloadRequest -> forall (m :: * -> *). Monad m => RetryPolicyM m
drLengthCheck :: DownloadRequest -> Maybe LengthCheck
drHashChecks :: DownloadRequest -> [HashCheck]
drRequest :: DownloadRequest -> Request
..} Path Abs File
destpath Maybe Integer -> ConduitM ByteString Void (RIO env) ()
progressSink = do
    let req :: Request
req = Request
drRequest
    RIO env Bool -> RIO env () -> RIO env Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m Bool
whenM' (IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
getShouldDownload) (RIO env () -> RIO env Bool) -> RIO env () -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ByteString
path Request
req))
        IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
        String -> String -> (String -> Handle -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions String
dir (ShowS
FP.takeFileName String
fp) ((String -> Handle -> RIO env ()) -> RIO env ())
-> (String -> Handle -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \String
fptmp Handle
htmp -> do
            (forall (m :: * -> *). Monad m => RetryPolicyM m)
-> RIO env () -> RIO env ()
forall env a.
HasTerm env =>
(forall (m :: * -> *). Monad m => RetryPolicyM m)
-> RIO env a -> RIO env a
recoveringHttp forall (m :: * -> *). Monad m => RetryPolicyM m
drRetryPolicy (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RIO env () -> RIO env ()
forall env a. RIO env a -> RIO env a
catchingHttpExceptions (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                Request
-> (Response () -> ConduitM ByteString Void (RIO env) ())
-> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
httpSink Request
req ((Response () -> ConduitM ByteString Void (RIO env) ())
 -> RIO env ())
-> (Response () -> ConduitM ByteString Void (RIO env) ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ ConduitM ByteString Void (RIO env) ()
-> Response () -> ConduitM ByteString Void (RIO env) ()
go (Handle -> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
htmp)
            Handle -> RIO env ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
htmp
            IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
fptmp String
fp
  where
    whenM' :: m Bool -> m a -> m Bool
whenM' m Bool
mp m a
m = do
        Bool
p <- m Bool
mp
        if Bool
p then m a
m m a -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    fp :: String
fp = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
destpath
    dir :: String
dir = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath (Path Abs Dir -> String) -> Path Abs Dir -> String
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
destpath

    getShouldDownload :: IO Bool
getShouldDownload = if Bool
drForceDownload then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
        Bool
fileExists <- String -> IO Bool
doesFileExist String
fp
        if Bool
fileExists
            -- only download if file does not match expectations
            then Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
fileMatchesExpectations
            -- or if it doesn't exist yet
            else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

    -- precondition: file exists
    -- TODO: add logging
    fileMatchesExpectations :: IO Bool
fileMatchesExpectations =
        ((IO ()
checkExpectations IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
          IO Bool -> (VerifyFileException -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(VerifyFileException
_ :: VerifyFileException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          IO Bool -> (VerifiedDownloadException -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(VerifiedDownloadException
_ :: VerifiedDownloadException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    checkExpectations :: IO ()
checkExpectations = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
fp IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Maybe LengthCheck -> (LengthCheck -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe LengthCheck
drLengthCheck ((LengthCheck -> IO ()) -> IO ())
-> (LengthCheck -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> LengthCheck -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Handle -> LengthCheck -> m ()
checkFileSizeExpectations Handle
h
        ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
            (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h
           ConduitT () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ZipSink ByteString IO () -> ConduitM ByteString Void IO ()
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink (Request -> [HashCheck] -> ZipSink ByteString IO ()
forall (m :: * -> *).
MonadThrow m =>
Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink Request
drRequest [HashCheck]
drHashChecks)

    -- doesn't move the handle
    checkFileSizeExpectations :: Handle -> LengthCheck -> m ()
checkFileSizeExpectations Handle
h LengthCheck
expectedFileSize = do
        Integer
fileSizeInteger <- Handle -> m Integer
forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
fileSizeInteger Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> LengthCheck -> Integer
forall a. Integral a => a -> Integer
toInteger (LengthCheck
forall a. Bounded a => a
maxBound :: Int)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            VerifyFileException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifyFileException -> m ()) -> VerifyFileException -> m ()
forall a b. (a -> b) -> a -> b
$ LengthCheck -> Integer -> VerifyFileException
WrongFileSize LengthCheck
expectedFileSize Integer
fileSizeInteger
        let fileSize :: LengthCheck
fileSize = Integer -> LengthCheck
forall a. Num a => Integer -> a
fromInteger Integer
fileSizeInteger
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LengthCheck
fileSize LengthCheck -> LengthCheck -> Bool
forall a. Eq a => a -> a -> Bool
/= LengthCheck
expectedFileSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            VerifyFileException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifyFileException -> m ()) -> VerifyFileException -> m ()
forall a b. (a -> b) -> a -> b
$ LengthCheck -> Integer -> VerifyFileException
WrongFileSize LengthCheck
expectedFileSize Integer
fileSizeInteger

    checkContentLengthHeader :: [(HeaderName, ByteString)]
-> LengthCheck -> ConduitM ByteString Void (RIO env) ()
checkContentLengthHeader [(HeaderName, ByteString)]
headers LengthCheck
expectedContentLength =
        case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
hContentLength [(HeaderName, ByteString)]
headers of
            Just ByteString
lengthBS -> do
              let lengthStr :: String
lengthStr = ByteString -> String
displayByteString ByteString
lengthBS
              Bool
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
lengthStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= LengthCheck -> String
forall a. Show a => a -> String
show LengthCheck
expectedContentLength) (ConduitM ByteString Void (RIO env) ()
 -> ConduitM ByteString Void (RIO env) ())
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall a b. (a -> b) -> a -> b
$
                VerifiedDownloadException -> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifiedDownloadException
 -> ConduitM ByteString Void (RIO env) ())
-> VerifiedDownloadException
-> ConduitM ByteString Void (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Request -> LengthCheck -> ByteString -> VerifiedDownloadException
WrongContentLength Request
drRequest LengthCheck
expectedContentLength ByteString
lengthBS
            Maybe ByteString
_ -> () -> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    go :: ConduitM ByteString Void (RIO env) ()
-> Response () -> ConduitM ByteString Void (RIO env) ()
go ConduitM ByteString Void (RIO env) ()
sink Response ()
res = do
        let headers :: [(HeaderName, ByteString)]
headers = Response () -> [(HeaderName, ByteString)]
forall a. Response a -> [(HeaderName, ByteString)]
getResponseHeaders Response ()
res
            mcontentLength :: Maybe Integer
mcontentLength = do
              ByteString
hLength <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
hContentLength [(HeaderName, ByteString)]
headers
              (Integer
i,ByteString
_) <- ByteString -> Maybe (Integer, ByteString)
readInteger ByteString
hLength
              Integer -> Maybe Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
        Maybe LengthCheck
-> (LengthCheck -> ConduitM ByteString Void (RIO env) ())
-> ConduitM ByteString Void (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe LengthCheck
drLengthCheck ((LengthCheck -> ConduitM ByteString Void (RIO env) ())
 -> ConduitM ByteString Void (RIO env) ())
-> (LengthCheck -> ConduitM ByteString Void (RIO env) ())
-> ConduitM ByteString Void (RIO env) ()
forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
-> LengthCheck -> ConduitM ByteString Void (RIO env) ()
checkContentLengthHeader [(HeaderName, ByteString)]
headers
        let hashChecks :: [HashCheck]
hashChecks = (case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
hContentMD5 [(HeaderName, ByteString)]
headers of
                Just ByteString
md5BS ->
                    [ HashCheck :: forall a.
(Show a, HashAlgorithm a) =>
a -> CheckHexDigest -> HashCheck
HashCheck
                          { hashCheckAlgorithm :: MD5
hashCheckAlgorithm = MD5
MD5
                          , hashCheckHexDigest :: CheckHexDigest
hashCheckHexDigest = ByteString -> CheckHexDigest
CheckHexDigestHeader ByteString
md5BS
                          }
                    ]
                Maybe ByteString
Nothing -> []
                ) [HashCheck] -> [HashCheck] -> [HashCheck]
forall a. [a] -> [a] -> [a]
++ [HashCheck]
drHashChecks

        (ConduitM ByteString Void (RIO env) ()
 -> ConduitM ByteString Void (RIO env) ())
-> (LengthCheck
    -> ConduitM ByteString Void (RIO env) ()
    -> ConduitM ByteString Void (RIO env) ())
-> Maybe LengthCheck
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall a. a -> a
id (\LengthCheck
len -> (LengthCheck -> ConduitT ByteString ByteString (RIO env) ()
forall (m :: * -> *).
Monad m =>
LengthCheck -> ConduitT ByteString ByteString m ()
CB.isolate LengthCheck
len ConduitT ByteString ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|)) Maybe LengthCheck
drLengthCheck
            (ConduitM ByteString Void (RIO env) ()
 -> ConduitM ByteString Void (RIO env) ())
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall a b. (a -> b) -> a -> b
$ ZipSink ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink
                ( Request -> [HashCheck] -> ZipSink ByteString (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink Request
drRequest [HashCheck]
hashChecks
                  ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ZipSink ByteString (RIO env) ()
-> (LengthCheck -> ZipSink ByteString (RIO env) ())
-> Maybe LengthCheck
-> ZipSink ByteString (RIO env) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ZipSink ByteString (RIO env) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Request -> LengthCheck -> ZipSink ByteString (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
Request -> LengthCheck -> ZipSink ByteString m ()
assertLengthSink Request
drRequest) Maybe LengthCheck
drLengthCheck
                  ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ConduitM ByteString Void (RIO env) ()
-> ZipSink ByteString (RIO env) ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink ConduitM ByteString Void (RIO env) ()
sink
                  ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
-> ZipSink ByteString (RIO env) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ConduitM ByteString Void (RIO env) ()
-> ZipSink ByteString (RIO env) ()
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Maybe Integer -> ConduitM ByteString Void (RIO env) ()
progressSink Maybe Integer
mcontentLength))
    catchingHttpExceptions :: RIO env a -> RIO env a
    catchingHttpExceptions :: RIO env a -> RIO env a
catchingHttpExceptions RIO env a
action = RIO env a -> (HttpException -> RIO env a) -> RIO env a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch RIO env a
action (VerifiedDownloadException -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VerifiedDownloadException -> RIO env a)
-> (HttpException -> VerifiedDownloadException)
-> HttpException
-> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> VerifiedDownloadException
DownloadHttpError)


-- | Like 'UnliftIO.Temporary.withTempFile', but the file is created with
--   default file permissions, instead of read/write access only for the owner.
withTempFileWithDefaultPermissions
             :: MonadUnliftIO m
             => FilePath -- ^ Temp dir to create the file in.
             -> String   -- ^ File name template. See 'openTempFile'.
             -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file.
             -> m a
withTempFileWithDefaultPermissions :: String -> String -> (String -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions String
tmpDir String
template String -> Handle -> m a
action =
  m (String, Handle)
-> ((String, Handle) -> m ()) -> ((String, Handle) -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (IO (String, Handle) -> m (String, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO (String, Handle)
openTempFileWithDefaultPermissions String
tmpDir String
template))
    (\(String
name, Handle
handle') -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
handle' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
forall a. IO a -> IO ()
ignoringIOErrors (String -> IO ()
removeFile String
name)))
    ((String -> Handle -> m a) -> (String, Handle) -> m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Handle -> m a
action)
  where
    ignoringIOErrors :: IO a -> IO ()
ignoringIOErrors = IO (Either IOException a) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void(IO (Either IOException a) -> IO ())
-> (IO a -> IO (Either IOException a)) -> IO a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOException a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO