{-# 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 the given URL to the given location. If the file already exists,
-- no download is performed. Otherwise, creates the parent directory, downloads
-- to a temporary file, and on file download completion moves to the
-- appropriate destination.
--
-- Throws an exception if things go wrong
download :: HasTerm env
         => Request
         -> Path Abs File -- ^ destination
         -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
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

-- | Same as 'download', but will download a file a second time if it is already present.
--
-- Returns 'True' if the file was downloaded, 'False' otherwise
redownload :: HasTerm env
           => Request
           -> Path Abs File -- ^ destination
           -> 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

          -- Order here is important: first delete the etag, then write the
          -- file, then write the etag. That way, if any step fails, it will
          -- force the download to happen again.
          (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