HttpUtils.hs 29.8 KB
Newer Older
Duncan Coutts's avatar
Duncan Coutts committed
1
{-# LANGUAGE CPP, BangPatterns #-}
2
-----------------------------------------------------------------------------
3
-- | Separate module for HTTP actions, using a proxy server if one exists.
4
-----------------------------------------------------------------------------
5
module Distribution.Client.HttpUtils (
td123's avatar
td123 committed
6
    DownloadResult(..),
7
8
    configureTransport,
    HttpTransport(..),
9
    HttpCode,
10
    downloadURI,
11
12
13
    transportCheckHttps,
    remoteRepoCheckHttps,
    remoteRepoTryUpgradeToHttps,
14
15
    isOldHackageURI
  ) where
16

17
18
import Network.HTTP
         ( Request (..), Response (..), RequestMethod (..)
19
         , Header(..), HeaderName(..), lookupHeader )
20
import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
21
import Network.URI
22
         ( URI (..), URIAuth (..), uriToString )
23
import Network.Browser
24
         ( browse, setOutHandler, setErrHandler, setProxy
25
         , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )
Duncan Coutts's avatar
Duncan Coutts committed
26
#if !MIN_VERSION_base(4,8,0)
27
import Control.Applicative
Duncan Coutts's avatar
Duncan Coutts committed
28
#endif
29
import qualified Control.Exception as Exception
30
import Control.Monad
31
32
         ( when, guard )
import qualified Data.ByteString.Lazy.Char8 as BS
33
import Data.List
34
         ( isPrefixOf, find, intercalate )
35
import Data.Maybe
36
         ( listToMaybe, maybeToList, fromMaybe )
37
import qualified Paths_cabal_install (version)
38
import Distribution.Verbosity (Verbosity)
39
import Distribution.Simple.Utils
40
41
42
         ( die, info, warn, debug, notice, writeFileAtomic
         , copyFileVerbose,  withTempFile
         , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings )
43
44
import Distribution.Client.Utils
         ( readMaybe, withTempFileName )
45
46
import Distribution.Client.Types
         ( RemoteRepo(..) )
47
48
import Distribution.System
         ( buildOS, buildArch )
49
50
import Distribution.Text
         ( display )
51
52
import Data.Char
         ( isSpace )
53
54
import qualified System.FilePath.Posix as FilePath.Posix
         ( splitDirectories )
55
56
57
import System.FilePath
         ( (<.>) )
import System.Directory
58
         ( doesFileExist, renameFile )
59
60
import System.IO.Error
         ( isDoesNotExistError )
61
import Distribution.Simple.Program
62
63
64
         ( Program, simpleProgram, ConfiguredProgram, programPath
         , ProgramInvocation(..), programInvocation
         , getProgramInvocationOutput )
65
import Distribution.Simple.Program.Db
66
67
68
         ( ProgramDb, emptyProgramDb, addKnownPrograms
         , configureAllKnownPrograms
         , requireProgram, lookupProgram )
69
70
71
72
import Distribution.Simple.Program.Run
        ( IOEncoding(..), getEffectiveEnvironment )
import Numeric (showHex)
import System.Directory (canonicalizePath)
Benno Fünfstück's avatar
Benno Fünfstück committed
73
import System.IO (hClose)
74
75
76
77
78
import System.FilePath (takeFileName, takeDirectory)
import System.Random (randomRIO)
import System.Exit (ExitCode(..))


79
80
81
------------------------------------------------------------------------------
-- Downloading a URI, given an HttpTransport
--
82

83
84
85
data DownloadResult = FileAlreadyInCache
                    | FileDownloaded FilePath
  deriving (Eq)
td123's avatar
td123 committed
86

87
88
89
90
91
92
93
94
95
96
downloadURI :: HttpTransport
            -> Verbosity
            -> URI      -- ^ What to download
            -> FilePath -- ^ Where to put it
            -> IO DownloadResult
downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do
  copyFileVerbose verbosity (uriPath uri) path
  return (FileDownloaded path)
  -- Can we store the hash of the file so we can safely return path when the
  -- hash matches to avoid unnecessary computation?
97

98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
downloadURI transport verbosity uri path = do

    let etagPath = path <.> "etag"
    targetExists   <- doesFileExist path
    etagPathExists <- doesFileExist etagPath
    -- In rare cases the target file doesn't exist, but the etag does.
    etag <- if targetExists && etagPathExists
              then Just <$> readFile etagPath
              else return Nothing

    -- Only use the external http transports if we actually have to
    -- (or have been told to do so)
    let transport'
          | uriScheme uri == "http:"
          , not (transportManuallySelected transport)
          = plainHttpTransport

          | otherwise
          = transport
117

118
    withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do
119
      result <- getHttp transport' verbosity uri etag tmpFile []
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

      -- Only write the etag if we get a 200 response code.
      -- A 304 still sends us an etag header.
      case result of
        (200, Just newEtag) -> writeFile etagPath newEtag
        _ -> return ()

      case fst result of
        200 -> do
            info verbosity ("Downloaded to " ++ path)
            renameFile tmpFile path
            return (FileDownloaded path)
        304 -> do
            notice verbosity "Skipping download: local and remote files match."
            return FileAlreadyInCache
        errCode ->  die $ "Failed to download " ++ show uri
                       ++ " : HTTP code " ++ show errCode

138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
------------------------------------------------------------------------------
-- Utilities for repo url management
--

remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps transport repo
  | uriScheme (remoteRepoURI repo) == "https:"
  , not (transportSupportsHttps transport)
              = die $ "The remote repository '" ++ remoteRepoName repo
                   ++ "' specifies a URL that " ++ requiresHttpsErrorMessage
  | otherwise = return ()

transportCheckHttps :: HttpTransport -> URI -> IO ()
transportCheckHttps transport uri
  | uriScheme uri == "https:"
  , not (transportSupportsHttps transport)
              = die $ "The URL " ++ show uri
                   ++ " " ++ requiresHttpsErrorMessage
  | otherwise = return ()

requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage =
      "requires HTTPS however the built-in HTTP implementation "
   ++ "does not support HTTPS. The transport implementations with HTTPS "
   ++ "support are " ++ intercalate ", "
      [ name | (name, _, True, _ ) <- supportedTransports ]
   ++ ". One of these will be selected automatically if the corresponding "
   ++ "external program is available, or one can be selected specifically "
   ++ "with the global flag --http-transport="

remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps transport repo
  | remoteRepoShouldTryHttps repo
  , uriScheme (remoteRepoURI repo) == "http:"
  , not (transportSupportsHttps transport)
  , not (transportManuallySelected transport)
  = die $ "The builtin HTTP implementation does not support HTTPS, but using "
       ++ "HTTPS for authenticated uploads is recommended. "
       ++ "The transport implementations with HTTPS support are "
       ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]
       ++ "but they require the corresponding external program to be "
       ++ "available. You can either make one available or use plain HTTP by "
       ++ "using the global flag --http-transport=plain-http (or putting the "
       ++ "equivalent in the config file). With plain HTTP, your password "
       ++ "is sent using HTTP digest authentication so it cannot be easily "
       ++ "intercepted, but it is not as secure as using HTTPS."

  | remoteRepoShouldTryHttps repo
  , uriScheme (remoteRepoURI repo) == "http:"
  , transportSupportsHttps transport
  = return repo {
      remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }
    }

  | otherwise
  = return repo

