cabal-install/src/Distribution/Client/HttpUtils.hs

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