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         | uriScheme uri == "http:"
 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 remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
 255 remoteRepoCheckHttps verbosity transport repo
 256   | uriScheme (remoteRepoURI repo) == "https:"
 257   , not (transportSupportsHttps transport) =
 258       dieWithException verbosity $ RemoteRepoCheckHttps (unRepoName (remoteRepoName repo)) requiresHttpsErrorMessage
 259   | otherwise = return ()
 260
 261 transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
 262 transportCheckHttps verbosity transport uri
 263   | uriScheme uri == "https:"
 264   , not (transportSupportsHttps transport) =
 265       dieWithException verbosity $ TransportCheckHttps uri requiresHttpsErrorMessage
 266   | otherwise = return ()
 267
 268 requiresHttpsErrorMessage :: String
 269 requiresHttpsErrorMessage =
 270   "requires HTTPS however the built-in HTTP implementation "
 271     ++ "does not support HTTPS. The transport implementations with HTTPS "
 272     ++ "support are "
 273     ++ intercalate
 274       ", "
 275       [name | (name, _, True, _) <- supportedTransports]
 276     ++ ". One of these will be selected automatically if the corresponding "
 277     ++ "external program is available, or one can be selected specifically "
 278     ++ "with the global flag --http-transport="
 279
 280 remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
 281 remoteRepoTryUpgradeToHttps verbosity transport repo
 282   | remoteRepoShouldTryHttps repo
 283   , uriScheme (remoteRepoURI repo) == "http:"
 284   , not (transportSupportsHttps transport)
 285   , not (transportManuallySelected transport) =
 286       dieWithException verbosity $ TryUpgradeToHttps [name | (name, _, True, _) <- supportedTransports]
 287   | remoteRepoShouldTryHttps repo
 288   , uriScheme (remoteRepoURI repo) == "http:"
 289   , transportSupportsHttps transport =
 290       return
 291         repo
 292           { remoteRepoURI = (remoteRepoURI repo){uriScheme = "https:"}
 293           }
 294   | otherwise =
 295       return repo
 296
 297 -- | Utility function for legacy support.
 298 isOldHackageURI :: URI -> Bool
 299 isOldHackageURI uri =
 300   case uriAuthority uri of
 301     Just (URIAuth{uriRegName = "hackage.haskell.org"}) ->
 302       FilePath.Posix.splitDirectories (uriPath uri)
 303         == ["/", "packages", "archive"]
 304     _ -> False
 305
 306 ------------------------------------------------------------------------------
 307 -- Setting up a HttpTransport
 308 --
 309
 310 data HttpTransport = HttpTransport
 311   { getHttp
 312       :: Verbosity
 313       -> URI
 314       -> Maybe ETag
 315       -> FilePath
 316       -> [Header]
 317       -> IO (HttpCode, Maybe ETag)
 318   -- ^ GET a URI, with an optional ETag (to do a conditional fetch),
 319   -- write the resource to the given file and return the HTTP status code,
 320   -- and optional ETag.
 321   , postHttp
 322       :: Verbosity
 323       -> URI
 324       -> String
 325       -> Maybe Auth
 326       -> IO (HttpCode, String)
 327   -- ^ POST a resource to a URI, with optional 'Auth'
 328   -- and return the HTTP status code and any redirect URL.
 329   , postHttpFile
 330       :: Verbosity
 331       -> URI
 332       -> FilePath
 333       -> Maybe Auth
 334       -> IO (HttpCode, String)
 335   -- ^ POST a file resource to a URI using multipart\/form-data encoding,
 336   -- with optional 'Auth' and return the HTTP status
 337   -- code and any error string.
 338   , putHttpFile
 339       :: Verbosity
 340       -> URI
 341       -> FilePath
 342       -> Maybe Auth
 343       -> [Header]
 344       -> IO (HttpCode, String)
 345   -- ^ PUT a file resource to a URI, with optional 'Auth',
 346   -- extra headers and return the HTTP status code
 347   -- and any error string.
 348   , transportSupportsHttps :: Bool
 349   -- ^ Whether this transport supports https or just http.
 350   , transportManuallySelected :: Bool
 351   -- ^ Whether this transport implementation was specifically chosen by
 352   -- the user via configuration, or whether it was automatically selected.
 353   -- Strictly speaking this is not a property of the transport itself but
 354   -- about how it was chosen. Nevertheless it's convenient to keep here.
 355   }
 356
 357 -- TODO: why does postHttp return a redirect, but postHttpFile return errors?
 358
 359 type HttpCode = Int
 360 type ETag = String
 361
 362 noPostYet
 363   :: Verbosity
 364   -> URI
 365   -> String
 366   -> Maybe Auth
 367   -> IO (Int, String)
 368 noPostYet verbosity _ _ _ = dieWithException verbosity NoPostYet
 369
 370 supportedTransports
 371   :: [ ( String
 372        , Maybe Program
 373        , Bool
 374        , ProgramDb -> Maybe HttpTransport
 375        )
 376      ]
 377 supportedTransports =
 378   [ let prog = simpleProgram "curl"
 379      in ( "curl"
 380         , Just prog
 381         , True
 382         , \db -> curlTransport <$> lookupProgram prog db
 383         )
 384   , let prog = simpleProgram "wget"
 385      in ( "wget"
 386         , Just prog
 387         , True
 388         , \db -> wgetTransport <$> lookupProgram prog db
 389         )
 390   , let prog = simpleProgram "powershell"
 391      in ( "powershell"
 392         , Just prog
 393         , True
 394         , \db -> powershellTransport <$> lookupProgram prog db
 395         )
 396   ,
 397     ( "plain-http"
 398     , Nothing
 399     , False
 400     , \_ -> Just plainHttpTransport
 401     )
 402   ]
 403
 404 configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport
 405 configureTransport verbosity extraPath (Just name) =
 406   -- the user specifically selected a transport by name so we'll try and
 407   -- configure that one
 408
 409   case find (\(name', _, _, _) -> name' == name) supportedTransports of
 410     Just (_, mprog, _tls, mkTrans) -> do
 411       baseProgDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb
 412       progdb <- case mprog of
 413         Nothing -> return emptyProgramDb
 414         Just prog -> snd <$> requireProgram verbosity prog baseProgDb
 415       --      ^^ if it fails, it'll fail here
 416
 417       let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
 418       return transport{transportManuallySelected = True}
 419     Nothing ->
 420       dieWithException verbosity $ UnknownHttpTransportSpecified name [name' | (name', _, _, _) <- supportedTransports]
 421 configureTransport verbosity extraPath Nothing = do
 422   -- the user hasn't selected a transport, so we'll pick the first one we
 423   -- can configure successfully, provided that it supports tls
 424
 425   -- for all the transports except plain-http we need to try and find
 426   -- their external executable
 427   baseProgDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb
 428   progdb <-
 429     configureAllKnownPrograms verbosity $
 430       addKnownPrograms
 431         [prog | (_, Just prog, _, _) <- supportedTransports]
 432         baseProgDb
 433
 434   let availableTransports =
 435         [ (name, transport)
 436         | (name, _, _, mkTrans) <- supportedTransports
 437         , transport <- maybeToList (mkTrans progdb)
 438         ]
 439   let (name, transport) =
 440         fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)
 441   debug verbosity $ "Selected http transport implementation: " ++ name
 442
 443   return transport{transportManuallySelected = False}
 444
 445 ------------------------------------------------------------------------------
 446 -- The HttpTransports based on external programs
 447 --
 448
 449 curlTransport :: ConfiguredProgram -> HttpTransport
 450 curlTransport prog =
 451   HttpTransport gethttp posthttp posthttpfile puthttpfile True False
 452   where
 453     gethttp verbosity uri etag destPath reqHeaders = do
 454       withTempFile
 455         (takeDirectory destPath)
 456         "curl-headers.txt"
 457         $ \tmpFile tmpHandle -> do
 458           hClose tmpHandle
 459           let args =
 460                 [ show uri
 461                 , "--output"
 462                 , destPath
 463                 , "--location"
 464                 , "--write-out"
 465                 , "%{http_code}"
 466                 , "--user-agent"
 467                 , userAgent
 468                 , "--silent"
 469                 , "--show-error"
 470                 , "--dump-header"
 471                 , tmpFile
 472                 ]
 473                   ++ concat
 474                     [ ["--header", "If-None-Match: " ++ t]
 475                     | t <- maybeToList etag
 476                     ]
 477                   ++ concat
 478                     [ ["--header", show name ++ ": " ++ value]
 479                     | Header name value <- reqHeaders
 480                     ]
 481
 482           resp <-
 483             getProgramInvocationOutput verbosity $
 484               addAuthConfig
 485                 Nothing
 486                 uri
 487                 (programInvocation prog args)
 488
 489           withFile tmpFile ReadMode $ \hnd -> do
 490             headers <- hGetContents hnd
 491             (code, _err, etag') <- parseResponse verbosity uri resp headers
 492             evaluate $ force (code, etag')
 493
 494     posthttp = noPostYet
 495
 496     addAuthConfig explicitAuth uri progInvocation = do
 497       -- attempt to derive a u/p pair from the uri authority if one exists
 498       -- all `uriUserInfo` values have '@' as a suffix. drop it.
 499       let uriDerivedAuth = case uriAuthority uri of
 500             (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u
 501             _ -> Nothing
 502       -- prefer passed in auth to auth derived from uri. If neither exist, then no auth
 503       let mbAuthStringToken = case (explicitAuth, uriDerivedAuth) of
 504             (Just (Right token), _) -> Just $ Right token
 505             (Just (Left (uname, passwd)), _) -> Just $ Left (uname ++ ":" ++ passwd)
 506             (Nothing, Just a) -> Just $ Left a
 507             (Nothing, Nothing) -> Nothing
 508       case mbAuthStringToken of
 509         Just (Left up) ->
 510           progInvocation
 511             { progInvokeInput =
 512                 Just . IODataText . unlines $
 513                   [ "--digest"
 514                   , "--user " ++ up
 515                   ]
 516             , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
 517             }
 518         Just (Right token) ->
 519           progInvocation
 520             { progInvokeArgs =
 521                 ["--header", "Authorization: X-ApiKey " ++ token]
 522                   ++ progInvokeArgs progInvocation
 523             }
 524         Nothing -> progInvocation
 525
 526     posthttpfile verbosity uri path auth = do
 527       let args =
 528             [ show uri
 529             , "--form"
 530             , "package=@" ++ path
 531             , "--write-out"
 532             , "\n%{http_code}"
 533             , "--user-agent"
 534             , userAgent
 535             , "--silent"
 536             , "--show-error"
 537             , "--header"
 538             , "Accept: text/plain"
 539             , "--location"
 540             ]
 541       resp <-
 542         getProgramInvocationOutput verbosity $
 543           addAuthConfig
 544             auth
 545             uri
 546             (programInvocation prog args)
 547       (code, err, _etag) <- parseResponse verbosity uri resp ""
 548       return (code, err)
 549
 550     puthttpfile verbosity uri path auth headers = do
 551       let args =
 552             [ show uri
 553             , "--request"
 554             , "PUT"
 555             , "--data-binary"
 556             , "@" ++ path
 557             , "--write-out"
 558             , "\n%{http_code}"
 559             , "--user-agent"
 560             , userAgent
 561             , "--silent"
 562             , "--show-error"
 563             , "--location"
 564             , "--header"
 565             , "Accept: text/plain"
 566             ]
 567               ++ concat
 568                 [ ["--header", show name ++ ": " ++ value]
 569                 | Header name value <- headers
 570                 ]
 571       resp <-
 572         getProgramInvocationOutput verbosity $
 573           addAuthConfig
 574             auth
 575             uri
 576             (programInvocation prog args)
 577       (code, err, _etag) <- parseResponse verbosity uri resp ""
 578       return (code, err)
 579
 580     -- on success these curl invocations produces an output like "200"
 581     -- and on failure it has the server error response first
 582     parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)
 583     parseResponse verbosity uri resp headers =
 584       let codeerr =
 585             case reverse (lines resp) of
 586               (codeLine : rerrLines) ->
 587                 case readMaybe (trim codeLine) of
 588                   Just i ->
 589                     let errstr = mkErrstr rerrLines
 590                      in Just (i, errstr)
 591                   Nothing -> Nothing
 592               [] -> Nothing
 593
 594           mkErrstr = unlines . reverse . dropWhile (all isSpace)
 595
 596           mb_etag :: Maybe ETag
 597           mb_etag =
 598             listToMaybe $
 599               reverse
 600                 [ etag
 601                 | [name, etag] <- map words (lines headers)
 602                 , isETag name
 603                 ]
 604        in case codeerr of
 605             Just (i, err) -> return (i, err, mb_etag)
 606             _ -> statusParseFail verbosity uri resp
 607
 608 wgetTransport :: ConfiguredProgram -> HttpTransport
 609 wgetTransport prog =
 610   HttpTransport gethttp posthttp posthttpfile puthttpfile True False
 611   where
 612     gethttp verbosity uri etag destPath reqHeaders = do
 613       resp <- runWGet verbosity uri args
 614
 615       -- wget doesn't support range requests.
 616       -- so, we not only ignore range request headers,
 617       -- but we also display a warning message when we see them.
 618       let hasRangeHeader = any isRangeHeader reqHeaders
 619           warningMsg =
 620             "the 'wget' transport currently doesn't support"
 621               ++ " range requests, which wastes network bandwidth."
 622               ++ " To fix this, set 'http-transport' to 'curl' or"
 623               ++ " 'plain-http' in '~/.config/cabal/config'."
 624               ++ " Note that the 'plain-http' transport doesn't"
 625               ++ " support HTTPS.\n"
 626
 627       when (hasRangeHeader) $ warn verbosity warningMsg
 628       (code, etag') <- parseOutput verbosity uri resp
 629       return (code, etag')
 630       where
 631         args =
 632           [ "--output-document=" ++ destPath
 633           , "--user-agent=" ++ userAgent
 634           , "--tries=5"
 635           , "--timeout=15"
 636           , "--server-response"
 637           ]
 638             ++ concat
 639               [ ["--header", "If-None-Match: " ++ t]
 640               | t <- maybeToList etag
 641               ]
 642             ++ [ "--header=" ++ show name ++ ": " ++ value
 643                | hdr@(Header name value) <- reqHeaders
 644                , (not (isRangeHeader hdr))
 645                ]
 646
 647         -- wget doesn't support range requests.
 648         -- so, we ignore range request headers, lest we get errors.
 649         isRangeHeader :: Header -> Bool
 650         isRangeHeader (Header HdrRange _) = True
 651         isRangeHeader _ = False
 652
 653     posthttp = noPostYet
 654
 655     posthttpfile verbosity uri path auth =
 656       withTempFile
 657         (takeDirectory path)
 658         (takeFileName path)
 659         $ \tmpFile tmpHandle ->
 660           withTempFile (takeDirectory path) "response" $
 661             \responseFile responseHandle -> do
 662               hClose responseHandle
 663               (body, boundary) <- generateMultipartBody path
 664               LBS.hPut tmpHandle body
 665               hClose tmpHandle
 666               let args =
 667                     [ "--post-file=" ++ tmpFile
 668                     , "--user-agent=" ++ userAgent
 669                     , "--server-response"
 670                     , "--output-document=" ++ responseFile
 671                     , "--header=Accept: text/plain"
 672                     , "--header=Content-type: multipart/form-data; "
 673                         ++ "boundary="
 674                         ++ boundary
 675                     ]
 676                       ++ maybeToList (authTokenHeader auth)
 677               out <- runWGet verbosity (addUriAuth auth uri) args
 678               (code, _etag) <- parseOutput verbosity uri out
 679               withFile responseFile ReadMode $ \hnd -> do
 680                 resp <- hGetContents hnd
 681                 evaluate $ force (code, resp)
 682
 683     puthttpfile verbosity uri path auth headers =
 684       withTempFile (takeDirectory path) "response" $
 685         \responseFile responseHandle -> do
 686           hClose responseHandle
 687           let args =
 688                 [ "--method=PUT"
 689                 , "--body-file=" ++ path
 690                 , "--user-agent=" ++ userAgent
 691                 , "--server-response"
 692                 , "--output-document=" ++ responseFile
 693                 , "--header=Accept: text/plain"
 694                 ]
 695                   ++ [ "--header=" ++ show name ++ ": " ++ value
 696                      | Header name value <- headers
 697                      ]
 698                   ++ maybeToList (authTokenHeader auth)
 699
 700           out <- runWGet verbosity (addUriAuth auth uri) args
 701           (code, _etag) <- parseOutput verbosity uri out
 702           withFile responseFile ReadMode $ \hnd -> do
 703             resp <- hGetContents hnd
 704             evaluate $ force (code, resp)
 705
 706     authTokenHeader (Just (Right token)) = Just $ "--header=Authorization: X-ApiKey " ++ token
 707     authTokenHeader _ = Nothing
 708
 709     addUriAuth (Just (Left (user, pass))) uri =
 710       uri
 711         { uriAuthority = Just a{uriUserInfo = user ++ ":" ++ pass ++ "@"}
 712         }
 713       where
 714         a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)
 715     addUriAuth _ uri = uri
 716
 717     runWGet verbosity uri args = do
 718       -- We pass the URI via STDIN because it contains the users' credentials
 719       -- and sensitive data should not be passed via command line arguments.
 720       let
 721         invocation =
 722           (programInvocation prog ("--input-file=-" : args))
 723             { progInvokeInput = Just $ IODataText $ uriToString id uri ""
 724             }
 725
 726       -- wget returns its output on stderr rather than stdout
 727       (_, resp, exitCode) <-
 728         getProgramInvocationOutputAndErrors
 729           verbosity
 730           invocation
 731       -- wget returns exit code 8 for server "errors" like "304 not modified"
 732       if exitCode == ExitSuccess || exitCode == ExitFailure 8
 733         then return resp
 734         else dieWithException verbosity $ WGetServerError (programPath prog) resp
 735
 736     -- With the --server-response flag, wget produces output with the full
 737     -- http server response with all headers, we want to find a line like
 738     -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple
 739     -- requests due to redirects.
 740     parseOutput verbosity uri resp =
 741       let parsedCode =
 742             listToMaybe
 743               [ code
 744               | (protocol : codestr : _err) <- map words (reverse (lines resp))
 745               , "HTTP/" `isPrefixOf` protocol
 746               , code <- maybeToList (readMaybe codestr)
 747               ]
 748           mb_etag :: Maybe ETag
 749           mb_etag =
 750             listToMaybe
 751               [ etag
 752               | [name, etag] <- map words (reverse (lines resp))
 753               , isETag name
 754               ]
 755        in case parsedCode of
 756             Just i -> return (i, mb_etag)
 757             _ -> statusParseFail verbosity uri resp
 758
 759 powershellTransport :: ConfiguredProgram -> HttpTransport
 760 powershellTransport prog =
 761   HttpTransport gethttp posthttp posthttpfile puthttpfile True False
 762   where
 763     gethttp verbosity uri etag destPath reqHeaders = do
 764       resp <-
 765         runPowershellScript verbosity $
 766           webclientScript
 767             (escape (show uri))
 768             ( ("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
 769                 : (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))
 770             )
 771             [ "$response = $request.GetResponse()"
 772             , "$responseStream = $response.GetResponseStream()"
 773             , "$buffer = new-object byte[] 10KB"
 774             , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
 775             , "while ($count -gt 0)"
 776             , "{"
 777             , "    $targetStream.Write($buffer, 0, $count)"
 778             , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"
 779             , "}"
 780             , "Write-Host ($response.StatusCode -as [int]);"
 781             , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
 782             ]
 783             [ "$targetStream.Flush()"
 784             , "$targetStream.Close()"
 785             , "$targetStream.Dispose()"
 786             , "$responseStream.Dispose()"
 787             ]
 788       parseResponse resp
 789       where
 790         parseResponse :: String -> IO (HttpCode, Maybe ETag)
 791         parseResponse x =
 792           case lines $ trim x of
 793             (code : etagv : _) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
 794             (code : _) -> fmap (\c -> (c, Nothing)) $ parseCode code x
 795             _ -> statusParseFail verbosity uri x
 796         parseCode :: String -> String -> IO HttpCode
 797         parseCode code x = case readMaybe code of
 798           Just i -> return i
 799           Nothing -> statusParseFail verbosity uri x
 800         etagHeader = [Header HdrIfNoneMatch t | t <- maybeToList etag]
 801
 802     posthttp = noPostYet
 803
 804     posthttpfile verbosity uri path auth =
 805       withTempFile
 806         (takeDirectory path)
 807         (takeFileName path)
 808         $ \tmpFile tmpHandle -> do
 809           (body, boundary) <- generateMultipartBody path
 810           LBS.hPut tmpHandle body
 811           hClose tmpHandle
 812           fullPath <- canonicalizePath tmpFile
 813
 814           let contentHeader =
 815                 Header
 816                   HdrContentType
 817                   ("multipart/form-data; boundary=" ++ boundary)
 818           resp <-
 819             runPowershellScript verbosity $
 820               webclientScript
 821                 (escape (show uri))
 822                 (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
 823                 (uploadFileAction "POST" uri fullPath)
 824                 uploadFileCleanup
 825           parseUploadResponse verbosity uri resp
 826
 827     puthttpfile verbosity uri path auth headers = do
 828       fullPath <- canonicalizePath path
 829       resp <-
 830         runPowershellScript verbosity $
 831           webclientScript
 832             (escape (show uri))
 833             (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
 834             (uploadFileAction "PUT" uri fullPath)
 835             uploadFileCleanup
 836       parseUploadResponse verbosity uri resp
 837
 838     runPowershellScript verbosity script = do
 839       let args =
 840             [ "-InputFormat"
 841             , "None"
 842             , -- the default execution policy doesn't allow running
 843               -- unsigned scripts, so we need to tell powershell to bypass it
 844               "-ExecutionPolicy"
 845             , "bypass"
 846             , "-NoProfile"
 847             , "-NonInteractive"
 848             , "-Command"
 849             , "-"
 850             ]
 851       debug verbosity script
 852       getProgramInvocationOutput
 853         verbosity
 854         (programInvocation prog args)
 855           { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"
 856           }
 857
 858     escape = show
 859
 860     useragentHeader = Header HdrUserAgent userAgent
 861     extraHeaders = [Header HdrAccept "text/plain", useragentHeader]
 862
 863     setupHeaders headers =
 864       [ "$request." ++ addHeader name value
 865       | Header name value <- headers
 866       ]
 867       where
 868         addHeader header value =
 869           case header of
 870             HdrAccept -> "Accept = " ++ escape value
 871             HdrUserAgent -> "UserAgent = " ++ escape value
 872             HdrConnection -> "Connection = " ++ escape value
 873             HdrContentLength -> "ContentLength = " ++ escape value
 874             HdrContentType -> "ContentType = " ++ escape value
 875             HdrDate -> "Date = " ++ escape value
 876             HdrExpect -> "Expect = " ++ escape value
 877             HdrHost -> "Host = " ++ escape value
 878             HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
 879             HdrReferer -> "Referer = " ++ escape value
 880             HdrTransferEncoding -> "TransferEncoding = " ++ escape value
 881             HdrRange ->
 882               let (start, end) =
 883                     if "bytes=" `isPrefixOf` value
 884                       then case break (== '-') value' of
 885                         (start', '-' : end') -> (start', end')
 886                         _ -> error $ "Could not decode range: " ++ value
 887                       else error $ "Could not decode range: " ++ value
 888                   value' = drop 6 value
 889                in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
 890             name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
 891
 892     setupAuth (Just (Left (uname, passwd))) =
 893       [ "$request.Credentials = new-object System.Net.NetworkCredential("
 894           ++ escape uname
 895           ++ ","
 896           ++ escape passwd
 897           ++ ",\"\");"
 898       ]
 899     setupAuth (Just (Right token)) =
 900       ["$request.Headers[\"Authorization\"] = " ++ escape ("X-ApiKey " ++ token)]
 901     setupAuth Nothing = []
 902
 903     uploadFileAction method _uri fullPath =
 904       [ "$request.Method = " ++ show method
 905       , "$requestStream = $request.GetRequestStream()"
 906       , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"
 907       , "$bufSize=10000"
 908       , "$chunk = New-Object byte[] $bufSize"
 909       , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"
 910       , "{"
 911       , "  $requestStream.write($chunk, 0, $bytesRead)"
 912       , "  $requestStream.Flush()"
 913       , "}"
 914       , ""
 915       , "$responseStream = $request.getresponse()"
 916       , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"
 917       , "$code = $response.StatusCode -as [int]"
 918       , "if ($code -eq 0) {"
 919       , "  $code = 200;"
 920       , "}"
 921       , "Write-Host $code"
 922       , "Write-Host $responseReader.ReadToEnd()"
 923       ]
 924
 925     uploadFileCleanup =
 926       [ "$fileStream.Close()"
 927       , "$requestStream.Close()"
 928       , "$responseStream.Close()"
 929       ]
 930
 931     parseUploadResponse verbosity uri resp = case lines (trim resp) of
 932       (codeStr : message)
 933         | Just code <- readMaybe codeStr -> return (code, unlines message)
 934       _ -> statusParseFail verbosity uri resp
 935
 936     webclientScript uri setup action cleanup =
 937       unlines
 938         [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
 939         , "$uri = New-Object \"System.Uri\" " ++ uri
 940         , "$request = [System.Net.HttpWebRequest]::Create($uri)"
 941         , unlines setup
 942         , "Try {"
 943         , unlines (map ("  " ++) action)
 944         , "} Catch [System.Net.WebException] {"
 945         , "  $exception = $_.Exception;"
 946         , "  If ($exception.Status -eq "
 947             ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
 948         , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"
 949         , "    $reader = new-object "
 950             ++ "System.IO.StreamReader($response.GetResponseStream());"
 951         , "    Write-Host ($response.StatusCode -as [int]);"
 952         , "    Write-Host $reader.ReadToEnd();"
 953         , "  } Else {"
 954         , "    Write-Host $exception.Message;"
 955         , "  }"
 956         , "} Catch {"
 957         , "  Write-Host $_.Exception.Message;"
 958         , "} finally {"
 959         , unlines (map ("  " ++) cleanup)
 960         , "}"
 961         ]
 962
 963 ------------------------------------------------------------------------------
 964 -- The builtin plain HttpTransport
 965 --
 966
 967 plainHttpTransport :: HttpTransport
 968 plainHttpTransport =
 969   HttpTransport gethttp posthttp posthttpfile puthttpfile False False
 970   where
 971     gethttp verbosity uri etag destPath reqHeaders = do
 972       let req =
 973             Request
 974               { rqURI = uri
 975               , rqMethod = GET
 976               , rqHeaders =
 977                   [ Header HdrIfNoneMatch t
 978                   | t <- maybeToList etag
 979                   ]
 980                     ++ reqHeaders
 981               , rqBody = LBS.empty
 982               }
 983       (_, resp) <- cabalBrowse verbosity Nothing (request req)
 984       let code = convertRspCode (rspCode resp)
 985           etag' = lookupHeader HdrETag (rspHeaders resp)
 986       -- 206 Partial Content is a normal response to a range request; see #3385.
 987       when (code == 200 || code == 206) $
 988         writeFileAtomic destPath $
 989           rspBody resp
 990       return (code, etag')
 991
 992     posthttp = noPostYet
 993
 994     posthttpfile verbosity uri path auth = do
 995       (body, boundary) <- generateMultipartBody path
 996       let headers =
 997             [ Header
 998                 HdrContentType
 999                 ("multipart/form-data; boundary=" ++ boundary)
1000             , Header HdrContentLength (show (LBS8.length body))
1001             , Header HdrAccept ("text/plain")
1002             ]
1003               ++ maybeToList (authTokenHeader auth)
1004           req =
1005             Request
1006               { rqURI = uri
1007               , rqMethod = POST
1008               , rqHeaders = headers
1009               , rqBody = body
1010               }
1011       (_, resp) <- cabalBrowse verbosity auth (request req)
1012       return (convertRspCode (rspCode resp), rspErrorString resp)
1013
1014     puthttpfile verbosity uri path auth headers = do
1015       body <- LBS8.readFile path
1016       let req =
1017             Request
1018               { rqURI = uri
1019               , rqMethod = PUT
1020               , rqHeaders =
1021                   Header HdrContentLength (show (LBS8.length body))
1022                     : Header HdrAccept "text/plain"
1023                     : maybeToList (authTokenHeader auth)
1024                     ++ headers
1025               , rqBody = body
1026               }
1027       (_, resp) <- cabalBrowse verbosity auth (request req)
1028       return (convertRspCode (rspCode resp), rspErrorString resp)
1029
1030     convertRspCode (a, b, c) = a * 100 + b * 10 + c
1031
1032     rspErrorString resp =
1033       case lookupHeader HdrContentType (rspHeaders resp) of
1034         Just contenttype
1035           | takeWhile (/= ';') contenttype == "text/plain" ->
1036               LBS8.unpack (rspBody resp)
1037         _ -> rspReason resp
1038
1039     cabalBrowse verbosity auth act = do
1040       p <- fixupEmptyProxy <$> fetchProxy True
1041       Exception.handleJust
1042         (guard . isDoesNotExistError)
1043         ( const . dieWithException verbosity $ Couldn'tEstablishHttpConnection
1044         )
1045         $ browse
1046         $ do
1047           setProxy p
1048           setErrHandler (warn verbosity . ("http error: " ++))
1049           setOutHandler (debug verbosity)
1050           setUserAgent userAgent
1051           setAllowBasicAuth False
1052           case auth of
1053             Just (Left x) -> setAuthorityGen (\_ _ -> return $ Just x)
1054             _ -> setAuthorityGen (\_ _ -> return Nothing)
1055           act
1056
1057     authTokenHeader (Just (Right token)) = Just $ Header HdrAuthorization ("X-ApiKey " ++ token)
1058     authTokenHeader _ = Nothing
1059
1060     fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
1061     fixupEmptyProxy p = p
1062
1063 ------------------------------------------------------------------------------
1064 -- Common stuff used by multiple transport impls
1065 --
1066
1067 userAgent :: String
1068 userAgent =
1069   concat
1070     [ "cabal-install/"
1071     , prettyShow cabalInstallVersion
1072     , " ("
1073     , prettyShow buildOS
1074     , "; "
1075     , prettyShow buildArch
1076     , ")"
1077     ]
1078
1079 statusParseFail :: Verbosity -> URI -> String -> IO a
1080 statusParseFail verbosity uri r =
1081   dieWithException verbosity $ StatusParseFail uri r
1082
1083 ------------------------------------------------------------------------------
1084 -- Multipart stuff partially taken from cgi package.
1085 --
1086
1087 generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
1088 generateMultipartBody path = do
1089   content <- LBS.readFile path
1090   boundary <- genBoundary
1091   let !body = formatBody content (LBS8.pack boundary)
1092   return (body, boundary)
1093   where
1094     formatBody content boundary =
1095       LBS8.concat $
1096         [crlf, dd, boundary, crlf]
1097           ++ [LBS8.pack (show header) | header <- headers]
1098           ++ [ crlf
1099              , content
1100              , crlf
1101              , dd
1102              , boundary
1103              , dd
1104              , crlf
1105              ]
1106
1107     headers =
1108       [ Header
1109           (HdrCustom "Content-disposition")
1110           ( "form-data; name=package; "
1111               ++ "filename=\""
1112               ++ takeFileName path
1113               ++ "\""
1114           )
1115       , Header HdrContentType "application/x-gzip"
1116       ]
1117
1118     crlf = LBS8.pack "\r\n"
1119     dd = LBS8.pack "--"
1120
1121 genBoundary :: IO String
1122 genBoundary = do
1123   i <- randomRIO (0x10000000000000, 0xFFFFFFFFFFFFFF) :: IO Integer
1124   return $ showHex i ""
1125
1126 isETag :: String -> Bool
1127 isETag name = fmap Char.toLower name == "etag:"