195
196
197
198
199
-- | Utility function for legacy support.
isOldHackageURI :: URI -> Bool
isOldHackageURI uri
    = case uriAuthority uri of
        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->
200
201
            FilePath.Posix.splitDirectories (uriPath uri)
            == ["/","packages","archive"]
202
        _ -> False
203

204

205
206
207
------------------------------------------------------------------------------
-- Setting up a HttpTransport
--
208
209

data HttpTransport = HttpTransport {
210
211
212
      -- | GET a URI, with an optional ETag (to do a conditional fetch),
      -- write the resource to the given file and return the HTTP status code,
      -- and optional ETag.
213
      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
214
215
216
217
218
219
220
221
222
223
224
               -> IO (HttpCode, Maybe ETag),

      -- | POST a resource to a URI, with optional auth (username, password)
      -- and return the HTTP status code and any redirect URL.
      postHttp :: Verbosity -> URI -> String -> Maybe Auth
               -> IO (HttpCode, String),

      -- | POST a file resource to a URI using multipart\/form-data encoding,
      -- with optional auth (username, password) and return the HTTP status
      -- code and any error string.
      postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
225
226
                   -> IO (HttpCode, String),

227
228
229
230
231
232
      -- | PUT a file resource to a URI, with optional auth
      -- (username, password), extra headers and return the HTTP status code
      -- and any error string.
      putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]
                  -> IO (HttpCode, String),

