module Network.HTTP.Download
( verifiedDownload
, DownloadRequest(..)
, drRetryPolicyDefault
, HashCheck(..)
, DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
, download
, redownload
, downloadJSON
, parseUrl
, liftHTTP
, ask
, getHttpManager
, MonadReader
, HasHttpManager
) where
import Control.Exception (Exception)
import Control.Exception.Enclosed (handleIO)
import Control.Monad (void)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, ask,
runReaderT)
import Data.Aeson.Extended (FromJSON, parseJSON)
import Data.Aeson.Parser (json')
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Conduit (($$))
import Data.Conduit.Attoparsec (sinkParser)
import Data.Conduit.Binary (sinkHandle, sourceHandle)
import qualified Data.Conduit.Binary as CB
import Data.Foldable (forM_)
import Data.Typeable (Typeable)
import Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,
Response, checkStatus,
getHttpManager, parseUrl,
requestHeaders, responseBody,
responseHeaders, responseStatus,
withResponse)
import Network.HTTP.Download.Verified
import Network.HTTP.Types (status200, status304)
import Path (Abs, File, Path, toFilePath)
import System.Directory (createDirectoryIfMissing,
removeFile,
renameFile)
import System.FilePath (takeDirectory, (<.>))
import System.IO (IOMode (ReadMode),
IOMode (WriteMode),
withBinaryFile)
download :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> Request
-> Path Abs File
-> m Bool
download req destpath = do
let downloadReq = DownloadRequest
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
, drRetryPolicy = drRetryPolicyDefault
}
let progressHook _ = return ()
verifiedDownload downloadReq destpath progressHook
redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> Request
-> Path Abs File
-> m Bool
redownload req0 dest = do
let destFilePath = toFilePath dest
etagFilePath = destFilePath <.> "etag"
metag <- liftIO $ handleIO (const $ return Nothing) $ fmap Just $
withBinaryFile etagFilePath ReadMode $ \h ->
sourceHandle h $$ CB.take 512
let req1 =
case metag of
Nothing -> req0
Just etag -> req0
{ requestHeaders =
requestHeaders req0 ++
[("If-None-Match", L.toStrict etag)]
}
req2 = req1 { checkStatus = \_ _ _ -> Nothing }
env <- ask
liftIO $ flip runReaderT env $ withResponse req2 $ \res -> case () of
()
| responseStatus res == status200 -> liftIO $ do
createDirectoryIfMissing True $ takeDirectory destFilePath
handleIO (const $ return ()) $ removeFile etagFilePath
let destFilePathTmp = destFilePath <.> "tmp"
withBinaryFile destFilePathTmp WriteMode $ \h ->
responseBody res $$ sinkHandle h
renameFile destFilePathTmp destFilePath
forM_ (lookup "ETag" (responseHeaders res)) $ \e -> do
let tmp = etagFilePath <.> "tmp"
S.writeFile tmp e
renameFile tmp etagFilePath
return True
| responseStatus res == status304 -> return False
| otherwise -> throwM $ RedownloadFailed req2 dest $ void res
downloadJSON :: (FromJSON a, MonadReader env m, HasHttpManager env, MonadIO m, MonadThrow m)
=> Request
-> m a
downloadJSON req = do
val <- liftHTTP $ withResponse req $ \res ->
responseBody res $$ sinkParser json'
case parseEither parseJSON val of
Left e -> throwM $ DownloadJSONException req e
Right x -> return x
data DownloadException
= DownloadJSONException Request String
| RedownloadFailed Request (Path Abs File) (Response ())
deriving (Show, Typeable)
instance Exception DownloadException
liftHTTP :: (MonadIO m, MonadReader env m, HasHttpManager env)
=> ReaderT Manager IO a
-> m a
liftHTTP inner = do
env <- ask
liftIO $ runReaderT inner $ getHttpManager env