diff --git a/http-download.cabal b/http-download.cabal --- a/http-download.cabal +++ b/http-download.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.32.0. -- -- see: https://github.com/sol/hpack -- --- hash: 8b4f895c68c59d6ced8926b73292a062ce3b3f53859ca9b40d11c85f39e2fbf2 +-- hash: 0eb36743b21d8003fc0ab6478ffc685d061b3c386bb35b293c1a50718a5fbd78 name: http-download -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Verified downloads with retries description: Higher level HTTP download APIs include verification of content and retries category: Development diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -2,7 +2,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Download - ( DownloadRequest(..) + ( DownloadRequest + , mkDownloadRequest + , modifyRequest + , setHashChecks + , setLengthCheck + , setRetryPolicy + , setForceDownload , drRetryPolicyDefault , HashCheck(..) , DownloadException(..) @@ -41,12 +47,7 @@ -> Path Abs File -- ^ destination -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? download req destpath = do - let downloadReq = DownloadRequest - { drRequest = req - , drHashChecks = [] - , drLengthCheck = Nothing - , drRetryPolicy = drRetryPolicyDefault - } + let downloadReq = mkDownloadRequest req let progressHook _ = return () verifiedDownload downloadReq destpath progressHook diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -10,12 +10,19 @@ module Network.HTTP.Download.Verified ( verifiedDownload , recoveringHttp - , DownloadRequest(..) , drRetryPolicyDefault , HashCheck(..) , CheckHexDigest(..) , LengthCheck , VerifiedDownloadException(..) + -- * DownloadRequest construction + , DownloadRequest + , mkDownloadRequest + , modifyRequest + , setHashChecks + , setLengthCheck + , setRetryPolicy + , setForceDownload ) where import qualified Data.List as List @@ -49,13 +56,56 @@ import System.IO (openTempFileWithDefaultPermissions) -- | A request together with some checks to perform. +-- +-- Construct using the 'downloadRequest' smart constructor and associated +-- setters. The constructor itself is not exposed to avoid breaking changes +-- with additional fields. +-- +-- @since 0.2.0.0 data DownloadRequest = DownloadRequest { drRequest :: Request , drHashChecks :: [HashCheck] , drLengthCheck :: Maybe LengthCheck , drRetryPolicy :: RetryPolicy + , drForceDownload :: Bool -- ^ whether to redownload or not if file exists } +-- | Construct a new 'DownloadRequest' from the given 'Request'. Use associated +-- setters to modify the value further. +-- +-- @since 0.2.0.0 +mkDownloadRequest :: Request -> DownloadRequest +mkDownloadRequest req = DownloadRequest req [] Nothing drRetryPolicyDefault False + +-- | Modify the 'Request' inside a 'DownloadRequest'. Especially intended for modifying the @User-Agent@ request header. +-- +-- @since 0.2.0.0 +modifyRequest :: (Request -> Request) -> DownloadRequest -> DownloadRequest +modifyRequest f dr = dr { drRequest = f $ drRequest dr } + +-- | Set the hash checks to be run when verifying. +-- +-- @since 0.2.0.0 +setHashChecks :: [HashCheck] -> DownloadRequest -> DownloadRequest +setHashChecks x dr = dr { drHashChecks = x } + +-- | Set the length check to be run when verifying. +-- +-- @since 0.2.0.0 +setLengthCheck :: Maybe LengthCheck -> DownloadRequest -> DownloadRequest +setLengthCheck x dr = dr { drLengthCheck = x } + +-- | Set the retry policy to be used when downloading. +-- +-- @since 0.2.0.0 +setRetryPolicy :: RetryPolicy -> DownloadRequest -> DownloadRequest +setRetryPolicy x dr = dr { drRetryPolicy = x } + +-- | If 'True', force download even if the file already exists. Useful for +-- download a resource which may change over time. +setForceDownload :: Bool -> DownloadRequest -> DownloadRequest +setForceDownload x dr = dr { drForceDownload = x } + -- | Default to retrying seven times with exponential backoff starting from -- one hundred milliseconds. -- @@ -103,6 +153,8 @@ String -- algorithm CheckHexDigest -- expected String -- actual (shown) + | DownloadHttpError + HttpException deriving (Typeable) instance Show VerifiedDownloadException where show (WrongContentLength req expected actual) = @@ -120,6 +172,8 @@ ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n" ++ "Actual: " ++ actual ++ "\n" ++ "For: " ++ show (getUri req) + show (DownloadHttpError exception) = + "Download expectation failure: " ++ show exception instance Exception VerifiedDownloadException @@ -251,7 +305,7 @@ logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req)) liftIO $ createDirectoryIfMissing True dir withTempFileWithDefaultPermissions dir (FP.takeFileName fp) $ \fptmp htmp -> do - recoveringHttp drRetryPolicy $ + recoveringHttp drRetryPolicy $ catchingHttpExceptions $ httpSink req $ go (sinkHandle htmp) hClose htmp liftIO $ renameFile fptmp fp @@ -263,7 +317,7 @@ fp = toFilePath destpath dir = toFilePath $ parent destpath - getShouldDownload = do + getShouldDownload = if drForceDownload then return True else do fileExists <- doesFileExist fp if fileExists -- only download if file does not match expectations @@ -324,7 +378,8 @@ *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck *> ZipSink sink *> ZipSink (progressSink mcontentLength)) - + catchingHttpExceptions :: RIO env a -> RIO env a + catchingHttpExceptions action = catch action (throwM . DownloadHttpError) -- | Like 'UnliftIO.Temporary.withTempFile', but the file is created with diff --git a/test/Network/HTTP/Download/VerifiedSpec.hs b/test/Network/HTTP/Download/VerifiedSpec.hs --- a/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/test/Network/HTTP/Download/VerifiedSpec.hs @@ -27,12 +27,11 @@ exampleReq :: DownloadRequest exampleReq = fromMaybe (error "exampleReq") $ do req <- parseRequest "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz" - return DownloadRequest - { drRequest = req - , drHashChecks = [exampleHashCheck] - , drLengthCheck = Just exampleLengthCheck - , drRetryPolicy = limitRetries 1 - } + return $ + setHashChecks [exampleHashCheck] $ + setLengthCheck (Just exampleLengthCheck) $ + setRetryPolicy (limitRetries 1) $ + mkDownloadRequest req exampleHashCheck :: HashCheck exampleHashCheck = HashCheck @@ -114,9 +113,7 @@ it "rejects incorrect content length" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir - let wrongContentLengthReq = exampleReq - { drLengthCheck = Just exampleWrongContentLength - } + let wrongContentLengthReq = setLengthCheck (Just exampleWrongContentLength) exampleReq let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook go `shouldThrow` isWrongContentLength doesFileExist examplePath `shouldReturn` False @@ -124,7 +121,7 @@ it "rejects incorrect digest" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest } - let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] } + let wrongDigestReq = setHashChecks [wrongHashCheck] exampleReq let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook go `shouldThrow` isWrongDigest doesFileExist examplePath `shouldReturn` False @@ -133,13 +130,20 @@ it "can download hackage tarballs" $ withTempDir' $ \dir -> do dest <- (dir ) <$> parseRelFile "acme-missiles-0.3.tar.gz" req <- parseRequest "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz" - let dReq = DownloadRequest - { drRequest = req - , drHashChecks = [] - , drLengthCheck = Nothing - , drRetryPolicy = limitRetries 1 - } + let dReq = setRetryPolicy (limitRetries 1) $ mkDownloadRequest req let go = run $ verifiedDownload dReq dest exampleProgressHook doesFileExist dest `shouldReturn` False go `shouldReturn` True doesFileExist dest `shouldReturn` True + + it "does redownload when forceDownload is True" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + doesFileExist examplePath `shouldReturn` False + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook + go `shouldReturn` True + doesFileExist examplePath `shouldReturn` True + + let forceReq = setForceDownload True exampleReq + let go' = run $ verifiedDownload forceReq examplePath exampleProgressHook + go' `shouldReturn` True + doesFileExist examplePath `shouldReturn` True