Skip to content

Commit 029230b

Browse files
qrilkaqrilka
committed
Split http-download
1 parent 7e26068 commit 029230b

12 files changed

Lines changed: 153 additions & 46 deletions

File tree

‎package.yaml‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -71,6 +71,7 @@ dependencies:
7171
- http-client
7272
- http-client-tls
7373
- http-conduit
74+
- http-download
7475
- http-types
7576
- memory
7677
- microlens
@@ -145,8 +146,6 @@ library:
145146
- Data.Attoparsec.Combinators
146147
- Data.Attoparsec.Interpreter
147148
- Data.Monoid.Map
148-
- Network.HTTP.Download
149-
- Network.HTTP.Download.Verified
150149
- Network.HTTP.StackClient
151150
- Options.Applicative.Args
152151
- Options.Applicative.Builder.Extra

‎src/Network/HTTP/StackClient.hs‎

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,15 @@ module Network.HTTP.StackClient
3939
, partFileRequestBody
4040
, partBS
4141
, partLBS
42+
, setGithubHeaders
43+
, download
44+
, redownload
45+
, verifiedDownload
46+
, CheckHexDigest (..)
47+
, DownloadRequest (..)
48+
, drRetryPolicyDefault
49+
, DownloadException (..)
50+
, HashCheck (..)
4251
) where
4352

4453
import Data.Aeson (FromJSON)
@@ -50,9 +59,13 @@ import Network.HTTP.Simple (setRequestMethod, setRequestBody, setReque
5059
import Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut)
5160
import Network.HTTP.Conduit (requestHeaders)
5261
import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException)
62+
import Network.HTTP.Download hiding (download, redownload, verifiedDownload)
63+
import qualified Network.HTTP.Download as Download
5364
import qualified Network.HTTP.Simple
5465
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS)
66+
import Path
5567
import RIO
68+
import RIO.PrettyPrint
5669

5770

5871
setUserAgent :: Request -> Request
@@ -83,3 +96,52 @@ withResponse
8396
:: (MonadUnliftIO m, MonadIO n)
8497
=> Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a
8598
withResponse = Network.HTTP.Simple.withResponse . setUserAgent
99+
100+
-- | Set the user-agent request header
101+
setGithubHeaders :: Request -> Request
102+
setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]
103+
104+
-- | Download the given URL to the given location. If the file already exists,
105+
-- no download is performed. Otherwise, creates the parent directory, downloads
106+
-- to a temporary file, and on file download completion moves to the
107+
-- appropriate destination.
108+
--
109+
-- Throws an exception if things go wrong
110+
download :: HasTerm env
111+
=> Request
112+
-> Path Abs File -- ^ destination
113+
-> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
114+
download req dest = Download.download (setUserAgent req) dest
115+
116+
-- | Same as 'download', but will download a file a second time if it is already present.
117+
--
118+
-- Returns 'True' if the file was downloaded, 'False' otherwise
119+
redownload :: HasTerm env
120+
=> Request
121+
-> Path Abs File -- ^ destination
122+
-> RIO env Bool
123+
redownload req dest = Download.redownload (setUserAgent req) dest
124+
125+
-- | Copied and extended version of Network.HTTP.Download.download.
126+
--
127+
-- Has the following additional features:
128+
-- * Verifies that response content-length header (if present)
129+
-- matches expected length
130+
-- * Limits the download to (close to) the expected # of bytes
131+
-- * Verifies that the expected # bytes were downloaded (not too few)
132+
-- * Verifies md5 if response includes content-md5 header
133+
-- * Verifies the expected hashes
134+
--
135+
-- Throws VerifiedDownloadException.
136+
-- Throws IOExceptions related to file system operations.
137+
-- Throws HttpException.
138+
verifiedDownload
139+
:: HasTerm env
140+
=> DownloadRequest
141+
-> Path Abs File -- ^ destination
142+
-> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress
143+
-> RIO env Bool -- ^ Whether a download was performed
144+
verifiedDownload dr destpath progressSink =
145+
Download.verifiedDownload dr' destpath progressSink
146+
where
147+
dr' = dr {drRequest = setUserAgent (drRequest dr)}

‎src/Stack/New.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,8 +29,9 @@ import qualified Data.Text.Encoding as T
2929
import qualified Data.Text.Lazy.Encoding as TLE
3030
import Data.Time.Calendar
3131
import Data.Time.Clock
32-
import Network.HTTP.Download
33-
import Network.HTTP.StackClient (Request, HttpException, getResponseStatusCode, getResponseBody)
32+
import Network.HTTP.StackClient (DownloadException (..), Request, HttpException,
33+
getResponseStatusCode, getResponseBody, httpLbs,
34+
parseRequest, parseUrlThrow, redownload, setGithubHeaders)
3435
import Path
3536
import Path.IO
3637
import Stack.Constants