233
234
235
236
      -- | Whether this transport supports https or just http.
      transportSupportsHttps :: Bool,

      -- | Whether this transport implementation was specifically chosen by
237
      -- the user via configuration, or whether it was automatically selected.
238
239
240
      -- Strictly speaking this is not a property of the transport itself but
      -- about how it was chosen. Nevertheless it's convenient to keep here.
      transportManuallySelected :: Bool
241
    }
242
    --TODO: why does postHttp return a redirect, but postHttpFile return errors?
243

244
245
246
247
248
249
250
251
252
253
254
255
256
257
type HttpCode = Int
type ETag     = String
type Auth     = (String, String)

noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)
          -> IO (Int, String)
noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet"

supportedTransports :: [(String, Maybe Program, Bool,
                         ProgramDb -> Maybe HttpTransport)]
supportedTransports =
    [ let prog = simpleProgram "curl" in
      ( "curl", Just prog, True
      , \db -> curlTransport <$> lookupProgram prog db )
258

259
260
261
262
263
264
265
266
267
268
269
    , let prog = simpleProgram "wget" in
      ( "wget", Just prog, True
      , \db -> wgetTransport <$> lookupProgram prog db )

    , let prog = simpleProgram "powershell" in
      ( "powershell", Just prog, True
      , \db -> powershellTransport <$> lookupProgram prog db )

    , ( "plain-http", Nothing, False
      , \_ -> Just plainHttpTransport )
    ]
270
271
272

configureTransport :: Verbosity -> Maybe String -> IO HttpTransport

273
274
275
276
277
278
279
280
281
282
283
284
configureTransport verbosity (Just name) =
    -- the user secifically selected a transport by name so we'll try and
    -- configure that one

    case find (\(name',_,_,_) -> name' == name) supportedTransports of
      Just (_, mprog, _tls, mkTrans) -> do

        progdb <- case mprog of
          Nothing   -> return emptyProgramDb
          Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb
                       --      ^^ if it fails, it'll fail here

285
286
        let Just transport = mkTrans progdb
        return transport { transportManuallySelected = True }
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

      Nothing -> die $ "Unknown HTTP transport specified: " ++ name
                    ++ ". The supported transports are "
                    ++ intercalate ", "
                         [ name' | (name', _, _, _ ) <- supportedTransports ]

configureTransport verbosity Nothing = do
    -- the user hasn't selected a transport, so we'll pick the first one we
    -- can configure successfully, provided that it supports tls

    -- for all the transports except plain-http we need to try and find
    -- their external executable
    progdb <- configureAllKnownPrograms  verbosity $
                addKnownPrograms
                  [ prog | (_, Just prog, _, _) <- supportedTransports ]
                  emptyProgramDb

304
305
306
307
308
309
310
    let availableTransports =
          [ (name, transport)
          | (name, _, _, mkTrans) <- supportedTransports
          , transport <- maybeToList (mkTrans progdb) ]
        -- there's always one because the plain one is last and never fails
    let (name, transport) = head availableTransports
    debug verbosity $ "Selected http transport implementation: " ++ name
311

312
    return transport { transportManuallySelected = False }
313

314

315
316
317
318
319
320
------------------------------------------------------------------------------
-- The HttpTransports based on external programs
--

curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport prog =
321
    HttpTransport gethttp posthttp posthttpfile puthttpfile True False
322
  where
323
    gethttp verbosity uri etag destPath reqHeaders = do
324
325
326
327
328
329
330
331
332
333
334
335
336
        withTempFile (takeDirectory destPath)
                     "curl-headers.txt" $ \tmpFile tmpHandle -> do
          hClose tmpHandle
          let args = [ show uri
                   , "--output", destPath
                   , "--location"
                   , "--write-out", "%{http_code}"
                   , "--user-agent", userAgent
                   , "--silent", "--show-error"
                   , "--dump-header", tmpFile ]
                ++ concat
                   [ ["--header", "If-None-Match: " ++ t]
                   | t <- maybeToList etag ]
