{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Download
( verifiedDownload
, DownloadRequest(..)
, drRetryPolicyDefault
, HashCheck(..)
, DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
, download
, redownload
, httpJSON
, httpLbs
, httpLBS
, parseRequest
, parseUrlThrow
, setGithubHeaders
, withResponse
) where
import Stack.Prelude
import Stack.Types.Runner
import qualified Data.ByteString.Lazy as L
import Data.Conduit (yield)
import qualified Data.Conduit.Binary as CB
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Encoding (decodeUtf8With)
import Network.HTTP.Download.Verified
import Network.HTTP.StackClient (Request, Response, HttpException, httpJSON, httpLbs, httpLBS, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode)
import Path.IO (doesFileExist)
import System.Directory (createDirectoryIfMissing,
removeFile)
import System.FilePath (takeDirectory, (<.>))
download :: HasRunner env
=> Request
-> Path Abs File
-> RIO env Bool
download req destpath = do
let downloadReq = DownloadRequest
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
, drRetryPolicy = drRetryPolicyDefault
}
let progressHook _ = return ()
verifiedDownload downloadReq destpath progressHook
redownload :: HasRunner env
=> Request
-> Path Abs File
-> RIO env Bool
redownload req0 dest = do
logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req0))
let destFilePath = toFilePath dest
etagFilePath = destFilePath <.> "etag"
metag <- do
exists <- doesFileExist dest
if not exists
then return Nothing
else liftIO $ handleIO (const $ return Nothing) $ fmap Just $
withSourceFile etagFilePath $ \src -> runConduit $ src .| CB.take 512
let req1 =
case metag of
Nothing -> req0
Just etag -> req0
{ requestHeaders =
requestHeaders req0 ++
[("If-None-Match", L.toStrict etag)]
}
req2 = req1 { checkResponse = \_ _ -> return () }
recoveringHttp drRetryPolicyDefault $ catchingHttpExceptions $ liftIO $
withResponse req2 $ \res -> case getResponseStatusCode res of
200 -> do
createDirectoryIfMissing True $ takeDirectory destFilePath
handleIO (const $ return ()) $ removeFile etagFilePath
withSinkFileCautious destFilePath $ \sink ->
runConduit $ getResponseBody res .| sink
forM_ (lookup "ETag" (getResponseHeaders res)) $ \e ->
withSinkFileCautious etagFilePath $ \sink ->
runConduit $ yield e .| sink
return True
304 -> return False
_ -> throwM $ RedownloadInvalidResponse req2 dest $ void res
where
catchingHttpExceptions :: RIO env a -> RIO env a
catchingHttpExceptions action = catch action (throwM . RedownloadHttpError)
data DownloadException = RedownloadInvalidResponse Request (Path Abs File) (Response ())
| RedownloadHttpError HttpException
deriving (Show, Typeable)
instance Exception DownloadException
setGithubHeaders :: Request -> Request
setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]