{-# 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 Int
drLengthCheck :: Maybe LengthCheck
    , DownloadRequest -> RetryPolicy
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 Int
-> RetryPolicy
-> Bool
-> DownloadRequest
DownloadRequest Request
req [] Maybe Int
forall a. Maybe a
Nothing RetryPolicy
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 Int -> DownloadRequest -> DownloadRequest
setLengthCheck Maybe Int
x DownloadRequest
dr = DownloadRequest
dr { drLengthCheck :: Maybe Int
drLengthCheck = Maybe Int
x }

-- | Set the retry policy to be used when downloading.
--
-- @since 0.2.0.0
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy RetryPolicy
x DownloadRequest
dr = DownloadRequest
dr { drRetryPolicy :: RetryPolicy
drRetryPolicy = RetryPolicy
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 :: RetryPolicy
drRetryPolicyDefault = Int -> RetryPolicy
limitRetries Int
7 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
onehundredMilliseconds
  where onehundredMilliseconds :: Int
onehundredMilliseconds = Int
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 Int -> CheckHexDigest -> ShowS
[CheckHexDigest] -> ShowS
CheckHexDigest -> [Char]
(Int -> CheckHexDigest -> ShowS)
-> (CheckHexDigest -> [Char])
-> ([CheckHexDigest] -> ShowS)
-> Show CheckHexDigest
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CheckHexDigest] -> ShowS
$cshowList :: [CheckHexDigest] -> ShowS
show :: CheckHexDigest -> [Char]
$cshow :: CheckHexDigest -> [Char]
showsPrec :: Int -> CheckHexDigest -> ShowS
$cshowsPrec :: Int -> CheckHexDigest -> ShowS
Show
instance IsString CheckHexDigest where
  fromString :: [Char] -> CheckHexDigest
fromString = [Char] -> 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 -> [Char]
show (WrongContentLength Request
req Int
expected ByteString
actual) =
        [Char]
"Download expectation failure: ContentLength header\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
displayByteString ByteString
actual [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"For: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
forall a. Show a => a -> [Char]
show (Request -> URI
getUri Request
req)
    show (WrongStreamLength Request
req Int
expected Int
actual) =
        [Char]
"Download expectation failure: download size\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
actual [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"For: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
forall a. Show a => a -> [Char]
show (Request -> URI
getUri Request
req)
    show (WrongDigest Request
req [Char]
algo CheckHexDigest
expected [Char]
actual) =
        [Char]
"Download expectation failure: content hash (" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
algo [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++  [Char]
")\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CheckHexDigest -> [Char]
displayCheckHexDigest CheckHexDigest
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
actual [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"For: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
forall a. Show a => a -> [Char]
show (Request -> URI
getUri Request
req)
    show (DownloadHttpError HttpException
exception) =
      [Char]
"Download expectation failure: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpException -> [Char]
forall a. Show a => a -> [Char]
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 (Int -> VerifyFileException -> ShowS
[VerifyFileException] -> ShowS
VerifyFileException -> [Char]
(Int -> VerifyFileException -> ShowS)
-> (VerifyFileException -> [Char])
-> ([VerifyFileException] -> ShowS)
-> Show VerifyFileException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VerifyFileException] -> ShowS
$cshowList :: [VerifyFileException] -> ShowS
show :: VerifyFileException -> [Char]
$cshow :: VerifyFileException -> [Char]
showsPrec :: Int -> VerifyFileException -> ShowS
$cshowsPrec :: Int -> VerifyFileException -> ShowS
Show, Typeable)
instance Exception VerifyFileException

-- Show a ByteString that is known to be UTF8 encoded.
displayByteString :: ByteString -> String
displayByteString :: ByteString -> [Char]
displayByteString =
    Text -> [Char]
Text.unpack (Text -> [Char]) -> (ByteString -> Text) -> ByteString -> [Char]
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 -> [Char]
displayCheckHexDigest (CheckHexDigestString [Char]
s) = [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (String)"
displayCheckHexDigest (CheckHexDigestByteString ByteString
s) = ByteString -> [Char]
displayByteString ByteString
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (ByteString)"
displayCheckHexDigest (CheckHexDigestHeader ByteString
h) =
      ByteString -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> ByteString
B64.decodeLenient ByteString
h) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (Header. unencoded: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
h [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"


-- | 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 :: forall (m :: * -> *) o.
MonadThrow m =>
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 :: [Char]
actualDigestString = Digest a -> [Char]
forall a. Show a => a -> [Char]
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 [Char]
s -> [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
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
-> [Char] -> CheckHexDigest -> [Char] -> VerifiedDownloadException
WrongDigest Request
req (a -> [Char]
forall a. Show a => a -> [Char]
show a
hashCheckAlgorithm) CheckHexDigest
hashCheckHexDigest [Char]
actualDigestString

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

-- | A more explicitly type-guided sinkHash.
sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)
sinkHashUsing :: forall (m :: * -> *) a o.
(Monad m, HashAlgorithm a) =>
a -> ConduitM ByteString o m (Digest a)
sinkHashUsing a
_ = ConduitT 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 :: forall (m :: * -> *).
MonadThrow m =>
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_ (ConduitT ByteString Void m () -> ZipSink ByteString m ()
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (ConduitT ByteString Void m () -> ZipSink ByteString m ())
-> (HashCheck -> ConduitT ByteString Void m ())
-> HashCheck
-> ZipSink ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HashCheck -> ConduitT ByteString Void 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 env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp RetryPolicy
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
RetryPolicy
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) -> forall a. 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
          [ [Char] -> StyleDoc
flow ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
            [ [Char]
"Retry number"
            , Int -> [Char]
forall a. Show a => a -> [Char]
show (RetryStatus -> Int
rsIterNumber RetryStatus
rs)
            , [Char]
"after a total delay of"
            , Int -> [Char]
forall a. Show a => a -> [Char]
show (RetryStatus -> Int
rsCumulativeDelay RetryStatus
rs)
            , [Char]
"us"
            ]
          , [Char] -> StyleDoc
flow ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
            [ [Char]
"If you see this warning and stack fails to download,"
            , [Char]
"but running the command again solves the problem,"
            , [Char]
"please report here: https://github.com/commercialhaskell/stack/issues/3510"
            , [Char]
"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 :: forall (m :: * -> *). Monad m => 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 :: forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload DownloadRequest{Bool
[HashCheck]
Maybe Int
Request
RetryPolicy
drForceDownload :: Bool
drRetryPolicy :: RetryPolicy
drLengthCheck :: Maybe Int
drHashChecks :: [HashCheck]
drRequest :: Request
drForceDownload :: DownloadRequest -> Bool
drRetryPolicy :: DownloadRequest -> RetryPolicy
drLengthCheck :: DownloadRequest -> Maybe Int
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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
        [Char] -> [Char] -> ([Char] -> Handle -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions [Char]
dir (ShowS
FP.takeFileName [Char]
fp) (([Char] -> Handle -> RIO env ()) -> RIO env ())
-> ([Char] -> Handle -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \[Char]
fptmp Handle
htmp -> do
            RetryPolicy -> RIO env () -> RIO env ()
forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp RetryPolicy
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
$ [Char] -> [Char] -> IO ()
renameFile [Char]
fptmp [Char]
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 :: [Char]
fp = Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
destpath
    dir :: [Char]
dir = Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> [Char]) -> Path Abs Dir -> [Char]
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 <- [Char] -> IO Bool
doesFileExist [Char]
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 = [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
fp IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Maybe Int -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
drLengthCheck ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ()
forall {m :: * -> *}.
(MonadIO m, MonadThrow m) =>
Handle -> Int -> 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 ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ZipSink ByteString IO () -> ConduitT ByteString Void IO ()
forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void 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 -> Int -> m ()
checkFileSizeExpectations Handle
h Int
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
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
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
$ Int -> Integer -> VerifyFileException
WrongFileSize Int
expectedFileSize Integer
fileSizeInteger
        let fileSize :: Int
fileSize = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
fileSizeInteger
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
fileSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
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
$ Int -> Integer -> VerifyFileException
WrongFileSize Int
expectedFileSize Integer
fileSizeInteger

    checkContentLengthHeader :: [(HeaderName, ByteString)]
-> Int -> ConduitM ByteString Void (RIO env) ()
checkContentLengthHeader [(HeaderName, ByteString)]
headers Int
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 :: [Char]
lengthStr = ByteString -> [Char]
displayByteString ByteString
lengthBS
              Bool
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
lengthStr [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> [Char]
forall a. Show a => a -> [Char]
show Int
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 -> Int -> ByteString -> VerifiedDownloadException
WrongContentLength Request
drRequest Int
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 Int
-> (Int -> 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 Int
drLengthCheck ((Int -> ConduitM ByteString Void (RIO env) ())
 -> ConduitM ByteString Void (RIO env) ())
-> (Int -> ConduitM ByteString Void (RIO env) ())
-> ConduitM ByteString Void (RIO env) ()
forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
-> Int -> 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) ())
-> (Int
    -> ConduitM ByteString Void (RIO env) ()
    -> ConduitM ByteString Void (RIO env) ())
-> Maybe Int
-> 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 (\Int
len -> (Int -> ConduitT ByteString ByteString (RIO env) ()
forall (m :: * -> *).
Monad m =>
Int -> ConduitT ByteString ByteString m ()
CB.isolate Int
len ConduitT ByteString ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|)) Maybe Int
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 -> ConduitT i Void 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) ()
-> (Int -> ZipSink ByteString (RIO env) ())
-> Maybe Int
-> 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 -> Int -> ZipSink ByteString (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
Request -> Int -> ZipSink ByteString m ()
assertLengthSink Request
drRequest) Maybe Int
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. ConduitT i Void 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. ConduitT i Void 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 :: forall env a. 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 :: forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions [Char]
tmpDir [Char]
template [Char] -> Handle -> m a
action =
  m ([Char], Handle)
-> (([Char], Handle) -> m ()) -> (([Char], Handle) -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (IO ([Char], Handle) -> m ([Char], Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> [Char] -> IO ([Char], Handle)
openTempFileWithDefaultPermissions [Char]
tmpDir [Char]
template))
    (\([Char]
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 ([Char] -> IO ()
removeFile [Char]
name)))
    (([Char] -> Handle -> m a) -> ([Char], Handle) -> m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> 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