337
338
339
                ++ concat
                   [ ["--header", show name ++ ": " ++ value]
                   | Header name value <- reqHeaders ]
340
341
342
343
344
345

          resp <- getProgramInvocationOutput verbosity
                    (programInvocation prog args)
          headers <- readFile tmpFile
          (code, _err, etag') <- parseResponse uri resp headers
          return (code, etag')
346
347
348

    posthttp = noPostYet

349
350
351
352
353
354
355
356
357
358
    addAuthConfig auth progInvocation = progInvocation
      { progInvokeInput = do
          (uname, passwd) <- auth
          return $ unlines
            [ "--digest"
            , "--user " ++ uname ++ ":" ++ passwd
            ]
      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
      }

359
    posthttpfile verbosity uri path auth = do
360
361
        let args = [ show uri
                   , "--form", "package=@"++path
362
                   , "--write-out", "\n%{http_code}"
363
364
                   , "--user-agent", userAgent
                   , "--silent", "--show-error"
365
366
367
                   , "--header", "Accept: text/plain"
                   ]
        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
368
369
370
                  (programInvocation prog args)
        (code, err, _etag) <- parseResponse uri resp ""
        return (code, err)
371

372
373
374
    puthttpfile verbosity uri path auth headers = do
        let args = [ show uri
                   , "--request", "PUT", "--data-binary", "@"++path
375
                   , "--write-out", "\n%{http_code}"
376
377
378
379
380
381
382
                   , "--user-agent", userAgent
                   , "--silent", "--show-error"
                   , "--header", "Accept: text/plain"
                   ]
                ++ concat
                   [ ["--header", show name ++ ": " ++ value]
                   | Header name value <- headers ]
383
        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
384
385
386
387
                  (programInvocation prog args)
        (code, err, _etag) <- parseResponse uri resp ""
        return (code, err)

388
389
390
391
392
393
394
    -- on success these curl involcations produces an output like "200"
    -- and on failure it has the server error response first
    parseResponse uri resp headers =
      let codeerr =
            case reverse (lines resp) of
              (codeLine:rerrLines) ->
                case readMaybe (trim codeLine) of
395
                  Just i  -> let errstr = mkErrstr rerrLines
396
397
398
399
                              in Just (i, errstr)
                  Nothing -> Nothing
              []          -> Nothing

400
401
          mkErrstr = unlines . reverse . dropWhile (all isSpace)

402
403
404
405
406
407
408
409
410
411
412
413
          mb_etag :: Maybe ETag
          mb_etag  = listToMaybe $ reverse
                     [ etag
                     | ["ETag:", etag] <- map words (lines headers) ]

       in case codeerr of
            Just (i, err) -> return (i, err, mb_etag)
            _             -> statusParseFail uri resp


wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport prog =
414
    HttpTransport gethttp posthttp posthttpfile puthttpfile True False
415
  where
416
    gethttp verbosity uri etag destPath reqHeaders = do
417
        resp <- runWGet verbosity uri args
418
419
        (code, _err, etag') <- parseResponse uri resp
        return (code, etag')
420
      where
421
        args = [ "--output-document=" ++ destPath
422
423
424
425
426
427
428
               , "--user-agent=" ++ userAgent
               , "--tries=5"
               , "--timeout=15"
               , "--server-response" ]
            ++ concat
               [ ["--header", "If-None-Match: " ++ t]
               | t <- maybeToList etag ]
429
430
            ++ [ "--header=" ++ show name ++ ": " ++ value
               | Header name value <- reqHeaders ]
431

432
433
    posthttp = noPostYet

434
    posthttpfile verbosity  uri path auth =
435
436
437
438
439
440
        withTempFile (takeDirectory path)
                     (takeFileName path) $ \tmpFile tmpHandle -> do
          (body, boundary) <- generateMultipartBody path
          BS.hPut tmpHandle body
          BS.writeFile "wget.in" body
          hClose tmpHandle
441
          let args = [ "--post-file=" ++ tmpFile
442
443
                     , "--user-agent=" ++ userAgent
                     , "--server-response"
444
                     , "--header=Content-type: multipart/form-data; " ++
445
                                              "boundary=" ++ boundary ]
446
          resp <- runWGet verbosity (addUriAuth auth uri) args
447
448
449
          (code, err, _etag) <- parseResponse uri resp
          return (code, err)

450
    puthttpfile verbosity uri path auth headers = do
451
        let args = [ "--method=PUT", "--body-file="++path
452
453
454
                   , "--user-agent=" ++ userAgent
                   , "--server-response"
                   , "--header=Accept: text/plain" ]
455
456
                ++ [ "--header=" ++ show name ++ ": " ++ value
                   | Header name value <- headers ]
457

458
        resp <- runWGet verbosity (addUriAuth auth uri) args
459
460
461
        (code, err, _etag) <- parseResponse uri resp
        return (code, err)

462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
    addUriAuth Nothing uri = uri
    addUriAuth (Just (user, pass)) uri = uri
      { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }
      }
     where
      a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)

    runWGet verbosity uri args = do
        -- We pass the URI via STDIN because it contains the users' credentials
        -- and sensitive data should not be passed via command line arguments.
        let
          invocation = (programInvocation prog ("--input-file=-" : args))
            { progInvokeInput = Just (uriToString id uri "")
            }

477
478
        -- wget returns its output on stderr rather than stdout
        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity
479
                                 invocation
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
        -- wget returns exit code 8 for server "errors" like "304 not modified"
        if exitCode == ExitSuccess || exitCode == ExitFailure 8
          then return resp
          else die $ "'" ++ programPath prog
                  ++ "' exited with an error:\n" ++ resp

    -- With the --server-response flag, wget produces output with the full
    -- http server response with all headers, we want to find a line like
    -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple
    -- requests due to redirects.
    --
    -- Unfortunately wget apparently cannot be persuaded to give us the body
    -- of error responses, so we just return the human readable status message
    -- like "Forbidden" etc.
    parseResponse uri resp =
      let codeerr = listToMaybe
                    [ (code, unwords err)
                    | (protocol:codestr:err) <- map words (reverse (lines resp))
                    , "HTTP/" `isPrefixOf` protocol
                    , code <- maybeToList (readMaybe codestr) ]
          mb_etag :: Maybe ETag
          mb_etag  = listToMaybe
                    [ etag
                    | ["ETag:", etag] <- map words (reverse (lines resp)) ]
       in case codeerr of
            Just (i, err) -> return (i, err, mb_etag)
            _             -> statusParseFail uri resp


powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport prog =
511
    HttpTransport gethttp posthttp posthttpfile puthttpfile True False
512
  where
513
    gethttp verbosity uri etag destPath reqHeaders = do
Benno Fünfstück's avatar
Benno Fünfstück committed
514
      resp <- runPowershellScript verbosity $
515
        webclientScript
516
          (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))
517
518
519
520
521
522
          [ "$wc.DownloadFile(" ++ escape (show uri)
              ++ "," ++ escape destPath ++ ");"
          , "Write-Host \"200\";"
          , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");"
          ]
      parseResponse resp
523
524
525
      where
        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of
          Just i  -> return (i, Nothing) -- TODO extract real etag
526
          Nothing -> statusParseFail uri x
527
        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]
