{-# 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 [] 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 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 forall a. Semigroup a => a -> a -> a
<> 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]
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"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
expected forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
displayByteString ByteString
actual forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"For: " forall a. [a] -> [a] -> [a]
++ 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"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
expected forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
actual forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"For: " forall a. [a] -> [a] -> [a]
++ 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 (" forall a. [a] -> [a] -> [a]
++ [Char]
algo forall a. [a] -> [a] -> [a]
++  [Char]
")\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Expected: " forall a. [a] -> [a] -> [a]
++ CheckHexDigest -> [Char]
displayCheckHexDigest CheckHexDigest
expected forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"Actual:   " forall a. [a] -> [a] -> [a]
++ [Char]
actual forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        forall a. [a] -> [a] -> [a]
++ [Char]
"For: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Request -> URI
getUri Request
req)
    show (DownloadHttpError HttpException
exception) =
      [Char]
"Download expectation failure: " forall a. [a] -> [a] -> [a]
++ 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]
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip 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 forall a. [a] -> [a] -> [a]
++ [Char]
" (String)"
displayCheckHexDigest (CheckHexDigestByteString ByteString
s) = ByteString -> [Char]
displayByteString ByteString
s forall a. [a] -> [a] -> [a]
++ [Char]
" (ByteString)"
displayCheckHexDigest (CheckHexDigestHeader ByteString
h) =
      forall a. Show a => a -> [Char]
show (ByteString -> ByteString
B64.decodeLenient ByteString
h) forall a. [a] -> [a] -> [a]
++ [Char]
" (Header. unencoded: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ByteString
h 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 <- forall (m :: * -> *) a o.
(Monad m, HashAlgorithm a) =>
a -> ConduitM ByteString o m (Digest a)
sinkHashUsing a
hashCheckAlgorithm
    let actualDigestString :: [Char]
actualDigestString = forall a. Show a => a -> [Char]
show Digest a
digest
    let actualDigestHexByteString :: ByteString
actualDigestHexByteString = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
Mem.convertToBase Base
Mem.Base16 Digest a
digest
    let actualDigestBytes :: ByteString
actualDigestBytes = 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 forall a. Eq a => a -> a -> Bool
== [Char]
actualDigestString
          CheckHexDigestByteString ByteString
b -> ByteString
b forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString
          CheckHexDigestHeader ByteString
b -> ByteString -> ByteString
B64.decodeLenient ByteString
b forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString
            Bool -> Bool -> Bool
|| ByteString -> ByteString
B64.decodeLenient ByteString
b 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 forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
passedCheck forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Request
-> [Char] -> CheckHexDigest -> [Char] -> VerifiedDownloadException
WrongDigest Request
req (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 = forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink forall a b. (a -> b) -> a -> b
$ do
  Sum Int
actualStreamLength <- forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
CL.foldMap (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
ByteString.length)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
actualStreamLength forall a. Eq a => a -> a -> Bool
/= Int
expectedStreamLength) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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
_ = forall (m :: * -> *) hash o.
(Monad m, HashAlgorithm hash) =>
ConduitT ByteString o 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ \UnliftIO (RIO env)
run -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicy
retryPolicy (UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]
handlers UnliftIO (RIO env)
run) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO forall a b. (a -> b) -> a -> b
$ \UnliftIO (RIO env)
run -> UnliftIO (RIO env) -> IO a -> IO a
wrapper UnliftIO (RIO env)
run (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 = [forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool
alwaysRetryHttp UnliftIO (RIO env)
u,forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler 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
      forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO env)
u forall a b. (a -> b) -> a -> b
$
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
vcat
          [ [Char] -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
            [ [Char]
"Retry number"
            , forall a. Show a => a -> [Char]
show (RetryStatus -> Int
rsIterNumber RetryStatus
rs)
            , [Char]
"after a total delay of"
            , forall a. Show a => a -> [Char]
show (RetryStatus -> Int
rsCumulativeDelay RetryStatus
rs)
            , [Char]
"us"
            ]
          , [Char] -> StyleDoc
flow 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'"
            ]
          ]
      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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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
    forall {m :: * -> *} {a}. Monad m => m Bool -> m a -> m Bool
