{-# 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 a. a -> m a
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 :: String
destFilePath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
dest
        etagFilePath :: String
etagFilePath = String
destFilePath String -> String -> String
<.> String
"etag"

    metag <- do
      exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
dest
      if not exists
        then return Nothing
        else liftIO $ handleIO (const $ return Nothing) $ fmap Just $
                 withSourceFile etagFilePath $ \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 =
            case Maybe ByteString
metag of
                Maybe ByteString
Nothing -> Request
req0
                Just ByteString
etag -> Request
req0
                    { requestHeaders =
                        requestHeaders req0 ++
                        [("If-None-Match", L.toStrict etag)]
                    }
        req2 = Request
req1 { checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
    recoveringHttp drRetryPolicyDefault $ catchingHttpExceptions $ liftIO $
      withResponse req2 $ \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 -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
etagFilePath

          String -> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious String
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 ->
            String -> (ConduitM ByteString Void IO () -> IO ()) -> IO ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious String
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Int
304 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Int
_ -> DownloadException -> IO Bool
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 -> String -> String
[DownloadException] -> String -> String
DownloadException -> String
(Int -> DownloadException -> String -> String)
-> (DownloadException -> String)
-> ([DownloadException] -> String -> String)
-> Show DownloadException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DownloadException -> String -> String
showsPrec :: Int -> DownloadException -> String -> String
$cshow :: DownloadException -> String
show :: DownloadException -> String
$cshowList :: [DownloadException] -> String -> String
showList :: [DownloadException] -> String -> String
Show, Typeable)
instance Exception DownloadException