528
529
530

    posthttp = noPostYet

531
    posthttpfile verbosity uri path auth =
532
533
534
535
536
537
538
539
540
      withTempFile (takeDirectory path)
                   (takeFileName path) $ \tmpFile tmpHandle -> do
        (body, boundary) <- generateMultipartBody path
        BS.hPut tmpHandle body
        hClose tmpHandle
        fullPath <- canonicalizePath tmpFile

        let contentHeader = Header HdrContentType
              ("multipart/form-data; boundary=" ++ boundary)
Benno Fünfstück's avatar
Benno Fünfstück committed
541
        resp <- runPowershellScript verbosity $ webclientScript
542
543
544
          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
          (uploadFileAction "POST" uri fullPath)
        parseUploadResponse uri resp
545

546
547
    puthttpfile verbosity uri path auth headers = do
      fullPath <- canonicalizePath path
Benno Fünfstück's avatar
Benno Fünfstück committed
548
      resp <- runPowershellScript verbosity $ webclientScript
549
550
551
552
        (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
        (uploadFileAction "PUT" uri fullPath)
      parseUploadResponse uri resp

Benno Fünfstück's avatar
Benno Fünfstück committed
553
554
555
556
557
558
559
560
561
562
563
564
    runPowershellScript verbosity script = do
      let args =
            [ "-InputFormat", "None"
            -- the default execution policy doesn't allow running
            -- unsigned scripts, so we need to tell powershell to bypass it
            , "-ExecutionPolicy", "bypass"
            , "-NoProfile", "-NonInteractive"
            , "-Command", "-"
            ]
      getProgramInvocationOutput verbosity (programInvocation prog args)
        { progInvokeInput = Just (script ++ "\nExit(0);")
        }
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583

    escape = show

    useragentHeader = Header HdrUserAgent userAgent
    extraHeaders = [Header HdrAccept "text/plain", useragentHeader]

    setupHeaders headers =
      [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
      | Header name value <- headers
      ]

    setupAuth auth =
      [ "$wc.Credentials = new-object System.Net.NetworkCredential("
          ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"
      | (uname,passwd) <- maybeToList auth
      ]

    uploadFileAction method uri fullPath =
      [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");"
584
585
      , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ ","
        ++ show method ++ ", $fileBytes);"
586
587
588
589
590
      , "Write-Host \"200\";"
      , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"
      ]

    parseUploadResponse uri resp = case lines (trim resp) of
591
592
      (codeStr : message)
        | Just code <- readMaybe codeStr -> return (code, unlines message)
593
594
595
596
597
598
599
600
601
      _ -> statusParseFail uri resp

    webclientScript setup action = unlines
      [ "$wc = new-object system.net.webclient;"
      , unlines setup
      , "Try {"
      , unlines (map ("  " ++) action)
      , "} Catch [System.Net.WebException] {"
      , "  $exception = $_.Exception;"
602
603
      , "  If ($exception.Status -eq "
        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
604
      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"
605
606
      , "    $reader = new-object "
        ++ "System.IO.StreamReader($response.GetResponseStream());"
607
608
609
      , "    Write-Host ($response.StatusCode -as [int]);"
      , "    Write-Host $reader.ReadToEnd();"
      , "  } Else {"
610
      , "    Write-Host $exception.Message;"
611
612
      , "  }"
      , "} Catch {"
613
      , "  Write-Host $_.Exception.Message;"
614
615
      , "}"
      ]
616

617

618
619
620
------------------------------------------------------------------------------
-- The builtin plain HttpTransport
--
621

622
623
plainHttpTransport :: HttpTransport
plainHttpTransport =
624
    HttpTransport gethttp posthttp posthttpfile puthttpfile False False
625
  where
626
    gethttp verbosity uri etag destPath reqHeaders = do
627
628
629
630
      let req = Request{
                  rqURI     = uri,
                  rqMethod  = GET,
                  rqHeaders = [ Header HdrIfNoneMatch t
631
632
                              | t <- maybeToList etag ]
                           ++ reqHeaders,
633
634
635
636
637
                  rqBody    = BS.empty
                }
      (_, resp) <- cabalBrowse verbosity Nothing (request req)
      let code  = convertRspCode (rspCode resp)
          etag' = lookupHeader HdrETag (rspHeaders resp)
638
      when (code==200 || code==206) $
639
640
641
642
        writeFileAtomic destPath $ rspBody resp
      return (code, etag')

    posthttp = noPostYet
643

644
645
646
647
648
649
650
651
652
653
654
655
    posthttpfile verbosity uri path auth = do
      (body, boundary) <- generateMultipartBody path
      let headers = [ Header HdrContentType
                             ("multipart/form-data; boundary="++boundary)
                    , Header HdrContentLength (show (BS.length body))
                    , Header HdrAccept ("text/plain")
                    ]
          req = Request {
                  rqURI     = uri,
                  rqMethod  = POST,
                  rqHeaders = headers,
                  rqBody    = body
656
657
658
659
660
661
662
663
664
665
666
667
668
                }
      (_, resp) <- cabalBrowse verbosity auth (request req)
      return (convertRspCode (rspCode resp), rspErrorString resp)

    puthttpfile verbosity uri path auth headers = do
      body <- BS.readFile path
      let req = Request {
                  rqURI     = uri,
                  rqMethod  = PUT,
                  rqHeaders = Header HdrContentLength (show (BS.length body))
                            : Header HdrAccept "text/plain"
                            : headers,
                  rqBody    = body
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
                }
      (_, resp) <- cabalBrowse verbosity auth (request req)
      return (convertRspCode (rspCode resp), rspErrorString resp)

    convertRspCode (a,b,c) = a*100 + b*10 + c

    rspErrorString resp =
      case lookupHeader HdrContentType (rspHeaders resp) of
        Just contenttype
           | takeWhile (/= ';') contenttype == "text/plain"
          -> BS.unpack (rspBody resp)
        _ -> rspReason resp

    cabalBrowse verbosity auth act = do
      p <- fixupEmptyProxy <$> fetchProxy True
      Exception.handleJust
        (guard . isDoesNotExistError)
        (const . die $ "Couldn't establish HTTP connection. "
                    ++ "Possible cause: HTTP proxy server is down.") $
        browse $ do
          setProxy p
          setErrHandler (warn verbosity . ("http error: "++))
          setOutHandler (debug verbosity)
          setUserAgent  userAgent
          setAllowBasicAuth False
          setAuthorityGen (\_ _ -> return auth)
          act

    fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
    fixupEmptyProxy p = p


------------------------------------------------------------------------------
-- Common stuff used by multiple transport impls
--
704

705
706
707
708
709
userAgent :: String
userAgent = concat [ "cabal-install/", display Paths_cabal_install.version
                   , " (", display buildOS, "; ", display buildArch, ")"
                   ]

710
711
712
713
statusParseFail :: URI -> String -> IO a
statusParseFail uri r =
    die $ "Failed to download " ++ show uri ++ " : "
       ++ "No Status Code could be parsed from response: " ++ r
714

715
716
717
718
719
720
721
-- Trim
trim :: String -> String
trim = f . f
      where f = reverse . dropWhile isSpace


------------------------------------------------------------------------------
722
-- Multipart stuff partially taken from cgi package.
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
--

generateMultipartBody :: FilePath -> IO (BS.ByteString, String)
generateMultipartBody path = do
    content  <- BS.readFile path
    boundary <- genBoundary
    let !body = formatBody content (BS.pack boundary)
    return (body, boundary)
  where
    formatBody content boundary =
        BS.concat $
        [ crlf, dd, boundary, crlf ]
     ++ [ BS.pack (show header) | header <- headers ]
     ++ [ crlf
        , content
        , crlf, dd, boundary, dd, crlf ]

    headers =
      [ Header (HdrCustom "Content-disposition")
               ("form-data; name=package; " ++
                "filename=\"" ++ takeFileName path ++ "\"")
      , Header HdrContentType "application/x-gzip"
      ]

    crlf = BS.pack "\r\n"
    dd   = BS.pack "--"
749
750

genBoundary :: IO String
751
752
753
754
755
756
757
758
759
760
761
762
genBoundary = do
    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
    return $ showHex i ""

------------------------------------------------------------------------------
-- Compat utils

-- TODO: This is only here temporarily so we can release without also requiring
-- the latest Cabal lib. The function is also included in Cabal now.

getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation
                                    -> IO (String, String, ExitCode)
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
getProgramInvocationOutputAndErrors verbosity
  ProgramInvocation {
    progInvokePath  = path,
    progInvokeArgs  = args,
    progInvokeEnv   = envOverrides,
    progInvokeCwd   = mcwd,
    progInvokeInput = minputStr,
    progInvokeOutputEncoding = encoding
  } = do
    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
        decode | utf8      = fromUTF8 . normaliseLineEndings
               | otherwise = id
    menv <- getEffectiveEnvironment envOverrides
    (output, errors, exitCode) <- rawSystemStdInOut verbosity
                                    path args
                                    mcwd menv
                                    input utf8
780
    return (decode output, decode errors, exitCode)
781
782
783
784
785
786
787
788
  where
    input =
      case minputStr of
        Nothing       -> Nothing
        Just inputStr -> Just $
          case encoding of
            IOEncodingText -> (inputStr, False)
            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8