never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3 -----------------------------------------------------------------------------
4 -- | Separate module for HTTP actions, using a proxy server if one exists.
5 -----------------------------------------------------------------------------
6 module Distribution.Client.HttpUtils (
7 DownloadResult(..),
8 configureTransport,
9 HttpTransport(..),
10 HttpCode,
11 downloadURI,
12 transportCheckHttps,
13 remoteRepoCheckHttps,
14 remoteRepoTryUpgradeToHttps,
15 isOldHackageURI
16 ) where
17
18 import Prelude ()
19 import Distribution.Client.Compat.Prelude hiding (Proxy (..))
20 import Distribution.Utils.Generic
21
22 import Network.HTTP
23 ( Request (..), Response (..), RequestMethod (..)
24 , Header(..), HeaderName(..), lookupHeader )
25 import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
26 import Network.URI
27 ( URI (..), URIAuth (..), uriToString )
28 import Network.Browser
29 ( browse, setOutHandler, setErrHandler, setProxy
30 , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )
31 import qualified Control.Exception as Exception
32 import Distribution.Simple.Utils
33 ( die', info, warn, debug, notice
34 , copyFileVerbose, withTempFile, IOData (..) )
35 import Distribution.Client.Utils
36 ( withTempFileName, cabalInstallVersion )
37 import Distribution.Client.Types
38 ( unRepoName, RemoteRepo(..) )
39 import Distribution.System
40 ( buildOS, buildArch )
41 import qualified System.FilePath.Posix as FilePath.Posix
42 ( splitDirectories )
43 import System.FilePath
44 ( (<.>), takeFileName, takeDirectory )
45 import System.Directory
46 ( doesFileExist, renameFile, canonicalizePath )
47 import System.IO
48 ( withFile, IOMode(ReadMode), hGetContents, hClose )
49 import System.IO.Error
50 ( isDoesNotExistError )
51 import Distribution.Simple.Program
52 ( Program, simpleProgram, ConfiguredProgram, programPath
53 , ProgramInvocation(..), programInvocation
54 , ProgramSearchPathEntry(..)
55 , getProgramInvocationOutput )
56 import Distribution.Simple.Program.Db
57 ( ProgramDb, emptyProgramDb, addKnownPrograms
58 , configureAllKnownPrograms
59 , requireProgram, lookupProgram
60 , modifyProgramSearchPath )
61 import Distribution.Simple.Program.Run
62 ( getProgramInvocationOutputAndErrors )
63 import Numeric (showHex)
64 import System.Random (randomRIO)
65
66 import qualified Crypto.Hash.SHA256 as SHA256
67 import qualified Data.ByteString.Base16 as Base16
68 import qualified Distribution.Compat.CharParsing as P
69 import qualified Data.ByteString as BS
70 import qualified Data.ByteString.Char8 as BS8
71 import qualified Data.ByteString.Lazy as LBS
72 import qualified Data.ByteString.Lazy.Char8 as LBS8
73
74 ------------------------------------------------------------------------------
75 -- Downloading a URI, given an HttpTransport
76 --
77
78 data DownloadResult = FileAlreadyInCache
79 | FileDownloaded FilePath
80 deriving (Eq)
81
82 data DownloadCheck
83 = Downloaded -- ^ already downloaded and sha256 matches
84 | CheckETag String -- ^ already downloaded and we have etag
85 | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check
86 deriving Eq
87
88 downloadURI :: HttpTransport
89 -> Verbosity
90 -> URI -- ^ What to download
91 -> FilePath -- ^ Where to put it
92 -> IO DownloadResult
93 downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do
94 copyFileVerbose verbosity (uriPath uri) path
95 return (FileDownloaded path)
96 -- Can we store the hash of the file so we can safely return path when the
97 -- hash matches to avoid unnecessary computation?
98
99 downloadURI transport verbosity uri path = do
100
101 targetExists <- doesFileExist path
102
103 downloadCheck <-
104 -- if we have uriFrag, then we expect there to be #sha256=...
105 if not (null uriFrag)
106 then case sha256parsed of
107 -- we know the hash, and target exists
108 Right expected | targetExists -> do
109 contents <- LBS.readFile path
110 let actual = SHA256.hashlazy contents
111 if expected == actual
112 then return Downloaded
113 else return (NeedsDownload (Just expected))
114
115 -- we known the hash, target doesn't exist
116 Right expected -> return (NeedsDownload (Just expected))
117
118 -- we failed to parse uriFragment
119 Left err -> die' verbosity $
120 "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err
121
122 -- if there are no uri fragment, use ETag
123 else do
124 etagPathExists <- doesFileExist etagPath
125 -- In rare cases the target file doesn't exist, but the etag does.
126 if targetExists && etagPathExists
127 then return (CheckETag etagPath)
128 else return (NeedsDownload Nothing)
129
130 -- Only use the external http transports if we actually have to
131 -- (or have been told to do so)
132 let transport'
133 | uriScheme uri == "http:"
134 , not (transportManuallySelected transport)
135 = plainHttpTransport
136
137 | otherwise
138 = transport
139
140 case downloadCheck of
141 Downloaded -> return FileAlreadyInCache
142 CheckETag etag -> makeDownload transport' Nothing (Just etag)
143 NeedsDownload hash -> makeDownload transport' hash Nothing
144
145 where
146 makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do
147 result <- getHttp transport' verbosity uri etag tmpFile []
148
149 -- Only write the etag if we get a 200 response code.
150 -- A 304 still sends us an etag header.
151 case result of
152 -- if we have hash, we don't care about etag.
153 (200, _) | Just expected <- sha256 -> do
154 contents <- LBS.readFile tmpFile
155 let actual = SHA256.hashlazy contents
156 unless (actual == expected) $
157 die' verbosity $ unwords
158 [ "Failed to download", show uri
159 , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)
160 , "actual:", BS8.unpack (Base16.encode actual)
161 ]
162
163 (200, Just newEtag) -> writeFile etagPath newEtag
164 _ -> return ()
165
166 case fst result of
167 200 -> do
168 info verbosity ("Downloaded to " ++ path)
169 renameFile tmpFile path
170 return (FileDownloaded path)
171 304 -> do
172 notice verbosity "Skipping download: local and remote files match."
173 return FileAlreadyInCache
174 errCode -> die' verbosity $ "failed to download " ++ show uri
175 ++ " : HTTP code " ++ show errCode
176
177 etagPath = path <.> "etag"
178 uriFrag = uriFragment uri
179
180 sha256parsed :: Either String BS.ByteString
181 sha256parsed = explicitEitherParsec fragmentParser uriFrag
182
183 fragmentParser = do
184 _ <- P.string "#sha256="
185 str <- some P.hexDigit
186 let bs = Base16.decode (BS8.pack str)
187 #if MIN_VERSION_base16_bytestring(1,0,0)
188 either fail return bs
189 #else
190 return (fst bs)
191 #endif
192
193 ------------------------------------------------------------------------------
194 -- Utilities for repo url management
195 --
196
197 remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
198 remoteRepoCheckHttps verbosity transport repo
199 | uriScheme (remoteRepoURI repo) == "https:"
200 , not (transportSupportsHttps transport)
201 = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)
202 ++ "' specifies a URL that " ++ requiresHttpsErrorMessage
203 | otherwise = return ()
204
205 transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
206 transportCheckHttps verbosity transport uri
207 | uriScheme uri == "https:"
208 , not (transportSupportsHttps transport)
209 = die' verbosity $ "The URL " ++ show uri
210 ++ " " ++ requiresHttpsErrorMessage
211 | otherwise = return ()
212
213 requiresHttpsErrorMessage :: String
214 requiresHttpsErrorMessage =
215 "requires HTTPS however the built-in HTTP implementation "
216 ++ "does not support HTTPS. The transport implementations with HTTPS "
217 ++ "support are " ++ intercalate ", "
218 [ name | (name, _, True, _ ) <- supportedTransports ]
219 ++ ". One of these will be selected automatically if the corresponding "
220 ++ "external program is available, or one can be selected specifically "
221 ++ "with the global flag --http-transport="
222
223 remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
224 remoteRepoTryUpgradeToHttps verbosity transport repo
225 | remoteRepoShouldTryHttps repo
226 , uriScheme (remoteRepoURI repo) == "http:"
227 , not (transportSupportsHttps transport)
228 , not (transportManuallySelected transport)
229 = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using "
230 ++ "HTTPS for authenticated uploads is recommended. "
231 ++ "The transport implementations with HTTPS support are "
232 ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]
233 ++ "but they require the corresponding external program to be "
234 ++ "available. You can either make one available or use plain HTTP by "
235 ++ "using the global flag --http-transport=plain-http (or putting the "
236 ++ "equivalent in the config file). With plain HTTP, your password "
237 ++ "is sent using HTTP digest authentication so it cannot be easily "
238 ++ "intercepted, but it is not as secure as using HTTPS."
239
240 | remoteRepoShouldTryHttps repo
241 , uriScheme (remoteRepoURI repo) == "http:"
242 , transportSupportsHttps transport
243 = return repo {
244 remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }
245 }
246
247 | otherwise
248 = return repo
249
250 -- | Utility function for legacy support.
251 isOldHackageURI :: URI -> Bool
252 isOldHackageURI uri
253 = case uriAuthority uri of
254 Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->
255 FilePath.Posix.splitDirectories (uriPath uri)
256 == ["/","packages","archive"]
257 _ -> False
258
259
260 ------------------------------------------------------------------------------
261 -- Setting up a HttpTransport
262 --
263
264 data HttpTransport = HttpTransport {
265 -- | GET a URI, with an optional ETag (to do a conditional fetch),
266 -- write the resource to the given file and return the HTTP status code,
267 -- and optional ETag.
268 getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
269 -> IO (HttpCode, Maybe ETag),
270
271 -- | POST a resource to a URI, with optional auth (username, password)
272 -- and return the HTTP status code and any redirect URL.
273 postHttp :: Verbosity -> URI -> String -> Maybe Auth
274 -> IO (HttpCode, String),
275
276 -- | POST a file resource to a URI using multipart\/form-data encoding,
277 -- with optional auth (username, password) and return the HTTP status
278 -- code and any error string.
279 postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
280 -> IO (HttpCode, String),
281
282 -- | PUT a file resource to a URI, with optional auth
283 -- (username, password), extra headers and return the HTTP status code
284 -- and any error string.
285 putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]
286 -> IO (HttpCode, String),
287
288 -- | Whether this transport supports https or just http.
289 transportSupportsHttps :: Bool,
290
291 -- | Whether this transport implementation was specifically chosen by
292 -- the user via configuration, or whether it was automatically selected.
293 -- Strictly speaking this is not a property of the transport itself but
294 -- about how it was chosen. Nevertheless it's convenient to keep here.
295 transportManuallySelected :: Bool
296 }
297 --TODO: why does postHttp return a redirect, but postHttpFile return errors?
298
299 type HttpCode = Int
300 type ETag = String
301 type Auth = (String, String)
302
303 noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)
304 -> IO (Int, String)
305 noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"
306
307 supportedTransports :: [(String, Maybe Program, Bool,
308 ProgramDb -> Maybe HttpTransport)]
309 supportedTransports =
310 [ let prog = simpleProgram "curl" in
311 ( "curl", Just prog, True
312 , \db -> curlTransport <$> lookupProgram prog db )
313
314 , let prog = simpleProgram "wget" in
315 ( "wget", Just prog, True
316 , \db -> wgetTransport <$> lookupProgram prog db )
317
318 , let prog = simpleProgram "powershell" in
319 ( "powershell", Just prog, True
320 , \db -> powershellTransport <$> lookupProgram prog db )
321
322 , ( "plain-http", Nothing, False
323 , \_ -> Just plainHttpTransport )
324 ]
325
326 configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport
327
328 configureTransport verbosity extraPath (Just name) =
329 -- the user specifically selected a transport by name so we'll try and
330 -- configure that one
331
332 case find (\(name',_,_,_) -> name' == name) supportedTransports of
333 Just (_, mprog, _tls, mkTrans) -> do
334
335 let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
336 progdb <- case mprog of
337 Nothing -> return emptyProgramDb
338 Just prog -> snd <$> requireProgram verbosity prog baseProgDb
339 -- ^^ if it fails, it'll fail here
340
341 let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
342 return transport { transportManuallySelected = True }
343
344 Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name
345 ++ ". The supported transports are "
346 ++ intercalate ", "
347 [ name' | (name', _, _, _ ) <- supportedTransports ]
348
349 configureTransport verbosity extraPath Nothing = do
350 -- the user hasn't selected a transport, so we'll pick the first one we
351 -- can configure successfully, provided that it supports tls
352
353 -- for all the transports except plain-http we need to try and find
354 -- their external executable
355 let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
356 progdb <- configureAllKnownPrograms verbosity $
357 addKnownPrograms
358 [ prog | (_, Just prog, _, _) <- supportedTransports ]
359 baseProgDb
360
361 let availableTransports =
362 [ (name, transport)
363 | (name, _, _, mkTrans) <- supportedTransports
364 , transport <- maybeToList (mkTrans progdb) ]
365 let (name, transport) =
366 fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)
367 debug verbosity $ "Selected http transport implementation: " ++ name
368
369 return transport { transportManuallySelected = False }
370
371
372 ------------------------------------------------------------------------------
373 -- The HttpTransports based on external programs
374 --
375
376 curlTransport :: ConfiguredProgram -> HttpTransport
377 curlTransport prog =
378 HttpTransport gethttp posthttp posthttpfile puthttpfile True False
379 where
380 gethttp verbosity uri etag destPath reqHeaders = do
381 withTempFile (takeDirectory destPath)
382 "curl-headers.txt" $ \tmpFile tmpHandle -> do
383 hClose tmpHandle
384 let args = [ show uri
385 , "--output", destPath
386 , "--location"
387 , "--write-out", "%{http_code}"
388 , "--user-agent", userAgent
389 , "--silent", "--show-error"
390 , "--dump-header", tmpFile ]
391 ++ concat
392 [ ["--header", "If-None-Match: " ++ t]
393 | t <- maybeToList etag ]
394 ++ concat
395 [ ["--header", show name ++ ": " ++ value]
396 | Header name value <- reqHeaders ]
397
398 resp <- getProgramInvocationOutput verbosity
399 (programInvocation prog args)
400 withFile tmpFile ReadMode $ \hnd -> do
401 headers <- hGetContents hnd
402 (code, _err, etag') <- parseResponse verbosity uri resp headers
403 evaluate $ force (code, etag')
404
405 posthttp = noPostYet
406
407 addAuthConfig auth progInvocation = progInvocation
408 { progInvokeInput = do
409 (uname, passwd) <- auth
410 return $ IODataText $ unlines
411 [ "--digest"
412 , "--user " ++ uname ++ ":" ++ passwd
413 ]
414 , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
415 }
416
417 posthttpfile verbosity uri path auth = do
418 let args = [ show uri
419 , "--form", "package=@"++path
420 , "--write-out", "\n%{http_code}"
421 , "--user-agent", userAgent
422 , "--silent", "--show-error"
423 , "--header", "Accept: text/plain"
424 , "--location"
425 ]
426 resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
427 (programInvocation prog args)
428 (code, err, _etag) <- parseResponse verbosity uri resp ""
429 return (code, err)
430
431 puthttpfile verbosity uri path auth headers = do
432 let args = [ show uri
433 , "--request", "PUT", "--data-binary", "@"++path
434 , "--write-out", "\n%{http_code}"
435 , "--user-agent", userAgent
436 , "--silent", "--show-error"
437 , "--location"
438 , "--header", "Accept: text/plain"
439 ]
440 ++ concat
441 [ ["--header", show name ++ ": " ++ value]
442 | Header name value <- headers ]
443 resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
444 (programInvocation prog args)
445 (code, err, _etag) <- parseResponse verbosity uri resp ""
446 return (code, err)
447
448 -- on success these curl invocations produces an output like "200"
449 -- and on failure it has the server error response first
450 parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)
451 parseResponse verbosity uri resp headers =
452 let codeerr =
453 case reverse (lines resp) of
454 (codeLine:rerrLines) ->
455 case readMaybe (trim codeLine) of
456 Just i -> let errstr = mkErrstr rerrLines
457 in Just (i, errstr)
458 Nothing -> Nothing
459 [] -> Nothing
460
461 mkErrstr = unlines . reverse . dropWhile (all isSpace)
462
463 mb_etag :: Maybe ETag
464 mb_etag = listToMaybe $ reverse
465 [ etag
466 | ["ETag:", etag] <- map words (lines headers) ]
467
468 in case codeerr of
469 Just (i, err) -> return (i, err, mb_etag)
470 _ -> statusParseFail verbosity uri resp
471
472
473 wgetTransport :: ConfiguredProgram -> HttpTransport
474 wgetTransport prog =
475 HttpTransport gethttp posthttp posthttpfile puthttpfile True False
476 where
477 gethttp verbosity uri etag destPath reqHeaders = do
478 resp <- runWGet verbosity uri args
479
480 -- wget doesn't support range requests.
481 -- so, we not only ignore range request headers,
482 -- but we also dispay a warning message when we see them.
483 let hasRangeHeader = any isRangeHeader reqHeaders
484 warningMsg = "the 'wget' transport currently doesn't support"
485 ++ " range requests, which wastes network bandwidth."
486 ++ " To fix this, set 'http-transport' to 'curl' or"
487 ++ " 'plain-http' in '~/.cabal/config'."
488 ++ " Note that the 'plain-http' transport doesn't"
489 ++ " support HTTPS.\n"
490
491 when (hasRangeHeader) $ warn verbosity warningMsg
492 (code, etag') <- parseOutput verbosity uri resp
493 return (code, etag')
494 where
495 args = [ "--output-document=" ++ destPath
496 , "--user-agent=" ++ userAgent
497 , "--tries=5"
498 , "--timeout=15"
499 , "--server-response" ]
500 ++ concat
501 [ ["--header", "If-None-Match: " ++ t]
502 | t <- maybeToList etag ]
503 ++ [ "--header=" ++ show name ++ ": " ++ value
504 | hdr@(Header name value) <- reqHeaders
505 , (not (isRangeHeader hdr)) ]
506
507 -- wget doesn't support range requests.
508 -- so, we ignore range request headers, lest we get errors.
509 isRangeHeader :: Header -> Bool
510 isRangeHeader (Header HdrRange _) = True
511 isRangeHeader _ = False
512
513 posthttp = noPostYet
514
515 posthttpfile verbosity uri path auth =
516 withTempFile (takeDirectory path)
517 (takeFileName path) $ \tmpFile tmpHandle ->
518 withTempFile (takeDirectory path) "response" $
519 \responseFile responseHandle -> do
520 hClose responseHandle
521 (body, boundary) <- generateMultipartBody path
522 LBS.hPut tmpHandle body
523 hClose tmpHandle
524 let args = [ "--post-file=" ++ tmpFile
525 , "--user-agent=" ++ userAgent
526 , "--server-response"
527 , "--output-document=" ++ responseFile
528 , "--header=Accept: text/plain"
529 , "--header=Content-type: multipart/form-data; " ++
530 "boundary=" ++ boundary ]
531 out <- runWGet verbosity (addUriAuth auth uri) args
532 (code, _etag) <- parseOutput verbosity uri out
533 withFile responseFile ReadMode $ \hnd -> do
534 resp <- hGetContents hnd
535 evaluate $ force (code, resp)
536
537 puthttpfile verbosity uri path auth headers =
538 withTempFile (takeDirectory path) "response" $
539 \responseFile responseHandle -> do
540 hClose responseHandle
541 let args = [ "--method=PUT", "--body-file="++path
542 , "--user-agent=" ++ userAgent
543 , "--server-response"
544 , "--output-document=" ++ responseFile
545 , "--header=Accept: text/plain" ]
546 ++ [ "--header=" ++ show name ++ ": " ++ value
547 | Header name value <- headers ]
548
549 out <- runWGet verbosity (addUriAuth auth uri) args
550 (code, _etag) <- parseOutput verbosity uri out
551 withFile responseFile ReadMode $ \hnd -> do
552 resp <- hGetContents hnd
553 evaluate $ force (code, resp)
554
555 addUriAuth Nothing uri = uri
556 addUriAuth (Just (user, pass)) uri = uri
557 { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }
558 }
559 where
560 a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)
561
562 runWGet verbosity uri args = do
563 -- We pass the URI via STDIN because it contains the users' credentials
564 -- and sensitive data should not be passed via command line arguments.
565 let
566 invocation = (programInvocation prog ("--input-file=-" : args))
567 { progInvokeInput = Just $ IODataText $ uriToString id uri ""
568 }
569
570 -- wget returns its output on stderr rather than stdout
571 (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity
572 invocation
573 -- wget returns exit code 8 for server "errors" like "304 not modified"
574 if exitCode == ExitSuccess || exitCode == ExitFailure 8
575 then return resp
576 else die' verbosity $ "'" ++ programPath prog
577 ++ "' exited with an error:\n" ++ resp
578
579 -- With the --server-response flag, wget produces output with the full
580 -- http server response with all headers, we want to find a line like
581 -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple
582 -- requests due to redirects.
583 parseOutput verbosity uri resp =
584 let parsedCode = listToMaybe
585 [ code
586 | (protocol:codestr:_err) <- map words (reverse (lines resp))
587 , "HTTP/" `isPrefixOf` protocol
588 , code <- maybeToList (readMaybe codestr) ]
589 mb_etag :: Maybe ETag
590 mb_etag = listToMaybe
591 [ etag
592 | ["ETag:", etag] <- map words (reverse (lines resp)) ]
593 in case parsedCode of
594 Just i -> return (i, mb_etag)
595 _ -> statusParseFail verbosity uri resp
596
597
598 powershellTransport :: ConfiguredProgram -> HttpTransport
599 powershellTransport prog =
600 HttpTransport gethttp posthttp posthttpfile puthttpfile True False
601 where
602 gethttp verbosity uri etag destPath reqHeaders = do
603 resp <- runPowershellScript verbosity $
604 webclientScript
605 (escape (show uri))
606 (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
607 :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))
608 [ "$response = $request.GetResponse()"
609 , "$responseStream = $response.GetResponseStream()"
610 , "$buffer = new-object byte[] 10KB"
611 , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
612 , "while ($count -gt 0)"
613 , "{"
614 , " $targetStream.Write($buffer, 0, $count)"
615 , " $count = $responseStream.Read($buffer, 0, $buffer.length)"
616 , "}"
617 , "Write-Host ($response.StatusCode -as [int]);"
618 , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
619 ]
620 [ "$targetStream.Flush()"
621 , "$targetStream.Close()"
622 , "$targetStream.Dispose()"
623 , "$responseStream.Dispose()"
624 ]
625 parseResponse resp
626 where
627 parseResponse :: String -> IO (HttpCode, Maybe ETag)
628 parseResponse x =
629 case lines $ trim x of
630 (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
631 (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x
632 _ -> statusParseFail verbosity uri x
633 parseCode :: String -> String -> IO HttpCode
634 parseCode code x = case readMaybe code of
635 Just i -> return i
636 Nothing -> statusParseFail verbosity uri x
637 etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]
638
639 posthttp = noPostYet
640
641 posthttpfile verbosity uri path auth =
642 withTempFile (takeDirectory path)
643 (takeFileName path) $ \tmpFile tmpHandle -> do
644 (body, boundary) <- generateMultipartBody path
645 LBS.hPut tmpHandle body
646 hClose tmpHandle
647 fullPath <- canonicalizePath tmpFile
648
649 let contentHeader = Header HdrContentType
650 ("multipart/form-data; boundary=" ++ boundary)
651 resp <- runPowershellScript verbosity $ webclientScript
652 (escape (show uri))
653 (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
654 (uploadFileAction "POST" uri fullPath)
655 uploadFileCleanup
656 parseUploadResponse verbosity uri resp
657
658 puthttpfile verbosity uri path auth headers = do
659 fullPath <- canonicalizePath path
660 resp <- runPowershellScript verbosity $ webclientScript
661 (escape (show uri))
662 (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
663 (uploadFileAction "PUT" uri fullPath)
664 uploadFileCleanup
665 parseUploadResponse verbosity uri resp
666
667 runPowershellScript verbosity script = do
668 let args =
669 [ "-InputFormat", "None"
670 -- the default execution policy doesn't allow running
671 -- unsigned scripts, so we need to tell powershell to bypass it
672 , "-ExecutionPolicy", "bypass"
673 , "-NoProfile", "-NonInteractive"
674 , "-Command", "-"
675 ]
676 debug verbosity script
677 getProgramInvocationOutput verbosity (programInvocation prog args)
678 { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"
679 }
680
681 escape = show
682
683 useragentHeader = Header HdrUserAgent userAgent
684 extraHeaders = [Header HdrAccept "text/plain", useragentHeader]
685
686 setupHeaders headers =
687 [ "$request." ++ addHeader name value
688 | Header name value <- headers
689 ]
690 where
691 addHeader header value
692 = case header of
693 HdrAccept -> "Accept = " ++ escape value
694 HdrUserAgent -> "UserAgent = " ++ escape value
695 HdrConnection -> "Connection = " ++ escape value
696 HdrContentLength -> "ContentLength = " ++ escape value
697 HdrContentType -> "ContentType = " ++ escape value
698 HdrDate -> "Date = " ++ escape value
699 HdrExpect -> "Expect = " ++ escape value
700 HdrHost -> "Host = " ++ escape value
701 HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
702 HdrReferer -> "Referer = " ++ escape value
703 HdrTransferEncoding -> "TransferEncoding = " ++ escape value
704 HdrRange -> let (start, end) =
705 if "bytes=" `isPrefixOf` value
706 then case break (== '-') value' of
707 (start', '-':end') -> (start', end')
708 _ -> error $ "Could not decode range: " ++ value
709 else error $ "Could not decode range: " ++ value
710 value' = drop 6 value
711 in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
712 name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
713
714 setupAuth auth =
715 [ "$request.Credentials = new-object System.Net.NetworkCredential("
716 ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"
717 | (uname,passwd) <- maybeToList auth
718 ]
719
720 uploadFileAction method _uri fullPath =
721 [ "$request.Method = " ++ show method
722 , "$requestStream = $request.GetRequestStream()"
723 , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"
724 , "$bufSize=10000"
725 , "$chunk = New-Object byte[] $bufSize"
726 , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"
727 , "{"
728 , " $requestStream.write($chunk, 0, $bytesRead)"
729 , " $requestStream.Flush()"
730 , "}"
731 , ""
732 , "$responseStream = $request.getresponse()"
733 , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"
734 , "$code = $response.StatusCode -as [int]"
735 , "if ($code -eq 0) {"
736 , " $code = 200;"
737 , "}"
738 , "Write-Host $code"
739 , "Write-Host $responseReader.ReadToEnd()"
740 ]
741
742 uploadFileCleanup =
743 [ "$fileStream.Close()"
744 , "$requestStream.Close()"
745 , "$responseStream.Close()"
746 ]
747
748 parseUploadResponse verbosity uri resp = case lines (trim resp) of
749 (codeStr : message)
750 | Just code <- readMaybe codeStr -> return (code, unlines message)
751 _ -> statusParseFail verbosity uri resp
752
753 webclientScript uri setup action cleanup = unlines
754 [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
755 , "$uri = New-Object \"System.Uri\" " ++ uri
756 , "$request = [System.Net.HttpWebRequest]::Create($uri)"
757 , unlines setup
758 , "Try {"
759 , unlines (map (" " ++) action)
760 , "} Catch [System.Net.WebException] {"
761 , " $exception = $_.Exception;"
762 , " If ($exception.Status -eq "
763 ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
764 , " $response = $exception.Response -as [System.Net.HttpWebResponse];"
765 , " $reader = new-object "
766 ++ "System.IO.StreamReader($response.GetResponseStream());"
767 , " Write-Host ($response.StatusCode -as [int]);"
768 , " Write-Host $reader.ReadToEnd();"
769 , " } Else {"
770 , " Write-Host $exception.Message;"
771 , " }"
772 , "} Catch {"
773 , " Write-Host $_.Exception.Message;"
774 , "} finally {"
775 , unlines (map (" " ++) cleanup)
776 , "}"
777 ]
778
779
780 ------------------------------------------------------------------------------
781 -- The builtin plain HttpTransport
782 --
783
784 plainHttpTransport :: HttpTransport
785 plainHttpTransport =
786 HttpTransport gethttp posthttp posthttpfile puthttpfile False False
787 where
788 gethttp verbosity uri etag destPath reqHeaders = do
789 let req = Request{
790 rqURI = uri,
791 rqMethod = GET,
792 rqHeaders = [ Header HdrIfNoneMatch t
793 | t <- maybeToList etag ]
794 ++ reqHeaders,
795 rqBody = LBS.empty
796 }
797 (_, resp) <- cabalBrowse verbosity Nothing (request req)
798 let code = convertRspCode (rspCode resp)
799 etag' = lookupHeader HdrETag (rspHeaders resp)
800 -- 206 Partial Content is a normal response to a range request; see #3385.
801 when (code==200 || code==206) $
802 writeFileAtomic destPath $ rspBody resp
803 return (code, etag')
804
805 posthttp = noPostYet
806
807 posthttpfile verbosity uri path auth = do
808 (body, boundary) <- generateMultipartBody path
809 let headers = [ Header HdrContentType
810 ("multipart/form-data; boundary="++boundary)
811 , Header HdrContentLength (show (LBS8.length body))
812 , Header HdrAccept ("text/plain")
813 ]
814 req = Request {
815 rqURI = uri,
816 rqMethod = POST,
817 rqHeaders = headers,
818 rqBody = body
819 }
820 (_, resp) <- cabalBrowse verbosity auth (request req)
821 return (convertRspCode (rspCode resp), rspErrorString resp)
822
823 puthttpfile verbosity uri path auth headers = do
824 body <- LBS8.readFile path
825 let req = Request {
826 rqURI = uri,
827 rqMethod = PUT,
828 rqHeaders = Header HdrContentLength (show (LBS8.length body))
829 : Header HdrAccept "text/plain"
830 : headers,
831 rqBody = body
832 }
833 (_, resp) <- cabalBrowse verbosity auth (request req)
834 return (convertRspCode (rspCode resp), rspErrorString resp)
835
836 convertRspCode (a,b,c) = a*100 + b*10 + c
837
838 rspErrorString resp =
839 case lookupHeader HdrContentType (rspHeaders resp) of
840 Just contenttype
841 | takeWhile (/= ';') contenttype == "text/plain"
842 -> LBS8.unpack (rspBody resp)
843 _ -> rspReason resp
844
845 cabalBrowse verbosity auth act = do
846 p <- fixupEmptyProxy <$> fetchProxy True
847 Exception.handleJust
848 (guard . isDoesNotExistError)
849 (const . die' verbosity $ "Couldn't establish HTTP connection. "
850 ++ "Possible cause: HTTP proxy server is down.") $
851 browse $ do
852 setProxy p
853 setErrHandler (warn verbosity . ("http error: "++))
854 setOutHandler (debug verbosity)
855 setUserAgent userAgent
856 setAllowBasicAuth False
857 setAuthorityGen (\_ _ -> return auth)
858 act
859
860 fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
861 fixupEmptyProxy p = p
862
863
864 ------------------------------------------------------------------------------
865 -- Common stuff used by multiple transport impls
866 --
867
868 userAgent :: String
869 userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion
870 , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"
871 ]
872
873 statusParseFail :: Verbosity -> URI -> String -> IO a
874 statusParseFail verbosity uri r =
875 die' verbosity $ "Failed to download " ++ show uri ++ " : "
876 ++ "No Status Code could be parsed from response: " ++ r
877
878 -- Trim
879 trim :: String -> String
880 trim = f . f
881 where f = reverse . dropWhile isSpace
882
883
884 ------------------------------------------------------------------------------
885 -- Multipart stuff partially taken from cgi package.
886 --
887
888 generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
889 generateMultipartBody path = do
890 content <- LBS.readFile path
891 boundary <- genBoundary
892 let !body = formatBody content (LBS8.pack boundary)
893 return (body, boundary)
894 where
895 formatBody content boundary =
896 LBS8.concat $
897 [ crlf, dd, boundary, crlf ]
898 ++ [ LBS8.pack (show header) | header <- headers ]
899 ++ [ crlf
900 , content
901 , crlf, dd, boundary, dd, crlf ]
902
903 headers =
904 [ Header (HdrCustom "Content-disposition")
905 ("form-data; name=package; " ++
906 "filename=\"" ++ takeFileName path ++ "\"")
907 , Header HdrContentType "application/x-gzip"
908 ]
909
910 crlf = LBS8.pack "\r\n"
911 dd = LBS8.pack "--"
912
913 genBoundary :: IO String
914 genBoundary = do
915 i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
916 return $ showHex i ""