diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/http-download.cabal b/http-download.cabal new file mode 100644 --- /dev/null +++ b/http-download.cabal @@ -0,0 +1,76 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b6a9c41e4facbc95bcb9ee81b15c8c682b88f638fa8df0382f9e4e54b6ab1629 + +name: http-download +version: 0.1.0.0 +synopsis: Verified downloads with retries +category: Development +homepage: https://github.com/commercialhaskell/stack#readme +bug-reports: https://github.com/commercialhaskell/stack/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/stack + +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 diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Download.hs @@ -0,0 +1,110 @@ +{-# 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 diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Download/Verified.hs @@ -0,0 +1,324 @@ +{-# 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 (withSinkFile) +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 ((<.>)) + +-- | 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 + recoveringHttp drRetryPolicy $ + withSinkFile fptmp $ httpSink req . go + liftIO $ renameFile fptmp fp + where + whenM' mp m = do + p <- mp + if p then m >> return True else return False + + fp = toFilePath destpath + fptmp = fp FP.<.> "tmp" + 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)) diff --git a/test/Network/HTTP/Download/VerifiedSpec.hs b/test/Network/HTTP/Download/VerifiedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Download/VerifiedSpec.hs @@ -0,0 +1,145 @@ +{-# 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}