whenM' (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
getShouldDownload) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ByteString
path Request
req))
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
        forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions [Char]
dir (ShowS
FP.takeFileName [Char]
fp) forall a b. (a -> b) -> a -> b
$ \[Char]
fptmp Handle
htmp -> do
            forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp RetryPolicy
drRetryPolicy forall a b. (a -> b) -> a -> b
$ forall env a. RIO env a -> RIO env a
catchingHttpExceptions forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a.
MonadUnliftIO m =>
Request -> (Response () -> ConduitM ByteString Void m a) -> m a
httpSink Request
req forall a b. (a -> b) -> a -> b
$ ConduitM ByteString Void (RIO env) ()
-> Response () -> ConduitM ByteString Void (RIO env) ()
go (forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
htmp)
            forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
htmp
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

    getShouldDownload :: IO Bool
getShouldDownload = if Bool
drForceDownload then 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
fileMatchesExpectations
            -- or if it doesn't exist yet
            else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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

    checkExpectations :: IO ()
checkExpectations = forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
drLengthCheck forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
(MonadIO m, MonadThrow m) =>
Handle -> Int -> m ()
checkFileSizeExpectations Handle
h
        forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h
           forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink (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 <- forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
fileSizeInteger forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int)) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Int -> Integer -> VerifyFileException
WrongFileSize Int
expectedFileSize Integer
fileSizeInteger
        let fileSize :: Int
fileSize = forall a. Num a => Integer -> a
fromInteger Integer
fileSizeInteger
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
fileSize forall a. Eq a => a -> a -> Bool
/= Int
expectedFileSize) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 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
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
lengthStr forall a. Eq a => a -> a -> Bool
/= forall a. Show a => a -> [Char]
show Int
expectedContentLength) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Request -> Int -> ByteString -> VerifiedDownloadException
WrongContentLength Request
drRequest Int
expectedContentLength ByteString
lengthBS
            Maybe ByteString
_ -> 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 = forall a. Response a -> [(HeaderName, ByteString)]
getResponseHeaders Response ()
res
            mcontentLength :: Maybe Integer
mcontentLength = do
              ByteString
hLength <- 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
              forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
drLengthCheck forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
-> Int -> ConduitM ByteString Void (RIO env) ()
checkContentLengthHeader [(HeaderName, ByteString)]
headers
        let hashChecks :: [HashCheck]
hashChecks = (case forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup HeaderName
hContentMD5 [(HeaderName, ByteString)]
headers of
                Just ByteString
md5BS ->
                    [ HashCheck
                          { hashCheckAlgorithm :: MD5
hashCheckAlgorithm = MD5
MD5
                          , hashCheckHexDigest :: CheckHexDigest
hashCheckHexDigest = ByteString -> CheckHexDigest
CheckHexDigestHeader ByteString
md5BS
                          }
                    ]
                Maybe ByteString
Nothing -> []
                ) forall a. [a] -> [a] -> [a]
++ [HashCheck]
drHashChecks

        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Int
len -> (forall (m :: * -> *).
Monad m =>
Int -> ConduitT ByteString ByteString m ()
CB.isolate Int
len 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
            forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink
                ( forall (m :: * -> *).
MonadThrow m =>
Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink Request
drRequest [HashCheck]
hashChecks
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall (m :: * -> *).
MonadThrow m =>
Request -> Int -> ZipSink ByteString m ()
assertLengthSink Request
drRequest) Maybe Int
drLengthCheck
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitM ByteString Void (RIO env) ()
sink
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch RIO env a
action (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 =
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> [Char] -> IO ([Char], Handle)
openTempFileWithDefaultPermissions [Char]
tmpDir [Char]
template))
    (\([Char]
name, Handle
handle') -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
handle' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {a}. IO a -> IO ()
ignoringIOErrors ([Char] -> IO ()
removeFile [Char]
name)))
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Handle -> m a
action)
  where
    ignoringIOErrors :: IO a -> IO ()
ignoringIOErrors = forall (f :: * -> *) a. Functor f => f a -> f ()
voidforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO