diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/http-download.cabal b/http-download.cabal --- a/http-download.cabal +++ b/http-download.cabal @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}