{-# 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
, 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 (..))
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)
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
}
mkDownloadRequest :: Request -> DownloadRequest
mkDownloadRequest :: Request -> DownloadRequest
mkDownloadRequest req :: 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
modifyRequest :: (Request -> Request) -> DownloadRequest -> DownloadRequest
modifyRequest :: (Request -> Request) -> DownloadRequest -> DownloadRequest
modifyRequest f :: Request -> Request
f dr :: 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 }
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks x :: [HashCheck]
x dr :: DownloadRequest
dr = DownloadRequest
dr { drHashChecks :: [HashCheck]
drHashChecks = [HashCheck]
x }
setLengthCheck :: Maybe LengthCheck -> DownloadRequest -> DownloadRequest
setLengthCheck :: Maybe LengthCheck -> DownloadRequest -> DownloadRequest
setLengthCheck x :: Maybe LengthCheck
x dr :: DownloadRequest
dr = DownloadRequest
dr { drLengthCheck :: Maybe LengthCheck
drLengthCheck = Maybe LengthCheck
x }
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy :: (forall (m :: * -> *). Monad m => RetryPolicyM m)
-> DownloadRequest -> DownloadRequest
setRetryPolicy x :: forall (m :: * -> *). Monad m => RetryPolicyM m
x dr :: DownloadRequest
dr = DownloadRequest
dr { drRetryPolicy :: forall (m :: * -> *). Monad m => RetryPolicyM m
drRetryPolicy = forall (m :: * -> *). Monad m => RetryPolicyM m
x }
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload x :: Bool
x dr :: DownloadRequest
dr = DownloadRequest
dr { drForceDownload :: Bool
drForceDownload = Bool
x }
drRetryPolicyDefault :: RetryPolicy
drRetryPolicyDefault :: RetryPolicyM m
drRetryPolicyDefault = LengthCheck -> forall (m :: * -> *). Monad m => RetryPolicyM m
limitRetries 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 = 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
| 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
data VerifiedDownloadException
= WrongContentLength
Request
Int
ByteString
| WrongStreamLength
Request
Int
Int
| WrongDigest
Request
String
CheckHexDigest
String
| DownloadHttpError
HttpException
deriving (Typeable)
instance Show VerifiedDownloadException where
show :: VerifiedDownloadException -> String
show (WrongContentLength req :: Request
req expected :: LengthCheck
expected actual :: ByteString
actual) =
"Download expectation failure: ContentLength header\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Actual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
displayByteString ByteString
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
show (WrongStreamLength req :: Request
req expected :: LengthCheck
expected actual :: LengthCheck
actual) =
"Download expectation failure: download size\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
show (WrongDigest req :: Request
req algo :: String
algo expected :: CheckHexDigest
expected actual :: String
actual) =
"Download expectation failure: content hash (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
algo String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Expected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CheckHexDigest -> String
displayCheckHexDigest CheckHexDigest
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Actual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
actual String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "For: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show (Request -> URI
getUri Request
req)
show (DownloadHttpError exception :: HttpException
exception) =
"Download expectation failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpException -> String
forall a. Show a => a -> String
show HttpException
exception
instance Exception VerifiedDownloadException
data VerifyFileException
= WrongFileSize
Int
Integer
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
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
displayCheckHexDigest :: CheckHexDigest -> String
displayCheckHexDigest :: CheckHexDigest -> String
displayCheckHexDigest (CheckHexDigestString s :: String
s) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (String)"
displayCheckHexDigest (CheckHexDigestByteString s :: ByteString
s) = ByteString -> String
displayByteString ByteString
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (ByteString)"
displayCheckHexDigest (CheckHexDigestHeader h :: ByteString
h) =
ByteString -> String
forall a. Show a => a -> String
show (ByteString -> ByteString
B64.decodeLenient ByteString
h) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (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]
++ ")"
sinkCheckHash :: MonadThrow m
=> Request
-> HashCheck
-> ConduitM ByteString o m ()
sinkCheckHash :: Request -> HashCheck -> ConduitM ByteString o m ()
sinkCheckHash req :: Request
req HashCheck{..} = 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 s :: String
s -> String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
actualDigestString
CheckHexDigestByteString b :: ByteString
b -> ByteString
b ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actualDigestHexByteString
CheckHexDigestHeader b :: 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
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 req :: Request
req expectedStreamLength :: 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 actualStreamLength :: 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
sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)
sinkHashUsing :: a -> ConduitM ByteString o m (Digest a)
sinkHashUsing _ = ConduitM ByteString o m (Digest a)
forall (m :: * -> *) hash.
(Monad m, HashAlgorithm hash) =>
Consumer ByteString m (Digest hash)
sinkHash
hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink :: Request -> [HashCheck] -> ZipSink ByteString m ()
hashChecksToZipSink req :: 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)
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 retryPolicy :: 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
$ \run :: 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 wrapper :: UnliftIO (RIO env) -> IO a -> IO a
wrapper action :: 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
$ \run :: 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 u :: 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 u :: UnliftIO (RIO env)
u rs :: RetryStatus
rs _ = 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
[ "Retry number"
, LengthCheck -> String
forall a. Show a => a -> String
show (RetryStatus -> LengthCheck
rsIterNumber RetryStatus
rs)
, "after a total delay of"
, LengthCheck -> String
forall a. Show a => a -> String
show (RetryStatus -> LengthCheck
rsCumulativeDelay RetryStatus
rs)
, "us"
]
, String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ "If you see this warning and stack fails to download,"
, "but running the command again solves the problem,"
, "please report here: https://github.com/commercialhaskell/stack/issues/3510"
, "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 e :: 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
ResourceVanished -> Bool
True
_ -> Bool
False
verifiedDownload
:: HasTerm env
=> DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload :: DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload DownloadRequest{..} destpath :: Path Abs File
destpath progressSink :: 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
$ "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
$ \fptmp :: String
fptmp htmp :: 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' mp :: m Bool
mp m :: 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
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
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
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
$ \h :: 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)
checkFileSizeExpectations :: Handle -> LengthCheck -> m ()
checkFileSizeExpectations h :: Handle
h expectedFileSize :: 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 headers :: [(HeaderName, ByteString)]
headers expectedContentLength :: 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 lengthBS :: 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
_ -> () -> 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 sink :: ConduitM ByteString Void (RIO env) ()
sink res :: 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
(i :: Integer
i,_) <- 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 md5BS :: 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
}
]
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 (\len :: 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 action :: 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)
withTempFileWithDefaultPermissions
:: MonadUnliftIO m
=> FilePath
-> String
-> (FilePath -> Handle -> m a)
-> m a
withTempFileWithDefaultPermissions :: String -> String -> (String -> Handle -> m a) -> m a
withTempFileWithDefaultPermissions tmpDir :: String
tmpDir template :: String
template action :: 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))
(\(name :: String
name, handle' :: 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