http-download 0.1.0.1 → 0.2.2.0
raw patch · 6 files changed
Files
- LICENSE +24/−24
- http-download.cabal +75/−77
- src/Network/HTTP/Download.hs +111/−110
- src/Network/HTTP/Download/Verified.hs +399/−344
- test/Network/HTTP/Download/VerifiedSpec.hs +149/−145
- test/Spec.hs +1/−1
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2015-2019, Stack contributors-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- * Neither the name of Stack nor the- names of its contributors may be used to endorse or promote products- derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2015-2023, Stack contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Stack nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
http-download.cabal view
@@ -1,77 +1,75 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.31.2.------ see: https://github.com/sol/hpack------ hash: 8b4f895c68c59d6ced8926b73292a062ce3b3f53859ca9b40d11c85f39e2fbf2--name: http-download-version: 0.1.0.1-synopsis: Verified downloads with retries-description: Higher level HTTP download APIs include verification of content and retries-category: Development-homepage: https://github.com/commercialhaskell/http-download#readme-bug-reports: https://github.com/commercialhaskell/http-download/issues-author: Michael Snoyman-maintainer: michael@snoyman.com-copyright: 2018-2019 FP Complete-license: BSD3-license-file: LICENSE-build-type: Simple--source-repository head- type: git- location: https://github.com/commercialhaskell/http-download--library- exposed-modules:- Network.HTTP.Download- Network.HTTP.Download.Verified- other-modules:- Paths_http_download- hs-source-dirs:- src/- build-depends:- base >=4.10 && <5- , base64-bytestring- , bytestring- , conduit- , conduit-extra- , cryptonite- , cryptonite-conduit- , directory- , exceptions- , filepath- , http-client- , http-conduit- , http-types- , memory- , path- , path-io- , retry- , rio- , rio-prettyprint- default-language: Haskell2010--test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- Network.HTTP.Download.VerifiedSpec- Paths_http_download- hs-source-dirs:- test- build-depends:- base >=4.10 && <5- , cryptonite- , hspec- , hspec-discover- , http-client- , http-download- , path- , path-io- , retry- , rio- , rio-prettyprint- default-language: Haskell2010+cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: http-download +version: 0.2.2.0 +synopsis: Verified downloads with retries +description: Higher level HTTP download APIs include verification of content and retries +category: Development +homepage: https://github.com/commercialhaskell/http-download#readme +bug-reports: https://github.com/commercialhaskell/http-download/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018-2023 FP Complete +license: BSD3 +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/commercialhaskell/http-download + +library + exposed-modules: + Network.HTTP.Download + Network.HTTP.Download.Verified + other-modules: + Paths_http_download + hs-source-dirs: + src/ + build-depends: + base >=4.10 && <5 + , base64-bytestring + , bytestring + , conduit + , conduit-extra + , crypton >=1.1.0 + , crypton-conduit >=0.3.0 + , directory + , exceptions + , filepath + , http-client + , http-conduit + , http-types + , path + , path-io + , ram + , retry + , rio + , rio-prettyprint + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Network.HTTP.Download.VerifiedSpec + Paths_http_download + hs-source-dirs: + test + build-depends: + base >=4.10 && <5 + , crypton >=1.1.0 + , hspec + , hspec-discover + , http-client + , http-download + , path + , path-io + , retry + , rio + , rio-prettyprint + default-language: Haskell2010
src/Network/HTTP/Download.hs view
@@ -1,110 +1,111 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.HTTP.Download- ( DownloadRequest(..)- , 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 req destpath = do- let downloadReq = DownloadRequest- { drRequest = req- , drHashChecks = []- , drLengthCheck = Nothing- , drRetryPolicy = drRetryPolicyDefault- }- let progressHook _ = return ()- verifiedDownload downloadReq destpath 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 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-- -- 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.- 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+{-# 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 req destpath = do + let downloadReq = mkDownloadRequest req + let progressHook _ = return () + verifiedDownload downloadReq destpath 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 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 + + -- 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. + 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
src/Network/HTTP/Download/Verified.hs view
@@ -1,344 +1,399 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}-module Network.HTTP.Download.Verified- ( verifiedDownload- , recoveringHttp- , DownloadRequest(..)- , drRetryPolicyDefault- , HashCheck(..)- , CheckHexDigest(..)- , LengthCheck- , VerifiedDownloadException(..)- ) where--import qualified Data.List as List-import qualified Data.ByteString.Base64 as B64-import Conduit (sinkHandle)-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL--import Control.Monad-import Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself-import Control.Retry (recovering,limitRetries,RetryPolicy,exponentialBackoff,RetryStatus(..))-import Crypto.Hash-import Crypto.Hash.Conduit (sinkHash)-import Data.ByteArray as Mem (convert)-import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))-import Data.ByteString.Char8 (readInteger)-import Data.Conduit-import Data.Conduit.Binary (sourceHandle)-import Data.Monoid (Sum(..))-import GHC.IO.Exception (IOException(..),IOErrorType(..))-import Network.HTTP.Client (Request, HttpException, getUri, path)-import Network.HTTP.Simple (getResponseHeaders, httpSink)-import Network.HTTP.Types (hContentLength, hContentMD5)-import Path-import RIO hiding (Handler)-import RIO.PrettyPrint-import qualified RIO.ByteString as ByteString-import qualified RIO.Text as Text-import System.Directory-import qualified System.FilePath as FP-import System.IO (openTempFileWithDefaultPermissions)---- | A request together with some checks to perform.-data DownloadRequest = DownloadRequest- { drRequest :: Request- , drHashChecks :: [HashCheck]- , drLengthCheck :: Maybe LengthCheck- , drRetryPolicy :: RetryPolicy- }---- | Default to retrying seven times with exponential backoff starting from--- one hundred milliseconds.------ This means the tries will occur after these delays if necessary:------ * 0.1s--- * 0.2s--- * 0.4s--- * 0.8s--- * 1.6s--- * 3.2s--- * 6.4s-drRetryPolicyDefault :: RetryPolicy-drRetryPolicyDefault = limitRetries 7 <> exponentialBackoff onehundredMilliseconds- where onehundredMilliseconds = 100000--data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck- { hashCheckAlgorithm :: a- , hashCheckHexDigest :: CheckHexDigest- }-deriving instance Show HashCheck--data CheckHexDigest- = CheckHexDigestString String- | CheckHexDigestByteString ByteString- | CheckHexDigestHeader ByteString- deriving Show-instance IsString CheckHexDigest where- fromString = CheckHexDigestString--type LengthCheck = Int---- | An exception regarding verification of a download.-data VerifiedDownloadException- = WrongContentLength- Request- Int -- expected- ByteString -- actual (as listed in the header)- | WrongStreamLength- Request- Int -- expected- Int -- actual- | WrongDigest- Request- String -- algorithm- CheckHexDigest -- expected- String -- actual (shown)- deriving (Typeable)-instance Show VerifiedDownloadException where- show (WrongContentLength req expected actual) =- "Download expectation failure: ContentLength header\n"- ++ "Expected: " ++ show expected ++ "\n"- ++ "Actual: " ++ displayByteString actual ++ "\n"- ++ "For: " ++ show (getUri req)- show (WrongStreamLength req expected actual) =- "Download expectation failure: download size\n"- ++ "Expected: " ++ show expected ++ "\n"- ++ "Actual: " ++ show actual ++ "\n"- ++ "For: " ++ show (getUri req)- show (WrongDigest req algo expected actual) =- "Download expectation failure: content hash (" ++ algo ++ ")\n"- ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"- ++ "Actual: " ++ actual ++ "\n"- ++ "For: " ++ show (getUri req)--instance Exception VerifiedDownloadException---- This exception is always caught and never thrown outside of this module.-data VerifyFileException- = WrongFileSize- Int -- expected- Integer -- actual (as listed by hFileSize)- deriving (Show, Typeable)-instance Exception VerifyFileException---- Show a ByteString that is known to be UTF8 encoded.-displayByteString :: ByteString -> String-displayByteString =- Text.unpack . Text.strip . decodeUtf8Lenient---- Show a CheckHexDigest in human-readable format.-displayCheckHexDigest :: CheckHexDigest -> String-displayCheckHexDigest (CheckHexDigestString s) = s ++ " (String)"-displayCheckHexDigest (CheckHexDigestByteString s) = displayByteString s ++ " (ByteString)"-displayCheckHexDigest (CheckHexDigestHeader h) =- show (B64.decodeLenient h) ++ " (Header. unencoded: " ++ show h ++ ")"----- | Make sure that the hash digest for a finite stream of bytes--- is as expected.------ Throws WrongDigest (VerifiedDownloadException)-sinkCheckHash :: MonadThrow m- => Request- -> HashCheck- -> ConduitM ByteString o m ()-sinkCheckHash req HashCheck{..} = do- digest <- sinkHashUsing hashCheckAlgorithm- let actualDigestString = show digest- let actualDigestHexByteString = Mem.convertToBase Mem.Base16 digest- let actualDigestBytes = Mem.convert digest-- let passedCheck = case hashCheckHexDigest of- CheckHexDigestString s -> s == actualDigestString- CheckHexDigestByteString b -> b == actualDigestHexByteString- CheckHexDigestHeader b -> B64.decodeLenient b == actualDigestHexByteString- || B64.decodeLenient b == actualDigestBytes- -- A hack to allow hackage tarballs to download.- -- They should really base64-encode their md5 header as per rfc2616#sec14.15.- -- https://github.com/commercialhaskell/stack/issues/240- || b == actualDigestHexByteString-- unless passedCheck $- throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString--assertLengthSink :: MonadThrow m- => Request- -> LengthCheck- -> ZipSink ByteString m ()-assertLengthSink req expectedStreamLength = ZipSink $ do- Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length)- when (actualStreamLength /= expectedStreamLength) $- throwM $ WrongStreamLength req expectedStreamLength actualStreamLength---- | A more explicitly type-guided sinkHash.-sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)-sinkHashUsing _ = sinkHash---- | Turns a list of hash checks into a ZipSink that checks all of them.-hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()-hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)---- 'Control.Retry.recovering' customized for HTTP failures-recoveringHttp :: forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a-recoveringHttp retryPolicy =- helper $ \run -> recovering retryPolicy (handlers run) . const- where- helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a- helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action)-- handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]- handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO]-- alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool- alwaysRetryHttp u rs _ = do- unliftIO u $- prettyWarn $ vcat- [ flow $ unwords- [ "Retry number"- , show (rsIterNumber rs)- , "after a total delay of"- , show (rsCumulativeDelay rs)- , "us"- ]- , flow $ unwords- [ "If you see this warning and stack fails to download,"- , "but running the command again solves the problem,"- , "please report here: https://github.com/commercialhaskell/stack/issues/3510"- , "Make sure to paste the output of 'stack --version'"- ]- ]- return True-- retrySomeIO :: Monad m => IOException -> m Bool- retrySomeIO e = return $ case ioe_type e of- -- hGetBuf: resource vanished (Connection reset by peer)- ResourceVanished -> True- -- conservatively exclude all others- _ -> False---- | Copied and extended version of Network.HTTP.Download.download.------ Has the following additional features:--- * Verifies that response content-length header (if present)--- matches expected length--- * Limits the download to (close to) the expected # of bytes--- * Verifies that the expected # bytes were downloaded (not too few)--- * Verifies md5 if response includes content-md5 header--- * Verifies the expected hashes------ Throws VerifiedDownloadException.--- Throws IOExceptions related to file system operations.--- Throws HttpException.-verifiedDownload- :: HasTerm env- => DownloadRequest- -> Path Abs File -- ^ destination- -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress- -> RIO env Bool -- ^ Whether a download was performed-verifiedDownload DownloadRequest{..} destpath progressSink = do- let req = drRequest- whenM' (liftIO getShouldDownload) $ do- logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req))- liftIO $ createDirectoryIfMissing True dir- withTempFileWithDefaultPermissions dir (FP.takeFileName fp) $ \fptmp htmp -> do- recoveringHttp drRetryPolicy $- httpSink req $ go (sinkHandle htmp)- hClose htmp- liftIO $ renameFile fptmp fp- where- whenM' mp m = do- p <- mp- if p then m >> return True else return False-- fp = toFilePath destpath- dir = toFilePath $ parent destpath-- getShouldDownload = do- fileExists <- doesFileExist fp- if fileExists- -- only download if file does not match expectations- then not <$> fileMatchesExpectations- -- or if it doesn't exist yet- else return True-- -- precondition: file exists- -- TODO: add logging- fileMatchesExpectations =- ((checkExpectations >> return True)- `catch` \(_ :: VerifyFileException) -> return False)- `catch` \(_ :: VerifiedDownloadException) -> return False-- checkExpectations = withBinaryFile fp ReadMode $ \h -> do- for_ drLengthCheck $ checkFileSizeExpectations h- runConduit- $ sourceHandle h- .| getZipSink (hashChecksToZipSink drRequest drHashChecks)-- -- doesn't move the handle- checkFileSizeExpectations h expectedFileSize = do- fileSizeInteger <- hFileSize h- when (fileSizeInteger > toInteger (maxBound :: Int)) $- throwM $ WrongFileSize expectedFileSize fileSizeInteger- let fileSize = fromInteger fileSizeInteger- when (fileSize /= expectedFileSize) $- throwM $ WrongFileSize expectedFileSize fileSizeInteger-- checkContentLengthHeader headers expectedContentLength =- case List.lookup hContentLength headers of- Just lengthBS -> do- let lengthStr = displayByteString lengthBS- when (lengthStr /= show expectedContentLength) $- throwM $ WrongContentLength drRequest expectedContentLength lengthBS- _ -> return ()-- go sink res = do- let headers = getResponseHeaders res- mcontentLength = do- hLength <- List.lookup hContentLength headers- (i,_) <- readInteger hLength- return i- for_ drLengthCheck $ checkContentLengthHeader headers- let hashChecks = (case List.lookup hContentMD5 headers of- Just md5BS ->- [ HashCheck- { hashCheckAlgorithm = MD5- , hashCheckHexDigest = CheckHexDigestHeader md5BS- }- ]- Nothing -> []- ) ++ drHashChecks-- maybe id (\len -> (CB.isolate len .|)) drLengthCheck- $ getZipSink- ( hashChecksToZipSink drRequest hashChecks- *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck- *> ZipSink sink- *> ZipSink (progressSink mcontentLength))------ | Like 'UnliftIO.Temporary.withTempFile', but the file is created with--- default file permissions, instead of read/write access only for the owner.-withTempFileWithDefaultPermissions- :: MonadUnliftIO m- => FilePath -- ^ Temp dir to create the file in.- -> String -- ^ File name template. See 'openTempFile'.- -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file.- -> m a-withTempFileWithDefaultPermissions tmpDir template action =- bracket- (liftIO (openTempFileWithDefaultPermissions tmpDir template))- (\(name, handle') -> liftIO (hClose handle' >> ignoringIOErrors (removeFile name)))- (uncurry action)- where- ignoringIOErrors = void. tryIO+{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +module Network.HTTP.Download.Verified + ( verifiedDownload + , recoveringHttp + , drRetryPolicyDefault + , HashCheck(..) + , CheckHexDigest(..) + , LengthCheck + , VerifiedDownloadException(..) + -- * DownloadRequest construction + , DownloadRequest + , mkDownloadRequest + , modifyRequest + , setHashChecks + , setLengthCheck + , setRetryPolicy + , setForceDownload + ) where + +import qualified Data.List as List +import qualified Data.ByteString.Base64 as B64 +import Conduit (sinkHandle) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +import Control.Monad +import Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself +import Control.Retry (recovering,limitRetries,RetryPolicy,exponentialBackoff,RetryStatus(..)) +import Crypto.Hash +import Crypto.Hash.Conduit (sinkHash) +import Data.ByteArray as Mem (convert) +import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) +import Data.ByteString.Char8 (readInteger) +import Data.Conduit +import Data.Conduit.Binary (sourceHandle) +import Data.Monoid (Sum(..)) +import GHC.IO.Exception (IOException(..),IOErrorType(..)) +import Network.HTTP.Client (Request, HttpException, getUri, path) +import Network.HTTP.Simple (getResponseHeaders, httpSink) +import Network.HTTP.Types (hContentLength, hContentMD5) +import Path +import RIO hiding (Handler) +import RIO.PrettyPrint +import qualified RIO.ByteString as ByteString +import qualified RIO.Text as Text +import System.Directory +import qualified System.FilePath as FP +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. +-- +-- This means the tries will occur after these delays if necessary: +-- +-- * 0.1s +-- * 0.2s +-- * 0.4s +-- * 0.8s +-- * 1.6s +-- * 3.2s +-- * 6.4s +drRetryPolicyDefault :: RetryPolicy +drRetryPolicyDefault = limitRetries 7 <> exponentialBackoff onehundredMilliseconds + where onehundredMilliseconds = 100000 + +data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck + { hashCheckAlgorithm :: a + , hashCheckHexDigest :: CheckHexDigest + } +deriving instance Show HashCheck + +data CheckHexDigest + = CheckHexDigestString String + | CheckHexDigestByteString ByteString + | CheckHexDigestHeader ByteString + deriving Show +instance IsString CheckHexDigest where + fromString = CheckHexDigestString + +type LengthCheck = Int + +-- | An exception regarding verification of a download. +data VerifiedDownloadException + = WrongContentLength + Request + Int -- expected + ByteString -- actual (as listed in the header) + | WrongStreamLength + Request + Int -- expected + Int -- actual + | WrongDigest + Request + String -- algorithm + CheckHexDigest -- expected + String -- actual (shown) + | DownloadHttpError + HttpException + deriving (Typeable) +instance Show VerifiedDownloadException where + show (WrongContentLength req expected actual) = + "Download expectation failure: ContentLength header\n" + ++ "Expected: " ++ show expected ++ "\n" + ++ "Actual: " ++ displayByteString actual ++ "\n" + ++ "For: " ++ show (getUri req) + show (WrongStreamLength req expected actual) = + "Download expectation failure: download size\n" + ++ "Expected: " ++ show expected ++ "\n" + ++ "Actual: " ++ show actual ++ "\n" + ++ "For: " ++ show (getUri req) + show (WrongDigest req algo expected actual) = + "Download expectation failure: content hash (" ++ algo ++ ")\n" + ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n" + ++ "Actual: " ++ actual ++ "\n" + ++ "For: " ++ show (getUri req) + show (DownloadHttpError exception) = + "Download expectation failure: " ++ show exception + +instance Exception VerifiedDownloadException + +-- This exception is always caught and never thrown outside of this module. +data VerifyFileException + = WrongFileSize + Int -- expected + Integer -- actual (as listed by hFileSize) + deriving (Show, Typeable) +instance Exception VerifyFileException + +-- Show a ByteString that is known to be UTF8 encoded. +displayByteString :: ByteString -> String +displayByteString = + Text.unpack . Text.strip . decodeUtf8Lenient + +-- Show a CheckHexDigest in human-readable format. +displayCheckHexDigest :: CheckHexDigest -> String +displayCheckHexDigest (CheckHexDigestString s) = s ++ " (String)" +displayCheckHexDigest (CheckHexDigestByteString s) = displayByteString s ++ " (ByteString)" +displayCheckHexDigest (CheckHexDigestHeader h) = + show (B64.decodeLenient h) ++ " (Header. unencoded: " ++ show h ++ ")" + + +-- | Make sure that the hash digest for a finite stream of bytes +-- is as expected. +-- +-- Throws WrongDigest (VerifiedDownloadException) +sinkCheckHash :: MonadThrow m + => Request + -> HashCheck + -> ConduitM ByteString o m () +sinkCheckHash req HashCheck{..} = do + digest <- sinkHashUsing hashCheckAlgorithm + let actualDigestString = show digest + let actualDigestHexByteString = Mem.convertToBase Mem.Base16 digest + let actualDigestBytes = Mem.convert digest + + let passedCheck = case hashCheckHexDigest of + CheckHexDigestString s -> s == actualDigestString + CheckHexDigestByteString b -> b == actualDigestHexByteString + CheckHexDigestHeader b -> B64.decodeLenient b == actualDigestHexByteString + || B64.decodeLenient b == actualDigestBytes + -- A hack to allow hackage tarballs to download. + -- They should really base64-encode their md5 header as per rfc2616#sec14.15. + -- https://github.com/commercialhaskell/stack/issues/240 + || b == actualDigestHexByteString + + unless passedCheck $ + throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString + +assertLengthSink :: MonadThrow m + => Request + -> LengthCheck + -> ZipSink ByteString m () +assertLengthSink req expectedStreamLength = ZipSink $ do + Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length) + when (actualStreamLength /= expectedStreamLength) $ + throwM $ WrongStreamLength req expectedStreamLength actualStreamLength + +-- | A more explicitly type-guided sinkHash. +sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a) +sinkHashUsing _ = sinkHash + +-- | Turns a list of hash checks into a ZipSink that checks all of them. +hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m () +hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req) + +-- 'Control.Retry.recovering' customized for HTTP failures +recoveringHttp :: forall env a. HasTerm env => RetryPolicy -> RIO env a -> RIO env a +recoveringHttp retryPolicy = + helper $ \run -> recovering retryPolicy (handlers run) . const + where + helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a + helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action) + + handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool] + handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO] + + alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool + alwaysRetryHttp u rs _ = do + unliftIO u $ + prettyWarn $ vcat + [ flow $ unwords + [ "Retry number" + , show (rsIterNumber rs) + , "after a total delay of" + , show (rsCumulativeDelay rs) + , "us" + ] + , flow $ unwords + [ "If you see this warning and stack fails to download," + , "but running the command again solves the problem," + , "please report here: https://github.com/commercialhaskell/stack/issues/3510" + , "Make sure to paste the output of 'stack --version'" + ] + ] + return True + + retrySomeIO :: Monad m => IOException -> m Bool + retrySomeIO e = return $ case ioe_type e of + -- hGetBuf: resource vanished (Connection reset by peer) + ResourceVanished -> True + -- conservatively exclude all others + _ -> False + +-- | Copied and extended version of Network.HTTP.Download.download. +-- +-- Has the following additional features: +-- * Verifies that response content-length header (if present) +-- matches expected length +-- * Limits the download to (close to) the expected # of bytes +-- * Verifies that the expected # bytes were downloaded (not too few) +-- * Verifies md5 if response includes content-md5 header +-- * Verifies the expected hashes +-- +-- Throws VerifiedDownloadException. +-- Throws IOExceptions related to file system operations. +-- Throws HttpException. +verifiedDownload + :: HasTerm env + => DownloadRequest + -> Path Abs File -- ^ destination + -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress + -> RIO env Bool -- ^ Whether a download was performed +verifiedDownload DownloadRequest{..} destpath progressSink = do + let req = drRequest + whenM' (liftIO getShouldDownload) $ do + logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req)) + liftIO $ createDirectoryIfMissing True dir + withTempFileWithDefaultPermissions dir (FP.takeFileName fp) $ \fptmp htmp -> do + recoveringHttp drRetryPolicy $ catchingHttpExceptions $ + httpSink req $ go (sinkHandle htmp) + hClose htmp + liftIO $ renameFile fptmp fp + where + whenM' mp m = do + p <- mp + if p then m >> return True else return False + + fp = toFilePath destpath + dir = toFilePath $ parent destpath + + getShouldDownload = if drForceDownload then return True else do + fileExists <- doesFileExist fp + if fileExists + -- only download if file does not match expectations + then not <$> fileMatchesExpectations + -- or if it doesn't exist yet + else return True + + -- precondition: file exists + -- TODO: add logging + fileMatchesExpectations = + ((checkExpectations >> return True) + `catch` \(_ :: VerifyFileException) -> return False) + `catch` \(_ :: VerifiedDownloadException) -> return False + + checkExpectations = withBinaryFile fp ReadMode $ \h -> do + for_ drLengthCheck $ checkFileSizeExpectations h + runConduit + $ sourceHandle h + .| getZipSink (hashChecksToZipSink drRequest drHashChecks) + + -- doesn't move the handle + checkFileSizeExpectations h expectedFileSize = do + fileSizeInteger <- hFileSize h + when (fileSizeInteger > toInteger (maxBound :: Int)) $ + throwM $ WrongFileSize expectedFileSize fileSizeInteger + let fileSize = fromInteger fileSizeInteger + when (fileSize /= expectedFileSize) $ + throwM $ WrongFileSize expectedFileSize fileSizeInteger + + checkContentLengthHeader headers expectedContentLength = + case List.lookup hContentLength headers of + Just lengthBS -> do + let lengthStr = displayByteString lengthBS + when (lengthStr /= show expectedContentLength) $ + throwM $ WrongContentLength drRequest expectedContentLength lengthBS + _ -> return () + + go sink res = do + let headers = getResponseHeaders res + mcontentLength = do + hLength <- List.lookup hContentLength headers + (i,_) <- readInteger hLength + return i + for_ drLengthCheck $ checkContentLengthHeader headers + let hashChecks = (case List.lookup hContentMD5 headers of + Just md5BS -> + [ HashCheck + { hashCheckAlgorithm = MD5 + , hashCheckHexDigest = CheckHexDigestHeader md5BS + } + ] + Nothing -> [] + ) ++ drHashChecks + + maybe id (\len -> (CB.isolate len .|)) drLengthCheck + $ getZipSink + ( hashChecksToZipSink drRequest hashChecks + *> 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 +-- default file permissions, instead of read/write access only for the owner. +withTempFileWithDefaultPermissions + :: MonadUnliftIO m + => FilePath -- ^ Temp dir to create the file in. + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file. + -> m a +withTempFileWithDefaultPermissions tmpDir template action = + bracket + (liftIO (openTempFileWithDefaultPermissions tmpDir template)) + (\(name, handle') -> liftIO (hClose handle' >> ignoringIOErrors (removeFile name))) + (uncurry action) + where + ignoringIOErrors = void. tryIO
test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -1,145 +1,149 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Network.HTTP.Download.VerifiedSpec (spec) where--import Control.Retry (limitRetries)-import Crypto.Hash-import Network.HTTP.Client-import Network.HTTP.Download.Verified-import Path-import Path.IO -- hiding (withSystemTempDir)-import System.IO (writeFile, readFile)-import RIO-import RIO.PrettyPrint-import RIO.PrettyPrint.StylesUpdate-import Test.Hspec---- TODO: share across test files-withTempDir' :: (Path Abs Dir -> IO a) -> IO a-withTempDir' = withSystemTempDir "NHD_VerifiedSpec"---- | An example path to download the exampleReq.-getExamplePath :: Path Abs Dir -> IO (Path Abs File)-getExamplePath dir = do- file <- parseRelFile "cabal-install-1.22.4.0.tar.gz"- return (dir </> file)---- | An example DownloadRequest that uses a SHA1-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- }--exampleHashCheck :: HashCheck-exampleHashCheck = HashCheck- { hashCheckAlgorithm = SHA1- , hashCheckHexDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec2"- }--exampleLengthCheck :: LengthCheck-exampleLengthCheck = 302513---- | The wrong ContentLength for exampleReq-exampleWrongContentLength :: Int-exampleWrongContentLength = 302512---- | The wrong SHA1 digest for exampleReq-exampleWrongDigest :: CheckHexDigest-exampleWrongDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec3"--exampleWrongContent :: String-exampleWrongContent = "example wrong content"--isWrongContentLength :: VerifiedDownloadException -> Bool-isWrongContentLength WrongContentLength{} = True-isWrongContentLength _ = False--isWrongDigest :: VerifiedDownloadException -> Bool-isWrongDigest WrongDigest{} = True-isWrongDigest _ = False--data TestTerm = TestTerm--instance HasLogFunc TestTerm where- -- ingoring output for now- logFuncL = lens (const $ mkLogFunc mempty) (\t _ -> t)--instance HasStylesUpdate TestTerm where- stylesUpdateL = lens (const $ StylesUpdate []) (\t _ -> t)--instance HasTerm TestTerm where- useColorL = lens (const False) (\t _ -> t)- termWidthL = lens (const 80) (\t _ -> t)--spec :: Spec-spec = do- let exampleProgressHook _ = return ()-- describe "verifiedDownload" $ do- let run func = runRIO TestTerm func- -- Preconditions:- -- * the exampleReq server is running- -- * the test runner has working internet access to it- it "downloads the file correctly" $ withTempDir' $ \dir -> do- examplePath <- getExamplePath dir- doesFileExist examplePath `shouldReturn` False- let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook- go `shouldReturn` True- doesFileExist examplePath `shouldReturn` True-- it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do- examplePath <- getExamplePath dir- doesFileExist examplePath `shouldReturn` False- let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook- go `shouldReturn` True- doesFileExist examplePath `shouldReturn` True- go `shouldReturn` False- doesFileExist examplePath `shouldReturn` True-- -- https://github.com/commercialhaskell/stack/issues/372- it "does redownload when the destination file is wrong" $ withTempDir' $ \dir -> do- examplePath <- getExamplePath dir- let exampleFilePath = toFilePath examplePath- writeFile exampleFilePath exampleWrongContent- doesFileExist examplePath `shouldReturn` True- readFile exampleFilePath `shouldReturn` exampleWrongContent- let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook- go `shouldReturn` True- doesFileExist examplePath `shouldReturn` True- readFile exampleFilePath `shouldNotReturn` exampleWrongContent-- it "rejects incorrect content length" $ withTempDir' $ \dir -> do- examplePath <- getExamplePath dir- let wrongContentLengthReq = exampleReq- { drLengthCheck = Just exampleWrongContentLength- }- let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook- go `shouldThrow` isWrongContentLength- doesFileExist examplePath `shouldReturn` False-- it "rejects incorrect digest" $ withTempDir' $ \dir -> do- examplePath <- getExamplePath dir- let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest }- let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] }- let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook- go `shouldThrow` isWrongDigest- doesFileExist examplePath `shouldReturn` False-- -- https://github.com/commercialhaskell/stack/issues/240- 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 go = run $ verifiedDownload dReq dest exampleProgressHook- doesFileExist dest `shouldReturn` False- go `shouldReturn` True- doesFileExist dest `shouldReturn` True+{-# LANGUAGE NoImplicitPrelude #-} +module Network.HTTP.Download.VerifiedSpec (spec) where + +import Control.Retry (limitRetries) +import Crypto.Hash +import Network.HTTP.Client +import Network.HTTP.Download.Verified +import Path +import Path.IO -- hiding (withSystemTempDir) +import System.IO (writeFile, readFile) +import RIO +import RIO.PrettyPrint +import RIO.PrettyPrint.StylesUpdate +import Test.Hspec + +-- TODO: share across test files +withTempDir' :: (Path Abs Dir -> IO a) -> IO a +withTempDir' = withSystemTempDir "NHD_VerifiedSpec" + +-- | An example path to download the exampleReq. +getExamplePath :: Path Abs Dir -> IO (Path Abs File) +getExamplePath dir = do + file <- parseRelFile "cabal-install-1.22.4.0.tar.gz" + return (dir </> file) + +-- | An example DownloadRequest that uses a SHA1 +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 $ + setHashChecks [exampleHashCheck] $ + setLengthCheck (Just exampleLengthCheck) $ + setRetryPolicy (limitRetries 1) $ + mkDownloadRequest req + +exampleHashCheck :: HashCheck +exampleHashCheck = HashCheck + { hashCheckAlgorithm = SHA1 + , hashCheckHexDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec2" + } + +exampleLengthCheck :: LengthCheck +exampleLengthCheck = 302513 + +-- | The wrong ContentLength for exampleReq +exampleWrongContentLength :: Int +exampleWrongContentLength = 302512 + +-- | The wrong SHA1 digest for exampleReq +exampleWrongDigest :: CheckHexDigest +exampleWrongDigest = CheckHexDigestString "b98eea96d321cdeed83a201c192dac116e786ec3" + +exampleWrongContent :: String +exampleWrongContent = "example wrong content" + +isWrongContentLength :: VerifiedDownloadException -> Bool +isWrongContentLength WrongContentLength{} = True +isWrongContentLength _ = False + +isWrongDigest :: VerifiedDownloadException -> Bool +isWrongDigest WrongDigest{} = True +isWrongDigest _ = False + +data TestTerm = TestTerm + +instance HasLogFunc TestTerm where + -- ingoring output for now + logFuncL = lens (const $ mkLogFunc mempty) (\t _ -> t) + +instance HasStylesUpdate TestTerm where + stylesUpdateL = lens (const $ StylesUpdate []) (\t _ -> t) + +instance HasTerm TestTerm where + useColorL = lens (const False) (\t _ -> t) + termWidthL = lens (const 80) (\t _ -> t) + +spec :: Spec +spec = do + let exampleProgressHook _ = return () + + describe "verifiedDownload" $ do + let run func = runRIO TestTerm func + -- Preconditions: + -- * the exampleReq server is running + -- * the test runner has working internet access to it + it "downloads the file correctly" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + doesFileExist examplePath `shouldReturn` False + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook + go `shouldReturn` True + doesFileExist examplePath `shouldReturn` True + + it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + doesFileExist examplePath `shouldReturn` False + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook + go `shouldReturn` True + doesFileExist examplePath `shouldReturn` True + go `shouldReturn` False + doesFileExist examplePath `shouldReturn` True + + -- https://github.com/commercialhaskell/stack/issues/372 + it "does redownload when the destination file is wrong" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + let exampleFilePath = toFilePath examplePath + writeFile exampleFilePath exampleWrongContent + doesFileExist examplePath `shouldReturn` True + readFile exampleFilePath `shouldReturn` exampleWrongContent + let go = run $ verifiedDownload exampleReq examplePath exampleProgressHook + go `shouldReturn` True + doesFileExist examplePath `shouldReturn` True + readFile exampleFilePath `shouldNotReturn` exampleWrongContent + + it "rejects incorrect content length" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + let wrongContentLengthReq = setLengthCheck (Just exampleWrongContentLength) exampleReq + let go = run $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook + go `shouldThrow` isWrongContentLength + doesFileExist examplePath `shouldReturn` False + + it "rejects incorrect digest" $ withTempDir' $ \dir -> do + examplePath <- getExamplePath dir + let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest } + let wrongDigestReq = setHashChecks [wrongHashCheck] exampleReq + let go = run $ verifiedDownload wrongDigestReq examplePath exampleProgressHook + go `shouldThrow` isWrongDigest + doesFileExist examplePath `shouldReturn` False + + -- https://github.com/commercialhaskell/stack/issues/240 + 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 = 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
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}