‎src/Stack/Setup.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -66,8 +66,10 @@ import Distribution.Text (simpleParse)
6666
import Distribution.Types.PackageName (mkPackageName)
6767
import Distribution.Version (mkVersion)
6868
import Lens.Micro (set)
69-
import Network.HTTP.StackClient (getResponseBody, getResponseStatusCode)
70-
import Network.HTTP.Download
69+
import Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..),
70+
drRetryPolicyDefault, getResponseBody, getResponseStatusCode,
71+
httpLbs, httpJSON, parseRequest, parseUrlThrow, setGithubHeaders,
72+
verifiedDownload, withResponse)
7173
import Path
7274
import Path.CheckInstall (warnInstallSearchPathIssues)
7375
import Path.Extra (toFilePathNoTrailingSep)

‎src/Stack/Sig/Sign.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -23,8 +23,7 @@ import qualified Data.ByteString.Lazy as L
2323
import qualified Distribution.PackageDescription as D
2424
import qualified Distribution.PackageDescription.Parsec as D
2525
import qualified Distribution.Verbosity as D
26-
import Network.HTTP.Download
27-
import Network.HTTP.StackClient (RequestBody (RequestBodyBS), setRequestMethod, setRequestBody, getResponseStatusCode, methodPut)
26+
import Network.HTTP.StackClient (RequestBody (RequestBodyBS), httpLbs, parseUrlThrow, setRequestMethod, setRequestBody, getResponseStatusCode, methodPut)
2827
import Path
2928
import Stack.Sig.GPG
3029
import Stack.Types.Sig

‎src/Stack/SourceMap.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,8 +15,7 @@ module Stack.SourceMap
1515
import qualified Data.Conduit.List as CL
1616
import Data.Yaml (decodeFileThrow)
1717
import qualified Distribution.PackageDescription as PD
18-
import Network.HTTP.Download (download, redownload)
19-
import Network.HTTP.StackClient (parseRequest)
18+
import Network.HTTP.StackClient (download, parseRequest, redownload)
2019
import Pantry
2120
import qualified RIO
2221
import qualified RIO.Map as Map

‎stack.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ packages:
44
- .
55
- subs/pantry
66
- subs/curator
7+
- subs/http-download
78
- subs/rio-prettyprint
89

910
# docker:

‎subs/http-download/package.yaml‎

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
name: http-download
2+
version: 0.1.0.0
3+
synopsis: Verified downloads with retries
4+
category: Development
5+
author: Michael Snoyman
6+
maintainer: michael@snoyman.com
7+
copyright: 2018-2019 FP Complete
8+
license: MIT
9+
github: commercialhaskell/http-download # TODO move to this repo!
10+
11+
dependencies:
12+
- base
13+
- cryptonite
14+
- http-client
15+
- path
16+
- path-io
17+
- retry
18+
- rio
19+
- rio-prettyprint
20+
21+
library:
22+
source-dirs: src/
23+
dependencies:
24+
- base64-bytestring
25+
- bytestring
26+
- conduit
27+
- conduit-extra
28+
- cryptonite-conduit
29+
- directory
30+
- exceptions
31+
- filepath
32+
- http-conduit
33+
- http-types
34+
- memory
35+
36+
tests:
37+
spec:
38+
source-dirs: test
39+
main: Spec.hs
40+
dependencies:
41+
- http-download
42+
- hspec

src/Network/HTTP/Download.hs renamed to subs/http-download/src/Network/HTTP/Download.hs

