{-# 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 Int
drLengthCheck :: Maybe LengthCheck
, DownloadRequest -> RetryPolicy
drRetryPolicy :: RetryPolicy
, DownloadRequest -> Bool
drForceDownload :: Bool
}
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 RetryPolicyM m
RetryPolicy
drRetryPolicyDefault Bool
False
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 }
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest
setHashChecks [HashCheck]
x DownloadRequest
dr = DownloadRequest
dr { drHashChecks :: [HashCheck]
drHashChecks = [HashCheck]
x }
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 }
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest
setRetryPolicy RetryPolicy
x DownloadRequest
dr = DownloadRequest
dr { drRetryPolicy :: RetryPolicy
drRetryPolicy = RetryPolicyM m
RetryPolicy
x }
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload :: Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
x DownloadRequest
dr = DownloadRequest
dr { drForceDownload :: Bool
drForceDownload = Bool
x }
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
| 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
$cshowsPrec :: Int -> CheckHexDigest -> ShowS
showsPrec :: Int -> CheckHexDigest -> ShowS
$cshow :: CheckHexDigest -> [Char]
show :: CheckHexDigest -> [Char]
$cshowList :: [CheckHexDigest] -> ShowS
showList :: [CheckHexDigest] -> ShowS
Show
instance IsString CheckHexDigest where
fromString :: [Char] -> CheckHexDigest
fromString = [Char] -> 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 -> [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
data VerifyFileException
= WrongFileSize
Int
Integer
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
$cshowsPrec :: Int -> VerifyFileException -> ShowS
showsPrec :: Int -> VerifyFileException -> ShowS
$cshow :: VerifyFileException -> [Char]
show :: VerifyFileException -> [Char]
$cshowList :: [VerifyFileException] -> ShowS
showList :: [VerifyFileException] -> ShowS
Show, Typeable)
instance Exception VerifyFileException
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
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]
")"
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
hashCheckAlgorithm :: ()
hashCheckHexDigest :: HashCheck -> CheckHexDigest
hashCheckAlgorithm :: a
hashCheckHexDigest :: CheckHexDigest
..} = 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
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 e a. Exception e => e -> ConduitT ByteString o m a
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 e a. Exception e => e -> ConduitT ByteString Void m a
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
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)
Consumer ByteString 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 :: 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)
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 a. a -> IO a
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 a. a -> m a
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
IOErrorType
ResourceVanished -> Bool
True
IOErrorType
_ -> Bool
False
verifiedDownload
:: HasTerm env
=> DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
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
drRequest :: DownloadRequest -> Request
drHashChecks :: DownloadRequest -> [HashCheck]
drLengthCheck :: DownloadRequest -> Maybe Int
drRetryPolicy :: DownloadRequest -> RetryPolicy
drForceDownload :: DownloadRequest -> Bool
drRequest :: Request
drHashChecks :: [HashCheck]
drLengthCheck :: Maybe Int
drRetryPolicy :: RetryPolicy
drForceDownload :: Bool
..} 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 a. IO a -> RIO env a
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 a. IO a -> RIO env a
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 RetryPolicyM m
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 a. IO a -> RIO env a
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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else Bool -> m Bool
forall a. a -> m a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
Bool
fileExists <- [Char] -> IO Bool
doesFileExist [Char]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
fileMatchesExpectations :: IO Bool
fileMatchesExpectations =
((IO ()
checkExpectations IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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)
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 e a. Exception e => e -> m a
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 e a. Exception e => e -> m a
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 e a.
Exception e =>
e -> ConduitT ByteString Void (RIO env) a
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 a. a -> ConduitT ByteString Void (RIO env) a
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 a. a -> Maybe a
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
{ 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 a b.
ZipSink ByteString (RIO env) a
-> ZipSink ByteString (RIO env) b -> ZipSink ByteString (RIO env) b
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 a. a -> ZipSink ByteString (RIO env) a
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 a b.
ZipSink ByteString (RIO env) a
-> ZipSink ByteString (RIO env) b -> ZipSink ByteString (RIO env) b
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 a b.
ZipSink ByteString (RIO env) a
-> ZipSink ByteString (RIO env) b -> ZipSink ByteString (RIO env) b
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 e a. Exception e => e -> 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 :: 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 a. IO a -> m a
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 a. IO a -> m a
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 a b. IO a -> IO b -> IO b
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