-
Notifications
You must be signed in to change notification settings - Fork 844
/
Download.hs
116 lines (104 loc) · 4.67 KB
/
Download.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Download
( verifiedDownload
, DownloadRequest(..)
, drRetryPolicyDefault
, HashCheck(..)
, DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
, download
, redownload
, httpJSON
, parseRequest
, parseUrlThrow
, setGithubHeaders
) where
import Stack.Prelude
import Stack.Types.Runner
import qualified Data.ByteString.Lazy as L
import Data.Conduit (yield)
import Data.Conduit.Binary (sourceHandle)
import qualified Data.Conduit.Binary as CB
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Encoding (decodeUtf8With)
import Network.HTTP.Client (Request, Response, path, checkResponse, parseUrlThrow, parseRequest)
import Network.HTTP.Client.Conduit (requestHeaders)
import Network.HTTP.Download.Verified
import Network.HTTP.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode,
setRequestHeader)
import Path.IO (doesFileExist)
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 :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
=> Request
-> Path Abs File -- ^ destination
-> m 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 :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
=> Request
-> Path Abs File -- ^ destination
-> m Bool
redownload req0 dest = do
logDebug $ "Downloading " <> 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 $
withBinaryFile etagFilePath ReadMode $ \h ->
runConduit $ sourceHandle h .| 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 $ 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
runConduitRes $ getResponseBody res .| CB.sinkFileCautious destFilePath
forM_ (lookup "ETag" (getResponseHeaders res)) $ \e ->
runConduitRes $ yield e .| CB.sinkFileCautious etagFilePath
return True
304 -> return False
_ -> throwM $ RedownloadFailed req2 dest $ void res
data DownloadException = RedownloadFailed Request (Path Abs File) (Response ())
deriving (Show, Typeable)
instance Exception DownloadException
-- | Set the user-agent request header
setGithubHeaders :: Request -> Request
setGithubHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"]
. setRequestHeader "Accept" ["application/vnd.github.v3+json"]