{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}
-----------------------------------------------------------------------------
-- | Separate module for HTTP actions, using a proxy server if one exists.
-----------------------------------------------------------------------------
module Distribution.Client.HttpUtils (
    DownloadResult(..),
    configureTransport,
    HttpTransport(..),
    HttpCode,
    downloadURI,
    transportCheckHttps,
    remoteRepoCheckHttps,
    remoteRepoTryUpgradeToHttps,
    isOldHackageURI
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (Proxy (..))
import Distribution.Utils.Generic

import Network.HTTP
         ( Request (..), Response (..), RequestMethod (..)
         , Header(..), HeaderName(..), lookupHeader )
import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
import Network.URI
         ( URI (..), URIAuth (..), uriToString )
import Network.Browser
         ( browse, setOutHandler, setErrHandler, setProxy
         , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )
import qualified Control.Exception as Exception
import Distribution.Simple.Utils
         ( die', info, warn, debug, notice
         , copyFileVerbose,  withTempFile, IOData (..) )
import Distribution.Client.Utils
         ( withTempFileName, cabalInstallVersion )
import Distribution.Client.Types
         ( unRepoName, RemoteRepo(..) )
import Distribution.System
         ( buildOS, buildArch )
import qualified System.FilePath.Posix as FilePath.Posix
         ( splitDirectories )
import System.FilePath
         ( (<.>), takeFileName, takeDirectory )
import System.Directory
         ( doesFileExist, renameFile, canonicalizePath )
import System.IO
         ( withFile, IOMode(ReadMode), hGetContents, hClose )
import System.IO.Error
         ( isDoesNotExistError )
import Distribution.Simple.Program
         ( Program, simpleProgram, ConfiguredProgram, programPath
         , ProgramInvocation(..), programInvocation
         , ProgramSearchPathEntry(..)
         , getProgramInvocationOutput )
import Distribution.Simple.Program.Db
         ( ProgramDb, emptyProgramDb, addKnownPrograms
         , configureAllKnownPrograms
         , requireProgram, lookupProgram
         , modifyProgramSearchPath )
import Distribution.Simple.Program.Run
         ( getProgramInvocationOutputAndErrors )
import Numeric (showHex)
import System.Random (randomRIO)

import qualified Crypto.Hash.SHA256         as SHA256
import qualified Data.ByteString.Base16     as Base16
import qualified Distribution.Compat.CharParsing as P
import qualified Data.ByteString            as BS
import qualified Data.ByteString.Char8      as BS8
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8

------------------------------------------------------------------------------
-- Downloading a URI, given an HttpTransport
--

data DownloadResult = FileAlreadyInCache
                    | FileDownloaded FilePath
  deriving (Eq)

data DownloadCheck
    = Downloaded                           -- ^ already downloaded and sha256 matches
    | CheckETag String                     -- ^ already downloaded and we have etag
    | NeedsDownload (Maybe BS.ByteString)  -- ^ needs download with optional hash check
  deriving Eq

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?

downloadURI transport verbosity uri path = do

    targetExists <- doesFileExist path

    downloadCheck <-
      -- if we have uriFrag, then we expect there to be #sha256=...
      if not (null uriFrag)
      then case sha256parsed of
        -- we know the hash, and target exists
        Right expected | targetExists -> do
          contents <- LBS.readFile path
          let actual = SHA256.hashlazy contents
          if expected == actual
          then return Downloaded
          else return (NeedsDownload (Just expected))

        -- we known the hash, target doesn't exist
        Right expected -> return (NeedsDownload (Just expected))

        -- we failed to parse uriFragment
        Left err -> die' verbosity $
          "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err

      -- if there are no uri fragment, use ETag
      else do
        etagPathExists <- doesFileExist etagPath
        -- In rare cases the target file doesn't exist, but the etag does.
        if targetExists && etagPathExists
        then return (CheckETag etagPath)
        else return (NeedsDownload 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

    case downloadCheck of
      Downloaded         -> return FileAlreadyInCache
      CheckETag etag     -> makeDownload transport' Nothing (Just etag)
      NeedsDownload hash -> makeDownload transport' hash Nothing

  where
    makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do
      result <- getHttp transport' verbosity uri etag tmpFile []

      -- Only write the etag if we get a 200 response code.
      -- A 304 still sends us an etag header.
      case result of
        -- if we have hash, we don't care about etag.
        (200, _) | Just expected <- sha256 -> do
          contents <- LBS.readFile tmpFile
          let actual = SHA256.hashlazy contents
          unless (actual == expected) $
            die' verbosity $ unwords
              [ "Failed to download", show uri
              , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)
              , "actual:", BS8.unpack (Base16.encode actual)
              ]

        (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' verbosity $ "failed to download " ++ show uri
                       ++ " : HTTP code " ++ show errCode

    etagPath = path <.> "etag"
    uriFrag = uriFragment uri

    sha256parsed :: Either String BS.ByteString
    sha256parsed = explicitEitherParsec fragmentParser uriFrag

    fragmentParser = do
        _ <- P.string "#sha256="
        str <- some P.hexDigit
        let bs = Base16.decode (BS8.pack str)
#if MIN_VERSION_base16_bytestring(1,0,0)
        either fail return bs
#else
        return (fst bs)
#endif

------------------------------------------------------------------------------
-- Utilities for repo url management
--

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

transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps verbosity transport uri
  | uriScheme uri == "https:"
  , not (transportSupportsHttps transport)
              = die' verbosity $ "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 :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps verbosity transport repo
  | remoteRepoShouldTryHttps repo
  , uriScheme (remoteRepoURI repo) == "http:"
  , not (transportSupportsHttps transport)
  , not (transportManuallySelected transport)
  = die' verbosity $ "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

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


------------------------------------------------------------------------------
-- Setting up a HttpTransport
--

data HttpTransport = HttpTransport {
      -- | 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.
      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
               -> 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
                   -> IO (HttpCode, String),

      -- | 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),

      -- | Whether this transport supports https or just http.
      transportSupportsHttps :: Bool,

      -- | Whether this transport implementation was specifically chosen by
      -- the user via configuration, or whether it was automatically selected.
      -- 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
    }
    --TODO: why does postHttp return a redirect, but postHttpFile return errors?

type HttpCode = Int
type ETag     = String
type Auth     = (String, String)

noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)
          -> IO (Int, String)
