{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Download
( DownloadRequest
, mkDownloadRequest
, modifyRequest
, setHashChecks
, setLengthCheck
, setRetryPolicy
, setForceDownload
, drRetryPolicyDefault
, HashCheck(..)
, DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
, download
, redownload
, verifiedDownload
) where
import qualified Data.ByteString.Lazy as L
import Conduit
import qualified Data.Conduit.Binary as CB
import Network.HTTP.Download.Verified
import Network.HTTP.Client (HttpException, Request, Response, checkResponse, path, requestHeaders)
import Network.HTTP.Simple (getResponseBody, getResponseHeaders, getResponseStatusCode, withResponse)
import Path (Path, Abs, File, toFilePath)
import Path.IO (doesFileExist)
import RIO
import RIO.PrettyPrint
import System.Directory (createDirectoryIfMissing,
removeFile)
import System.FilePath (takeDirectory, (<.>))
download :: HasTerm env
=> Request
-> Path Abs File
-> RIO env Bool
download :: forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
download Request
req Path Abs File
destpath = do
let downloadReq :: DownloadRequest
downloadReq = Request -> DownloadRequest
mkDownloadRequest Request
req
let progressHook :: p -> m ()
progressHook p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ())
-> RIO env Bool
verifiedDownload DownloadRequest
downloadReq Path Abs File
destpath Maybe Integer -> ConduitM ByteString Void (RIO env) ()
forall {m :: * -> *} {p}. Monad m => p -> m ()
progressHook
redownload :: HasTerm env
=> Request
-> Path Abs File
-> RIO env Bool
redownload :: forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
redownload Request
req0 Path Abs File
dest = 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
req0))
let destFilePath :: FilePath
destFilePath = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
dest
etagFilePath :: FilePath
etagFilePath = FilePath
destFilePath FilePath -> FilePath -> FilePath
<.> FilePath
"etag"
Maybe ByteString
metag <- do
Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
if Bool -> Bool
not Bool
exists
then Maybe ByteString -> RIO env (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
else IO (Maybe ByteString) -> RIO env (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> RIO env (Maybe ByteString))
-> IO (Maybe ByteString) -> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (IO (Maybe ByteString) -> IOException -> IO (Maybe ByteString)
forall a b. a -> b -> a
const (IO (Maybe ByteString) -> IOException -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IOException -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing) (IO (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
FilePath
-> (ConduitM () ByteString IO () -> IO ByteString) -> IO ByteString
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
etagFilePath ((ConduitM () ByteString IO () -> IO ByteString) -> IO ByteString)
-> (ConduitM () ByteString IO () -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src -> ConduitT () Void IO ByteString -> IO ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO ByteString -> IO ByteString)
-> ConduitT () Void IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src ConduitM () ByteString IO ()
-> ConduitT ByteString Void IO ByteString
-> ConduitT () Void IO ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Int -> ConduitT ByteString Void IO ByteString
forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ByteString
CB.take Int
512
let req1 :: Request
req1 =
case Maybe ByteString
metag of
Maybe ByteString
Nothing -> Request
req0
Just ByteString
etag -> Request
req0
{ requestHeaders :: RequestHeaders
requestHeaders =
Request -> RequestHeaders
requestHeaders Request
req0 RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++
[(HeaderName
"If-None-Match", ByteString -> ByteString
L.toStrict ByteString
etag)]
}
req2 :: Request
req2 = Request
req1 { checkResponse :: Request -> Response BodyReader -> IO ()
checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
RetryPolicy -> RIO env Bool -> RIO env Bool
forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp RetryPolicy
drRetryPolicyDefault (RIO env Bool -> RIO env Bool) -> RIO env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ RIO env Bool -> RIO env Bool
forall env a. RIO env a -> RIO env a
catchingHttpExceptions (RIO env Bool -> RIO env Bool) -> RIO env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$
Request
-> (Response (ConduitM () ByteString IO ()) -> IO Bool) -> IO Bool
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req2 ((Response (ConduitM () ByteString IO ()) -> IO Bool) -> IO Bool)
-> (Response (ConduitM () ByteString IO ()) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString IO ())
res -> case Response (ConduitM () ByteString IO ()) -> Int
forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
Int
200 -> do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
destFilePath
(IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (IO () -> IOException -> IO ()
forall a b. a -> b -> a
const (IO () -> IOException -> IO ()) -> IO () -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
etagFilePath
FilePath -> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious FilePath
destFilePath ((ConduitM ByteString Void IO () -> IO ()) -> IO ())
-> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
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
$ Response (ConduitM () ByteString IO ())
-> ConduitM () ByteString IO ()
forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res ConduitM () ByteString IO ()
-> ConduitM 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
.| ConduitM ByteString Void IO ()
sink
Maybe ByteString -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"ETag" (Response (ConduitM () ByteString IO ()) -> RequestHeaders
forall a. Response a -> RequestHeaders
getResponseHeaders Response (ConduitM () ByteString IO ())
res)) ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
e ->
FilePath -> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious FilePath
etagFilePath ((ConduitM ByteString Void IO () -> IO ()) -> IO ())
-> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
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
$ ByteString -> ConduitM () ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
e ConduitM () ByteString IO ()
-> ConduitM 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
.| ConduitM ByteString Void IO ()
sink
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Int
304 -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Int
_ -> DownloadException -> IO Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (DownloadException -> IO Bool) -> DownloadException -> IO Bool
forall a b. (a -> b) -> a -> b
$ Request -> Path Abs File -> Response () -> DownloadException
RedownloadInvalidResponse Request
req2 Path Abs File
dest (Response () -> DownloadException)
-> Response () -> DownloadException
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString IO ()) -> Response ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Response (ConduitM () ByteString IO ())
res
where
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 (DownloadException -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (DownloadException -> RIO env a)
-> (HttpException -> DownloadException)
-> HttpException
-> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> DownloadException
RedownloadHttpError)
data DownloadException = RedownloadInvalidResponse Request (Path Abs File) (Response ())
| RedownloadHttpError HttpException
deriving (Int -> DownloadException -> FilePath -> FilePath
[DownloadException] -> FilePath -> FilePath
DownloadException -> FilePath
(Int -> DownloadException -> FilePath -> FilePath)
-> (DownloadException -> FilePath)
-> ([DownloadException] -> FilePath -> FilePath)
-> Show DownloadException
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DownloadException] -> FilePath -> FilePath
$cshowList :: [DownloadException] -> FilePath -> FilePath
show :: DownloadException -> FilePath
$cshow :: DownloadException -> FilePath
showsPrec :: Int -> DownloadException -> FilePath -> FilePath
$cshowsPrec :: Int -> DownloadException -> FilePath -> FilePath
Show, Typeable)
instance Exception DownloadException