Lines changed: 8 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,8 @@
11
{-# LANGUAGE NoImplicitPrelude #-}
22
{-# LANGUAGE DeriveDataTypeable #-}
3-
{-# LANGUAGE MultiParamTypeClasses #-}
43
{-# LANGUAGE OverloadedStrings #-}
54
module Network.HTTP.Download
6-
( verifiedDownload
7-
, DownloadRequest(..)
5+
( DownloadRequest(..)
86
, drRetryPolicyDefault
97
, HashCheck(..)
108
, DownloadException(..)
@@ -14,27 +12,22 @@ module Network.HTTP.Download
1412

1513
, download
1614
, redownload
17-
, httpJSON
18-
, httpLbs
19-
, parseRequest
20-
, parseUrlThrow
21-
, setGithubHeaders
22-
, withResponse
15+
, verifiedDownload
2316
) where
2417

25-
import Stack.Prelude
2618
import qualified Data.ByteString.Lazy as L
27-
import Conduit (yield, withSinkFileCautious, withSourceFile)
19+
import Conduit
2820
import qualified Data.Conduit.Binary as CB
29-
import Data.Text.Encoding.Error (lenientDecode)
30-
import Data.Text.Encoding (decodeUtf8With)
3121
import Network.HTTP.Download.Verified
32-
import Network.HTTP.StackClient (Request, Response, HttpException, httpJSON, httpLbs, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode)
22+
import Network.HTTP.Client (HttpException, Request, Response, checkResponse, path, requestHeaders)
23+
import Network.HTTP.Simple (getResponseBody, getResponseHeaders, getResponseStatusCode, withResponse)
24+
import Path (Path, Abs, File, toFilePath)
3325
import Path.IO (doesFileExist)
26+
import RIO
27+
import RIO.PrettyPrint
3428
import System.Directory (createDirectoryIfMissing,
3529
removeFile)
3630
import System.FilePath (takeDirectory, (<.>))
37-
import RIO.PrettyPrint
3831

3932

4033
-- | Download the given URL to the given location. If the file already exists,
@@ -115,7 +108,3 @@ data DownloadException = RedownloadInvalidResponse Request (Path Abs File) (Resp
115108

116109
deriving (Show, Typeable)
117110
instance Exception DownloadException
118-
119-
-- | Set the user-agent request header
120-
setGithubHeaders :: Request -> Request
121-
setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"]

src/Network/HTTP/Download/Verified.hs renamed to subs/http-download/src/Network/HTTP/Download/Verified.hs

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -19,17 +19,13 @@ module Network.HTTP.Download.Verified
1919
) where
2020

2121
import qualified Data.List as List
22-
import qualified Data.ByteString as ByteString
2322
import qualified Data.ByteString.Base64 as B64
2423
import Conduit (withSinkFile)
2524
import qualified Data.Conduit.Binary as CB
2625
import qualified Data.Conduit.List as CL
27-
import qualified Data.Text as Text
28-
import qualified Data.Text.Encoding as Text
2926

3027
import Control.Monad
3128
import Control.Monad.Catch (Handler (..)) -- would be nice if retry exported this itself
32-
import Stack.Prelude hiding (Handler (..))
3329
import Control.Retry (recovering,limitRetries,RetryPolicy,exponentialBackoff,RetryStatus(..))
3430
import Crypto.Hash
3531
import Crypto.Hash.Conduit (sinkHash)
@@ -38,12 +34,16 @@ import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
3834
import Data.ByteString.Char8 (readInteger)
3935
import Data.Conduit
4036
import Data.Conduit.Binary (sourceHandle)
41-
import Data.Text.Encoding (decodeUtf8With)
42-
import Data.Text.Encoding.Error (lenientDecode)
37+
import Data.Monoid (Sum(..))
4338
import GHC.IO.Exception (IOException(..),IOErrorType(..))
44-
import Network.HTTP.StackClient (Request, HttpException, httpSink, getUri, path, getResponseHeaders, hContentLength, hContentMD5)
39+
import Network.HTTP.Client (Request, HttpException, getUri, path)
40+
import Network.HTTP.Simple (getResponseHeaders, httpSink)
41+
import Network.HTTP.Types (hContentLength, hContentMD5)
4542
import Path
43+
import RIO hiding (Handler)
4644
import RIO.PrettyPrint
45+
import qualified RIO.ByteString as ByteString
46+
import qualified RIO.Text as Text
4747
import System.Directory
4848
import qualified System.FilePath as FP ((<.>))
4949

@@ -133,7 +133,7 @@ instance Exception VerifyFileException
133133
-- Show a ByteString that is known to be UTF8 encoded.
134134
displayByteString :: ByteString -> String
135135
displayByteString =
136-
Text.unpack . Text.strip . Text.decodeUtf8
136+
Text.unpack . Text.strip . decodeUtf8Lenient
137137

138138
-- Show a CheckHexDigest in human-readable format.
139139
displayCheckHexDigest :: CheckHexDigest -> String
@@ -247,7 +247,7 @@ verifiedDownload
247247
verifiedDownload DownloadRequest{..} destpath progressSink = do
248248
let req = drRequest
249249
whenM' (liftIO getShouldDownload) $ do
250-
logDebug $ "Downloading " <> Stack.Prelude.display (decodeUtf8With lenientDecode (path req))
250+
logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req))
251251
liftIO $ createDirectoryIfMissing True dir
252252
recoveringHttp drRetryPolicy $
253253
withSinkFile fptmp $ httpSink req . go

0 commit comments

Comments
 (0)