noPostYet verbosity _ _ _ = die' verbosity "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 )

    , 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 )
    ]

configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport

configureTransport verbosity extraPath (Just name) =
    -- the user specifically 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

        let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
        progdb <- case mprog of
          Nothing   -> return emptyProgramDb
          Just prog -> snd <$> requireProgram verbosity prog baseProgDb
                       --      ^^ if it fails, it'll fail here

        let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
        return transport { transportManuallySelected = True }

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

configureTransport verbosity extraPath 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
    let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
    progdb <- configureAllKnownPrograms  verbosity $
                addKnownPrograms
                  [ prog | (_, Just prog, _, _) <- supportedTransports ]
                  baseProgDb

    let availableTransports =
          [ (name, transport)
          | (name, _, _, mkTrans) <- supportedTransports
          , transport <- maybeToList (mkTrans progdb) ]
    let (name, transport) =
         fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)
    debug verbosity $ "Selected http transport implementation: " ++ name

    return transport { transportManuallySelected = False }


------------------------------------------------------------------------------
-- The HttpTransports based on external programs
--

curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport prog =
    HttpTransport gethttp posthttp posthttpfile puthttpfile True False
  where
    gethttp verbosity uri etag destPath reqHeaders = do
        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 ]
                ++ concat
                   [ ["--header", show name ++ ": " ++ value]
                   | Header name value <- reqHeaders ]

          resp <- getProgramInvocationOutput verbosity
                    (programInvocation prog args)
          withFile tmpFile ReadMode $ \hnd -> do
            headers <- hGetContents hnd
            (code, _err, etag') <- parseResponse verbosity uri resp headers
            evaluate $ force (code, etag')

    posthttp = noPostYet

    addAuthConfig auth progInvocation = progInvocation
      { progInvokeInput = do
          (uname, passwd) <- auth
          return $ IODataText $ unlines
            [ "--digest"
            , "--user " ++ uname ++ ":" ++ passwd
            ]
      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
      }

    posthttpfile verbosity uri path auth = do
        let args = [ show uri
                   , "--form", "package=@"++path
                   , "--write-out", "\n%{http_code}"
                   , "--user-agent", userAgent
                   , "--silent", "--show-error"
                   , "--header", "Accept: text/plain"
                   , "--location"
                   ]
        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
                  (programInvocation prog args)
        (code, err, _etag) <- parseResponse verbosity uri resp ""
        return (code, err)

    puthttpfile verbosity uri path auth headers = do
        let args = [ show uri
                   , "--request", "PUT", "--data-binary", "@"++path
                   , "--write-out", "\n%{http_code}"
                   , "--user-agent", userAgent
                   , "--silent", "--show-error"
                   , "--location"
                   , "--header", "Accept: text/plain"
                   ]
                ++ concat
                   [ ["--header", show name ++ ": " ++ value]
                   | Header name value <- headers ]
        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth
                  (programInvocation prog args)
        (code, err, _etag) <- parseResponse verbosity uri resp ""
        return (code, err)

    -- on success these curl invocations produces an output like "200"
    -- and on failure it has the server error response first
    parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)
    parseResponse verbosity uri resp headers =
      let codeerr =
            case reverse (lines resp) of
              (codeLine:rerrLines) ->
                case readMaybe (trim codeLine) of
                  Just i  -> let errstr = mkErrstr rerrLines
                              in Just (i, errstr)
                  Nothing -> Nothing
              []          -> Nothing

          mkErrstr = unlines . reverse . dropWhile (all isSpace)

          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 verbosity uri resp


wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport prog =
  HttpTransport gethttp posthttp posthttpfile puthttpfile True False
  where
    gethttp verbosity uri etag destPath reqHeaders =  do
        resp <- runWGet verbosity uri args

        -- wget doesn't support range requests.
        -- so, we not only ignore range request headers,
        -- but we also dispay a warning message when we see them.
        let hasRangeHeader =  any isRangeHeader reqHeaders
            warningMsg     =  "the 'wget' transport currently doesn't support"
                           ++ " range requests, which wastes network bandwidth."
                           ++ " To fix this, set 'http-transport' to 'curl' or"
                           ++ " 'plain-http' in '~/.cabal/config'."
                           ++ " Note that the 'plain-http' transport doesn't"
                           ++ " support HTTPS.\n"

        when (hasRangeHeader) $ warn verbosity warningMsg
        (code, etag') <- parseOutput verbosity uri resp
        return (code, etag')
      where
        args = [ "--output-document=" ++ destPath
               , "--user-agent=" ++ userAgent
               , "--tries=5"
               , "--timeout=15"
               , "--server-response" ]
            ++ concat
               [ ["--header", "If-None-Match: " ++ t]
               | t <- maybeToList etag ]
            ++ [ "--header=" ++ show name ++ ": " ++ value
               | hdr@(Header name value) <- reqHeaders
               , (not (isRangeHeader hdr)) ]

        -- wget doesn't support range requests.
        -- so, we ignore range request headers, lest we get errors.
        isRangeHeader :: Header -> Bool
        isRangeHeader (Header HdrRange _) = True
        isRangeHeader _ = False

    posthttp = noPostYet

    posthttpfile verbosity  uri path auth =
        withTempFile (takeDirectory path)
                     (takeFileName path) $ \tmpFile tmpHandle ->
        withTempFile (takeDirectory path) "response" $
        \responseFile responseHandle -> do
          hClose responseHandle
          (body, boundary) <- generateMultipartBody path
          LBS.hPut tmpHandle body
          hClose tmpHandle
          let args = [ "--post-file=" ++ tmpFile
                     , "--user-agent=" ++ userAgent
                     , "--server-response"
                     , "--output-document=" ++ responseFile
                     , "--header=Accept: text/plain"
                     , "--header=Content-type: multipart/form-data; " ++
                                              "boundary=" ++ boundary ]
          out <- runWGet verbosity (addUriAuth auth uri) args
          (code, _etag) <- parseOutput verbosity uri out
          withFile responseFile ReadMode $ \hnd -> do
            resp <- hGetContents hnd
            evaluate $ force (code, resp)

    puthttpfile verbosity uri path auth headers =
        withTempFile (takeDirectory path) "response" $
        \responseFile responseHandle -> do
            hClose responseHandle
            let args = [ "--method=PUT", "--body-file="++path
                       , "--user-agent=" ++ userAgent
                       , "--server-response"
                       , "--output-document=" ++ responseFile
                       , "--header=Accept: text/plain" ]
                    ++ [ "--header=" ++ show name ++ ": " ++ value
                       | Header name value <- headers ]

            out <- runWGet verbosity (addUriAuth auth uri) args
            (code, _etag) <- parseOutput verbosity uri out
            withFile responseFile ReadMode $ \hnd -> do
              resp <- hGetContents hnd
              evaluate $ force (code, resp)

    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 $ IODataText $ uriToString id uri ""
            }

        -- wget returns its output on stderr rather than stdout
        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity
                                 invocation
        -- wget returns exit code 8 for server "errors" like "304 not modified"
        if exitCode == ExitSuccess || exitCode == ExitFailure 8
          then return resp
          else die' verbosity $ "'" ++ 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.
    parseOutput verbosity uri resp =
      let parsedCode = listToMaybe
                     [ code
                     | (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 parsedCode of
            Just i -> return (i, mb_etag)
            _      -> statusParseFail verbosity uri resp


powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport prog =
    HttpTransport gethttp posthttp posthttpfile puthttpfile True False
  where
    gethttp verbosity uri etag destPath reqHeaders = do
      resp <- runPowershellScript verbosity $
        webclientScript
          (escape (show uri))
          (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
          :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))
          [ "$response = $request.GetResponse()"
          , "$responseStream = $response.GetResponseStream()"
          , "$buffer = new-object byte[] 10KB"
          , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
          , "while ($count -gt 0)"
          , "{"
          , "    $targetStream.Write($buffer, 0, $count)"
          , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"
          , "}"
          , "Write-Host ($response.StatusCode -as [int]);"
          , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
          ]
          [ "$targetStream.Flush()"
          , "$targetStream.Close()"
          , "$targetStream.Dispose()"
          , "$responseStream.Dispose()"
          ]
      parseResponse resp
      where
        parseResponse :: String -> IO (HttpCode, Maybe ETag)
        parseResponse x =
          case lines $ trim x of
            (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
            (code:      _) -> fmap (\c -> (c, Nothing  )) $ parseCode code x
            _              -> statusParseFail verbosity uri x
        parseCode :: String -> String -> IO HttpCode
        parseCode code x = case readMaybe code of
          Just i  -> return i
          Nothing -> statusParseFail verbosity uri x
        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]

    posthttp = noPostYet

    posthttpfile verbosity uri path auth =
      withTempFile (takeDirectory path)
                   (takeFileName path) $ \tmpFile tmpHandle -> do
        (body, boundary) <- generateMultipartBody path
        LBS.hPut tmpHandle body
        hClose tmpHandle
        fullPath <- canonicalizePath tmpFile

        let contentHeader = Header HdrContentType
              ("multipart/form-data; boundary=" ++ boundary)
        resp <- runPowershellScript verbosity $ webclientScript
          (escape (show uri))
          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
          (uploadFileAction "POST" uri fullPath)
          uploadFileCleanup
        parseUploadResponse verbosity uri resp

    puthttpfile verbosity uri path auth headers = do
      fullPath <- canonicalizePath path
      resp <- runPowershellScript verbosity $ webclientScript
        (escape (show uri))
        (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
        (uploadFileAction "PUT" uri fullPath)
        uploadFileCleanup
      parseUploadResponse verbosity uri resp

    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", "-"
            ]
      debug verbosity script
      getProgramInvocationOutput verbosity (programInvocation prog args)
        { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"
        }

    escape = show

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

    setupHeaders headers =
      [ "$request." ++ addHeader name value
      | Header name value <- headers
      ]
      where
        addHeader header value
          = case header of
              HdrAccept           -> "Accept = "           ++ escape value
              HdrUserAgent        -> "UserAgent = "        ++ escape value
              HdrConnection       -> "Connection = "       ++ escape value
              HdrContentLength    -> "ContentLength = "    ++ escape value
              HdrContentType      -> "ContentType = "      ++ escape value
              HdrDate             -> "Date = "             ++ escape value
              HdrExpect           -> "Expect = "           ++ escape value
              HdrHost             -> "Host = "             ++ escape value
              HdrIfModifiedSince  -> "IfModifiedSince = "  ++ escape value
              HdrReferer          -> "Referer = "          ++ escape value
              HdrTransferEncoding -> "TransferEncoding = " ++ escape value
              HdrRange            -> let (start, end) =
                                          if "bytes=" `isPrefixOf` value
                                             then case break (== '-') value' of
                                                 (start', '-':end') -> (start', end')
                                                 _                  -> error $ "Could not decode range: " ++ value
                                             else error $ "Could not decode range: " ++ value
                                         value' = drop 6 value
                                     in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
              name                -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"

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

    uploadFileAction method _uri fullPath =
      [ "$request.Method = " ++ show method
      , "$requestStream = $request.GetRequestStream()"
      , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"
      , "$bufSize=10000"
      , "$chunk = New-Object byte[] $bufSize"
      , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"
      , "{"
      , "  $requestStream.write($chunk, 0, $bytesRead)"
      , "  $requestStream.Flush()"
      , "}"
      , ""
      , "$responseStream = $request.getresponse()"
      , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"
      , "$code = $response.StatusCode -as [int]"
      , "if ($code -eq 0) {"
      , "  $code = 200;"
      , "}"
      , "Write-Host $code"
      , "Write-Host $responseReader.ReadToEnd()"
      ]

    uploadFileCleanup =
      [ "$fileStream.Close()"
      , "$requestStream.Close()"
      , "$responseStream.Close()"
      ]

    parseUploadResponse verbosity uri resp = case lines (trim resp) of
      (codeStr : message)
        | Just code <- readMaybe codeStr -> return (code, unlines message)
      _ -> statusParseFail verbosity uri resp

    webclientScript uri setup action cleanup = unlines
      [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
      , "$uri = New-Object \"System.Uri\" " ++ uri
      , "$request = [System.Net.HttpWebRequest]::Create($uri)"
      , unlines setup
      , "Try {"
      , unlines (map ("  " ++) action)
      , "} Catch [System.Net.WebException] {"
      , "  $exception = $_.Exception;"
      , "  If ($exception.Status -eq "
        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"
      , "    $reader = new-object "
        ++ "System.IO.StreamReader($response.GetResponseStream());"
      , "    Write-Host ($response.StatusCode -as [int]);"
      , "    Write-Host $reader.ReadToEnd();"
      , "  } Else {"
      , "    Write-Host $exception.Message;"
      , "  }"
      , "} Catch {"
      , "  Write-Host $_.Exception.Message;"
      , "} finally {"
      , unlines (map ("  " ++) cleanup)
      , "}"
      ]


------------------------------------------------------------------------------
-- The builtin plain HttpTransport
--

plainHttpTransport :: HttpTransport
plainHttpTransport =
    HttpTransport gethttp posthttp posthttpfile puthttpfile False False
  where
    gethttp verbosity uri etag destPath reqHeaders = do
      let req = Request{
                  rqURI     = uri,
                  rqMethod  = GET,
                  rqHeaders = [ Header HdrIfNoneMatch t
                              | t <- maybeToList etag ]
                           ++ reqHeaders,
                  rqBody    = LBS.empty
                }
      (_, resp) <- cabalBrowse verbosity Nothing (request req)
      let code  = convertRspCode (rspCode resp)
          etag' = lookupHeader HdrETag (rspHeaders resp)
      -- 206 Partial Content is a normal response to a range request; see #3385.
      when (code==200 || code==206) $
        writeFileAtomic destPath $ rspBody resp
      return (code, etag')

    posthttp = noPostYet

    posthttpfile verbosity uri path auth = do
      (body, boundary) <- generateMultipartBody path
      let headers = [ Header HdrContentType
                             ("multipart/form-data; boundary="++boundary)
                    , Header HdrContentLength (show (LBS8.length body))
                    , Header HdrAccept ("text/plain")
                    ]
          req = Request {
                  rqURI     = uri,
                  rqMethod  = POST,
                  rqHeaders = headers,
                  rqBody    = body
                }
      (_, resp) <- cabalBrowse verbosity auth (request req)
      return (convertRspCode (rspCode resp), rspErrorString resp)

    puthttpfile verbosity uri path auth headers = do
      body <- LBS8.readFile path
      let req = Request {
                  rqURI     = uri,
                  rqMethod  = PUT,
                  rqHeaders = Header HdrContentLength (show (LBS8.length body))
                            : Header HdrAccept "text/plain"
                            : headers,
                  rqBody    = body
                }
      (_, 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"
          -> LBS8.unpack (rspBody resp)
        _ -> rspReason resp

    cabalBrowse verbosity auth act = do
      p <- fixupEmptyProxy <$> fetchProxy True
      Exception.handleJust
        (guard . isDoesNotExistError)
        (const . die' verbosity $ "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
--

userAgent :: String
userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion
                   , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"
                   ]

statusParseFail :: Verbosity -> URI -> String -> IO a
statusParseFail verbosity uri r =
    die' verbosity $ "Failed to download " ++ show uri ++ " : "
       ++ "No Status Code could be parsed from response: " ++ r

-- Trim
trim :: String -> String
trim = f . f
      where f = reverse . dropWhile isSpace


------------------------------------------------------------------------------
-- Multipart stuff partially taken from cgi package.
--

generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
generateMultipartBody path = do
    content  <- LBS.readFile path
    boundary <- genBoundary
    let !body = formatBody content (LBS8.pack boundary)
    return (body, boundary)
  where
    formatBody content boundary =
        LBS8.concat $
        [ crlf, dd, boundary, crlf ]
     ++ [ LBS8.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 = LBS8.pack "\r\n"
    dd   = LBS8.pack "--"

genBoundary :: IO String
genBoundary = do
    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
    return $ showHex i ""
