{-# 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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 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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (Request -> ByteString
path Request
req0))
    let destFilePath :: FilePath
destFilePath = 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 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
      if Bool -> Bool
not Bool
exists
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                 forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
etagFilePath forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }
    forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a
recoveringHttp RetryPolicy
drRetryPolicyDefault forall a b. (a -> b) -> a -> b
$ forall env a. RIO env a -> RIO env a
catchingHttpExceptions forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req2 forall a b. (a -> b) -> a -> b
$ \Response (ConduitM () ByteString IO ())
res -> case forall a. Response a -> Int
getResponseStatusCode Response (ConduitM () ByteString IO ())
res of
        Int
200 -> do
          Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True 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.
          forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
etagFilePath

          forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious FilePath
destFilePath forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
            forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response (ConduitM () ByteString IO ())
res 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

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"ETag" (forall a. Response a -> RequestHeaders
getResponseHeaders Response (ConduitM () ByteString IO ())
res)) forall a b. (a -> b) -> a -> b
$ \ByteString
e ->
            forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious FilePath
etagFilePath forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
            forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
e 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

          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Int
304 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Int
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Request -> Path Abs File -> Response () -> DownloadException
RedownloadInvalidResponse Request
req2 Path Abs File
dest forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch RIO env a
action (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> DownloadException
RedownloadHttpError)

data DownloadException = RedownloadInvalidResponse Request (Path Abs File) (Response ())
                       | RedownloadHttpError HttpException
                       
    deriving (Int -> DownloadException -> FilePath -> FilePath
[DownloadException] -> FilePath -> FilePath
DownloadException -> FilePath
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