{-# 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.Utils.String (trim)
import Distribution.Client.Utils
         ( withTempFileName )
import Distribution.Client.Version
         ( 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 (DownloadResult -> DownloadResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DownloadResult -> DownloadResult -> Bool
$c/= :: DownloadResult -> DownloadResult -> Bool
== :: DownloadResult -> DownloadResult -> Bool
$c== :: DownloadResult -> DownloadResult -> Bool
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 DownloadCheck -> DownloadCheck -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DownloadCheck -> DownloadCheck -> Bool
$c/= :: DownloadCheck -> DownloadCheck -> Bool
== :: DownloadCheck -> DownloadCheck -> Bool
$c== :: DownloadCheck -> DownloadCheck -> Bool
Eq

downloadURI :: HttpTransport
            -> Verbosity
            -> URI      -- ^ What to download
            -> FilePath -- ^ Where to put it
            -> IO DownloadResult
downloadURI :: HttpTransport -> Verbosity -> URI -> String -> IO DownloadResult
downloadURI HttpTransport
_transport Verbosity
verbosity URI
uri String
path | URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"file:" = do
  Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
verbosity (URI -> String
uriPath URI
uri) String
path
  forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadResult
FileDownloaded String
path)
  -- Can we store the hash of the file so we can safely return path when the
  -- hash matches to avoid unnecessary computation?

downloadURI HttpTransport
transport Verbosity
verbosity URI
uri String
path = do

    Bool
targetExists <- String -> IO Bool
doesFileExist String
path

    DownloadCheck
downloadCheck <-
      -- if we have uriFrag, then we expect there to be #sha256=...
      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriFrag)
      then case Either String ByteString
sha256parsed of
        -- we know the hash, and target exists
        Right ByteString
expected | Bool
targetExists -> do
          ByteString
contents <- String -> IO ByteString
LBS.readFile String
path
          let actual :: ByteString
actual = ByteString -> ByteString
SHA256.hashlazy ByteString
contents
          if ByteString
expected forall a. Eq a => a -> a -> Bool
== ByteString
actual
          then forall (m :: * -> *) a. Monad m => a -> m a
return DownloadCheck
Downloaded
          else forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload (forall a. a -> Maybe a
Just ByteString
expected))

        -- we known the hash, target doesn't exist
        Right ByteString
expected -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload (forall a. a -> Maybe a
Just ByteString
expected))

        -- we failed to parse uriFragment
        Left String
err -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
          String
"Cannot parse URI fragment " forall a. [a] -> [a] -> [a]
++ String
uriFrag forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
err

      -- if there are no uri fragment, use ETag
      else do
        Bool
etagPathExists <- String -> IO Bool
doesFileExist String
etagPath
        -- In rare cases the target file doesn't exist, but the etag does.
        if Bool
targetExists Bool -> Bool -> Bool
&& Bool
etagPathExists
        then forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadCheck
CheckETag String
etagPath)
        else forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload forall a. Maybe a
Nothing)

    -- Only use the external http transports if we actually have to
    -- (or have been told to do so)
    let transport' :: HttpTransport
transport'
          | URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"http:"
          , Bool -> Bool
not (HttpTransport -> Bool
transportManuallySelected HttpTransport
transport)
          = HttpTransport
plainHttpTransport

          | Bool
otherwise
          = HttpTransport
transport

    case DownloadCheck
downloadCheck of
      DownloadCheck
Downloaded         -> forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
      CheckETag String
etag     -> HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
etag)
      NeedsDownload Maybe ByteString
hash -> HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' Maybe ByteString
hash forall a. Maybe a
Nothing

  where
    makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult
    makeDownload :: HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' Maybe ByteString
sha256 Maybe String
etag = forall a. String -> String -> (String -> IO a) -> IO a
withTempFileName (String -> String
takeDirectory String
path) (String -> String
takeFileName String
path) forall a b. (a -> b) -> a -> b
$ \String
tmpFile -> do
      (HttpCode, Maybe String)
result <- HttpTransport
-> Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
getHttp HttpTransport
transport' Verbosity
verbosity URI
uri Maybe String
etag String
tmpFile []

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

        (HttpCode
200, Just String
newEtag) -> String -> String -> IO ()
writeFile String
etagPath String
newEtag
        (HttpCode, Maybe String)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      case forall a b. (a, b) -> a
fst (HttpCode, Maybe String)
result of
        HttpCode
200 -> do
            Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Downloaded to " forall a. [a] -> [a] -> [a]
++ String
path)
            String -> String -> IO ()
renameFile String
tmpFile String
path
            forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadResult
FileDownloaded String
path)
        HttpCode
304 -> do
            Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Skipping download: local and remote files match."
            forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
        HttpCode
errCode ->  forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"failed to download " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri
                       forall a. [a] -> [a] -> [a]
++ String
" : HTTP code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HttpCode
errCode

    etagPath :: String
etagPath = String
path String -> String -> String
<.> String
"etag"
    uriFrag :: String
uriFrag = URI -> String
uriFragment URI
uri

    sha256parsed :: Either String BS.ByteString
    sha256parsed :: Either String ByteString
sha256parsed = forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser ByteString
fragmentParser String
uriFrag

    fragmentParser :: ParsecParser ByteString
fragmentParser = do
        String
_ <- forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"#sha256="
        String
str <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
P.hexDigit
        let bs :: Either String ByteString
bs = ByteString -> Either String ByteString
Base16.decode (String -> ByteString
BS8.pack String
str)
#if MIN_VERSION_base16_bytestring(1,0,0)
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return Either String ByteString
bs
#else
        return (fst bs)
#endif

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

remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps Verbosity
verbosity HttpTransport
transport RemoteRepo
repo
  | URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) forall a. Eq a => a -> a -> Bool
== String
"https:"
  , Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
  = forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The remote repository '" forall a. [a] -> [a] -> [a]
++ RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
    forall a. [a] -> [a] -> [a]
++ String
"' specifies a URL that " forall a. [a] -> [a] -> [a]
++ String
requiresHttpsErrorMessage
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps Verbosity
verbosity HttpTransport
transport URI
uri
  | URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"https:"
  , Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
              = forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The URL " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri
                   forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
requiresHttpsErrorMessage
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

  | RemoteRepo -> Bool
remoteRepoShouldTryHttps RemoteRepo
repo
  , URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) forall a. Eq a => a -> a -> Bool
== String
"http:"
  , HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport
  = forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
repo {
      remoteRepoURI :: URI
remoteRepoURI = (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) { uriScheme :: String
uriScheme = String
"https:" }
    }

  | Bool
otherwise
  = forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
repo

-- | Utility function for legacy support.
isOldHackageURI :: URI -> Bool
isOldHackageURI :: URI -> Bool
isOldHackageURI URI
uri
    = case URI -> Maybe URIAuth
uriAuthority URI
uri of
        Just (URIAuth {uriRegName :: URIAuth -> String
uriRegName = String
"hackage.haskell.org"}) ->
            String -> [String]
FilePath.Posix.splitDirectories (URI -> String
uriPath URI
uri)
            forall a. Eq a => a -> a -> Bool
== [String
"/",String
"packages",String
"archive"]
        Maybe URIAuth
_ -> Bool
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.
      HttpTransport
-> Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
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.
      HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> IO (HttpCode, String)
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.
      HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> IO (HttpCode, 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.
      HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String)
putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]
                  -> IO (HttpCode, String),

      -- | Whether this transport supports https or just http.
      HttpTransport -> Bool
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.
      HttpTransport -> Bool
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 -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet Verbosity
verbosity URI
_ String
_ Maybe Auth
_ = forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Posting (for report upload) is not implemented yet"

supportedTransports :: [(String, Maybe Program, Bool,
                         ProgramDb -> Maybe HttpTransport)]
supportedTransports :: [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports =
    [ let prog :: Program
prog = String -> Program
simpleProgram String
"curl" in
      ( String
"curl", forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
curlTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )

    , let prog :: Program
prog = String -> Program
simpleProgram String
"wget" in
      ( String
"wget", forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
wgetTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )

    , let prog :: Program
prog = String -> Program
simpleProgram String
"powershell" in
      ( String
"powershell", forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
powershellTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )

    , ( String
"plain-http", forall a. Maybe a
Nothing, Bool
False
      , \ProgramDb
_ -> forall a. a -> Maybe a
Just HttpTransport
plainHttpTransport )
    ]

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

configureTransport :: Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity [String]
extraPath (Just String
name) =
    -- the user specifically selected a transport by name so we'll try and
    -- configure that one

    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(String
name',Maybe Program
_,Bool
_,ProgramDb -> Maybe HttpTransport
_) -> String
name' forall a. Eq a => a -> a -> Bool
== String
name) [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports of
      Just (String
_, Maybe Program
mprog, Bool
_tls, ProgramDb -> Maybe HttpTransport
mkTrans) -> do

        let baseProgDb :: ProgramDb
baseProgDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath (\ProgramSearchPath
p -> forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
        ProgramDb
progdb <- case Maybe Program
mprog of
          Maybe Program
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return ProgramDb
emptyProgramDb
          Just Program
prog -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
prog ProgramDb
baseProgDb
                       --      ^^ if it fails, it'll fail here

        let transport :: HttpTransport
transport = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"configureTransport: failed to make transport") forall a b. (a -> b) -> a -> b
$ ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb
        forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected :: Bool
transportManuallySelected = Bool
True }

      Maybe
  (String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)
Nothing -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Unknown HTTP transport specified: " forall a. [a] -> [a] -> [a]
++ String
name
                    forall a. [a] -> [a] -> [a]
++ String
". The supported transports are "
                    forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                         [ String
name' | (String
name', Maybe Program
_, Bool
_, ProgramDb -> Maybe HttpTransport
_ ) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]

configureTransport Verbosity
verbosity [String]
extraPath Maybe String
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 :: ProgramDb
baseProgDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath (\ProgramSearchPath
p -> forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
    ProgramDb
progdb <- Verbosity -> ProgramDb -> IO ProgramDb
configureAllKnownPrograms  Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
                [Program] -> ProgramDb -> ProgramDb
addKnownPrograms
                  [ Program
prog | (String
_, Just Program
prog, Bool
_, ProgramDb -> Maybe HttpTransport
_) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]
                  ProgramDb
baseProgDb

    let availableTransports :: [(String, HttpTransport)]
availableTransports =
          [ (String
name, HttpTransport
transport)
          | (String
name, Maybe Program
_, Bool
_, ProgramDb -> Maybe HttpTransport
mkTrans) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports
          , HttpTransport
transport <- forall a. Maybe a -> [a]
maybeToList (ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb) ]
    let (String
name, HttpTransport
transport) =
         forall a. a -> Maybe a -> a
fromMaybe (String
"plain-http", HttpTransport
plainHttpTransport) (forall a. [a] -> Maybe a
safeHead [(String, HttpTransport)]
availableTransports)
    Verbosity -> String -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Selected http transport implementation: " forall a. [a] -> [a] -> [a]
++ String
name

    forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected :: Bool
transportManuallySelected = Bool
False }


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

curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport ConfiguredProgram
prog =
    (Verbosity
 -> URI
 -> Maybe String
 -> String
 -> [Header]
 -> IO (HttpCode, Maybe String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI
    -> String
    -> Maybe Auth
    -> [Header]
    -> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Bool
True Bool
False
  where
    gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
        forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
destPath)
                     String
"curl-headers.txt" forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle -> do
          Handle -> IO ()
hClose Handle
tmpHandle
          let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
                   , String
"--output", String
destPath
                   , String
"--location"
                   , String
"--write-out", String
"%{http_code}"
                   , String
"--user-agent", String
userAgent
                   , String
"--silent", String
"--show-error"
                   , String
"--dump-header", String
tmpFile ]
                forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                   [ [String
"--header", String
"If-None-Match: " forall a. [a] -> [a] -> [a]
++ String
t]
                   | String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
                forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                   [ [String
"--header", forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value]
                   | Header HeaderName
name String
value <- [Header]
reqHeaders ]

          String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig forall a. Maybe a
Nothing URI
uri
                    (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)

          forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tmpFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
            String
headers <- Handle -> IO String
hGetContents Handle
hnd
            (HttpCode
code, String
_err, Maybe String
etag') <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
headers
            forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (HttpCode
code, Maybe String
etag')

    posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet

    addAuthConfig :: Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
explicitAuth URI
uri ProgramInvocation
progInvocation = do
      -- attempt to derive a u/p pair from the uri authority if one exists
      -- all `uriUserInfo` values have '@' as a suffix. drop it.
      let uriDerivedAuth :: Maybe String
uriDerivedAuth = case URI -> Maybe URIAuth
uriAuthority URI
uri of
                               (Just (URIAuth String
u String
_ String
_)) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'@') String
u
                               Maybe URIAuth
_ -> forall a. Maybe a
Nothing
      -- prefer passed in auth to auth derived from uri. If neither exist, then no auth
      let mbAuthString :: Maybe String
mbAuthString = case (Maybe Auth
explicitAuth, Maybe String
uriDerivedAuth) of
                          (Just (String
uname, String
passwd), Maybe String
_) -> forall a. a -> Maybe a
Just (String
uname forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
passwd)
                          (Maybe Auth
Nothing, Just String
a) -> forall a. a -> Maybe a
Just String
a
                          (Maybe Auth
Nothing, Maybe String
Nothing) -> forall a. Maybe a
Nothing
      case Maybe String
mbAuthString of
        Just String
up -> ProgramInvocation
progInvocation
          { progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOData
IODataText forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
              [ String
"--digest"
              , String
"--user " forall a. [a] -> [a] -> [a]
++ String
up
              ]
          , progInvokeArgs :: [String]
progInvokeArgs = [String
"--config", String
"-"] forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> [String]
progInvokeArgs ProgramInvocation
progInvocation
          }
        Maybe String
Nothing -> ProgramInvocation
progInvocation

    posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth = do
        let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
                   , String
"--form", String
"package=@"forall a. [a] -> [a] -> [a]
++String
path
                   , String
"--write-out", String
"\n%{http_code}"
                   , String
"--user-agent", String
userAgent
                   , String
"--silent", String
"--show-error"
                   , String
"--header", String
"Accept: text/plain"
                   , String
"--location"
                   ]
        String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
auth URI
uri
                  (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
        (HttpCode
code, String
err, Maybe String
_etag) <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
""
        forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, String
err)

    puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
        let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
                   , String
"--request", String
"PUT", String
"--data-binary", String
"@"forall a. [a] -> [a] -> [a]
++String
path
                   , String
"--write-out", String
"\n%{http_code}"
                   , String
"--user-agent", String
userAgent
                   , String
"--silent", String
"--show-error"
                   , String
"--location"
                   , String
"--header", String
"Accept: text/plain"
                   ]
                forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                   [ [String
"--header", forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value]
                   | Header HeaderName
name String
value <- [Header]
headers ]
        String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
auth URI
uri
                  (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
        (HttpCode
code, String
err, Maybe String
_etag) <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
""
        forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, String
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 -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
headers =
      let codeerr :: Maybe (HttpCode, String)
codeerr =
            case forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp) of
              (String
codeLine:[String]
rerrLines) ->
                case forall a. Read a => String -> Maybe a
readMaybe (String -> String
trim String
codeLine) of
                  Just HttpCode
i  -> let errstr :: String
errstr = [String] -> String
mkErrstr [String]
rerrLines
                              in forall a. a -> Maybe a
Just (HttpCode
i, String
errstr)
                  Maybe HttpCode
Nothing -> forall a. Maybe a
Nothing
              []          -> forall a. Maybe a
Nothing

          mkErrstr :: [String] -> String
mkErrstr = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace)

          mb_etag :: Maybe ETag
          mb_etag :: Maybe String
mb_etag  = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
                     [ String
etag
                     | [String
"ETag:", String
etag] <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (String -> [String]
lines String
headers) ]

       in case Maybe (HttpCode, String)
codeerr of
            Just (HttpCode
i, String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
i, String
err, Maybe String
mb_etag)
            Maybe (HttpCode, String)
_             -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp


wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport ConfiguredProgram
prog =
  (Verbosity
 -> URI
 -> Maybe String
 -> String
 -> [Header]
 -> IO (HttpCode, Maybe String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI
    -> String
    -> Maybe Auth
    -> [Header]
    -> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport forall {a}.
Read a =>
Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (a, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp forall {a}.
(Read a, NFData a) =>
Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile forall {a}.
(Read a, NFData a) =>
Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Bool
True Bool
False
  where
    gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (a, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders =  do
        String
resp <- Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity URI
uri [String]
args

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

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasRangeHeader) forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity String
warningMsg
        (a
code, Maybe String
etag') <- forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
resp
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, Maybe String
etag')
      where
        args :: [String]
args = [ String
"--output-document=" forall a. [a] -> [a] -> [a]
++ String
destPath
               , String
"--user-agent=" forall a. [a] -> [a] -> [a]
++ String
userAgent
               , String
"--tries=5"
               , String
"--timeout=15"
               , String
"--server-response" ]
            forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
               [ [String
"--header", String
"If-None-Match: " forall a. [a] -> [a] -> [a]
++ String
t]
               | String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
            forall a. [a] -> [a] -> [a]
++ [ String
"--header=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value
               | hdr :: Header
hdr@(Header HeaderName
name String
value) <- [Header]
reqHeaders
               , (Bool -> Bool
not (Header -> Bool
isRangeHeader Header
hdr)) ]

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

    posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet

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

    puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers =
        forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path) String
"response" forall a b. (a -> b) -> a -> b
$
        \String
responseFile Handle
responseHandle -> do
            Handle -> IO ()
hClose Handle
responseHandle
            let args :: [String]
args = [ String
"--method=PUT", String
"--body-file="forall a. [a] -> [a] -> [a]
++String
path
                       , String
"--user-agent=" forall a. [a] -> [a] -> [a]
++ String
userAgent
                       , String
"--server-response"
                       , String
"--output-document=" forall a. [a] -> [a] -> [a]
++ String
responseFile
                       , String
"--header=Accept: text/plain" ]
                    forall a. [a] -> [a] -> [a]
++ [ String
"--header=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value
                       | Header HeaderName
name String
value <- [Header]
headers ]

            String
out <- Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity (Maybe Auth -> URI -> URI
addUriAuth Maybe Auth
auth URI
uri) [String]
args
            (a
code, Maybe String
_etag) <- forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
out
            forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
responseFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
              String
resp <- Handle -> IO String
hGetContents Handle
hnd
              forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (a
code, String
resp)

    addUriAuth :: Maybe Auth -> URI -> URI
addUriAuth Maybe Auth
Nothing URI
uri = URI
uri
    addUriAuth (Just (String
user, String
pass)) URI
uri = URI
uri
      { uriAuthority :: Maybe URIAuth
uriAuthority = forall a. a -> Maybe a
Just URIAuth
a { uriUserInfo :: String
uriUserInfo = String
user forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
pass forall a. [a] -> [a] -> [a]
++ String
"@" }
      }
     where
      a :: URIAuth
a = forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> URIAuth
URIAuth String
"" String
"" String
"") (URI -> Maybe URIAuth
uriAuthority URI
uri)

    runWGet :: Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity URI
uri [String]
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
invocation = (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog (String
"--input-file=-" forall a. a -> [a] -> [a]
: [String]
args))
            { progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
""
            }

        -- wget returns its output on stderr rather than stdout
        (String
_, String
resp, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity
                                 ProgramInvocation
invocation
        -- wget returns exit code 8 for server "errors" like "304 not modified"
        if ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
|| ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== HttpCode -> ExitCode
ExitFailure HttpCode
8
          then forall (m :: * -> *) a. Monad m => a -> m a
return String
resp
          else forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
prog
                  forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" forall a. [a] -> [a] -> [a]
++ String
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 -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
resp =
      let parsedCode :: Maybe a
parsedCode = forall a. [a] -> Maybe a
listToMaybe
                     [ a
code
                     | (String
protocol:String
codestr:[String]
_err) <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp))
                     , String
"HTTP/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
protocol
                     , a
code <- forall a. Maybe a -> [a]
maybeToList (forall a. Read a => String -> Maybe a
readMaybe String
codestr) ]
          mb_etag :: Maybe ETag
          mb_etag :: Maybe String
mb_etag  = forall a. [a] -> Maybe a
listToMaybe
                    [ String
etag
                    | [String
"ETag:", String
etag] <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp)) ]
       in case Maybe a
parsedCode of
            Just a
i -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
i, Maybe String
mb_etag)
            Maybe a
_      -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp


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

    posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet

    posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth =
      forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path)
                   (String -> String
takeFileName String
path) forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle -> do
        (ByteString
body, String
boundary) <- String -> IO (ByteString, String)
generateMultipartBody String
path
        Handle -> ByteString -> IO ()
LBS.hPut Handle
tmpHandle ByteString
body
        Handle -> IO ()
hClose Handle
tmpHandle
        String
fullPath <- String -> IO String
canonicalizePath String
tmpFile

        let contentHeader :: Header
contentHeader = HeaderName -> String -> Header
Header HeaderName
HdrContentType
              (String
"multipart/form-data; boundary=" forall a. [a] -> [a] -> [a]
++ String
boundary)
        String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
          (String -> String
escape (forall a. Show a => a -> String
show URI
uri))
          ([Header] -> [String]
setupHeaders (Header
contentHeader forall a. a -> [a] -> [a]
: [Header]
extraHeaders) forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
          (forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"POST" URI
uri String
fullPath)
          [String]
uploadFileCleanup
        forall {a}. Read a => Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp

    puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
      String
fullPath <- String -> IO String
canonicalizePath String
path
      String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
        (String -> String
escape (forall a. Show a => a -> String
show URI
uri))
        ([Header] -> [String]
setupHeaders ([Header]
extraHeaders forall a. [a] -> [a] -> [a]
++ [Header]
headers) forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
        (forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"PUT" URI
uri String
fullPath)
        [String]
uploadFileCleanup
      forall {a}. Read a => Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp

    runPowershellScript :: Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity String
script = do
      let args :: [String]
args =
            [ String
"-InputFormat", String
"None"
            -- the default execution policy doesn't allow running
            -- unsigned scripts, so we need to tell powershell to bypass it
            , String
"-ExecutionPolicy", String
"bypass"
            , String
"-NoProfile", String
"-NonInteractive"
            , String
"-Command", String
"-"
            ]
      Verbosity -> String -> IO ()
debug Verbosity
verbosity String
script
      Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
        { progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText forall a b. (a -> b) -> a -> b
$ String
script forall a. [a] -> [a] -> [a]
++ String
"\nExit(0);"
        }

    escape :: String -> String
escape = forall a. Show a => a -> String
show

    useragentHeader :: Header
useragentHeader = HeaderName -> String -> Header
Header HeaderName
HdrUserAgent String
userAgent
    extraHeaders :: [Header]
extraHeaders = [HeaderName -> String -> Header
Header HeaderName
HdrAccept String
"text/plain", Header
useragentHeader]

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

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

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

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

    parseUploadResponse :: Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp = case String -> [String]
lines (String -> String
trim String
resp) of
      (String
codeStr : [String]
message)
        | Just a
code <- forall a. Read a => String -> Maybe a
readMaybe String
codeStr -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, [String] -> String
unlines [String]
message)
      [String]
_ -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp

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


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

plainHttpTransport :: HttpTransport
plainHttpTransport :: HttpTransport
plainHttpTransport =
    (Verbosity
 -> URI
 -> Maybe String
 -> String
 -> [Header]
 -> IO (HttpCode, Maybe String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
    -> URI
    -> String
    -> Maybe Auth
    -> [Header]
    -> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Bool
False Bool
False
  where
    gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
      let req :: Request ByteString
req = Request{
                  rqURI :: URI
rqURI     = URI
uri,
                  rqMethod :: RequestMethod
rqMethod  = RequestMethod
GET,
                  rqHeaders :: [Header]
rqHeaders = [ HeaderName -> String -> Header
Header HeaderName
HdrIfNoneMatch String
t
                              | String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
                           forall a. [a] -> [a] -> [a]
++ [Header]
reqHeaders,
                  rqBody :: ByteString
rqBody    = ByteString
LBS.empty
                }
      (URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity forall a. Maybe a
Nothing (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
      let code :: HttpCode
code  = forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp)
          etag' :: Maybe String
etag' = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrETag (forall a. Response a -> [Header]
rspHeaders Response ByteString
resp)
      -- 206 Partial Content is a normal response to a range request; see #3385.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HttpCode
codeforall a. Eq a => a -> a -> Bool
==HttpCode
200 Bool -> Bool -> Bool
|| HttpCode
codeforall a. Eq a => a -> a -> Bool
==HttpCode
206) forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
writeFileAtomic String
destPath forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
rspBody Response ByteString
resp
      forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, Maybe String
etag')

    posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet

    posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth = do
      (ByteString
body, String
boundary) <- String -> IO (ByteString, String)
generateMultipartBody String
path
      let headers :: [Header]
headers = [ HeaderName -> String -> Header
Header HeaderName
HdrContentType
                             (String
"multipart/form-data; boundary="forall a. [a] -> [a] -> [a]
++String
boundary)
                    , HeaderName -> String -> Header
Header HeaderName
HdrContentLength (forall a. Show a => a -> String
show (ByteString -> Int64
LBS8.length ByteString
body))
                    , HeaderName -> String -> Header
Header HeaderName
HdrAccept (String
"text/plain")
                    ]
          req :: Request ByteString
req = Request {
                  rqURI :: URI
rqURI     = URI
uri,
                  rqMethod :: RequestMethod
rqMethod  = RequestMethod
POST,
                  rqHeaders :: [Header]
rqHeaders = [Header]
headers,
                  rqBody :: ByteString
rqBody    = ByteString
body
                }
      (URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp), Response ByteString -> String
rspErrorString Response ByteString
resp)

    puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
      ByteString
body <- String -> IO ByteString
LBS8.readFile String
path
      let req :: Request ByteString
req = Request {
                  rqURI :: URI
rqURI     = URI
uri,
                  rqMethod :: RequestMethod
rqMethod  = RequestMethod
PUT,
                  rqHeaders :: [Header]
rqHeaders = HeaderName -> String -> Header
Header HeaderName
HdrContentLength (forall a. Show a => a -> String
show (ByteString -> Int64
LBS8.length ByteString
body))
                            forall a. a -> [a] -> [a]
: HeaderName -> String -> Header
Header HeaderName
HdrAccept String
"text/plain"
                            forall a. a -> [a] -> [a]
: [Header]
headers,
                  rqBody :: ByteString
rqBody    = ByteString
body
                }
      (URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp), Response ByteString -> String
rspErrorString Response ByteString
resp)

    convertRspCode :: (a, a, a) -> a
convertRspCode (a
a,a
b,a
c) = a
aforall a. Num a => a -> a -> a
*a
100 forall a. Num a => a -> a -> a
+ a
bforall a. Num a => a -> a -> a
*a
10 forall a. Num a => a -> a -> a
+ a
c

    rspErrorString :: Response ByteString -> String
rspErrorString Response ByteString
resp =
      case HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentType (forall a. Response a -> [Header]
rspHeaders Response ByteString
resp) of
        Just String
contenttype
           | forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';') String
contenttype forall a. Eq a => a -> a -> Bool
== String
"text/plain"
          -> ByteString -> String
LBS8.unpack (forall a. Response a -> a
rspBody Response ByteString
resp)
        Maybe String
_ -> forall a. Response a -> String
rspReason Response ByteString
resp

    cabalBrowse :: Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth BrowserAction conn b
act = do
      Proxy
p <- Proxy -> Proxy
fixupEmptyProxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO Proxy
fetchProxy Bool
True
      forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust
        (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
        (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Couldn't establish HTTP connection. "
                    forall a. [a] -> [a] -> [a]
++ String
"Possible cause: HTTP proxy server is down.") forall a b. (a -> b) -> a -> b
$
        forall conn a. BrowserAction conn a -> IO a
browse forall a b. (a -> b) -> a -> b
$ do
          forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p
          forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler (Verbosity -> String -> IO ()
warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"http error: "forall a. [a] -> [a] -> [a]
++))
          forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler (Verbosity -> String -> IO ()
debug Verbosity
verbosity)
          forall t. String -> BrowserAction t ()
setUserAgent  String
userAgent
          forall t. Bool -> BrowserAction t ()
setAllowBasicAuth Bool
False
          forall t. (URI -> String -> IO (Maybe Auth)) -> BrowserAction t ()
setAuthorityGen (\URI
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Auth
auth)
          BrowserAction conn b
act

    fixupEmptyProxy :: Proxy -> Proxy
fixupEmptyProxy (Proxy String
uri Maybe Authority
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri = Proxy
NoProxy
    fixupEmptyProxy Proxy
p = Proxy
p


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

userAgent :: String
userAgent :: String
userAgent = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"cabal-install/", forall a. Pretty a => a -> String
prettyShow Version
cabalInstallVersion
                   , String
" (", forall a. Pretty a => a -> String
prettyShow OS
buildOS, String
"; ", forall a. Pretty a => a -> String
prettyShow Arch
buildArch, String
")"
                   ]

statusParseFail :: Verbosity -> URI -> String -> IO a
statusParseFail :: forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
r =
    forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Failed to download " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri forall a. [a] -> [a] -> [a]
++ String
" : "
       forall a. [a] -> [a] -> [a]
++ String
"No Status Code could be parsed from response: " forall a. [a] -> [a] -> [a]
++ String
r

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

generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
generateMultipartBody :: String -> IO (ByteString, String)
generateMultipartBody String
path = do
    ByteString
content  <- String -> IO ByteString
LBS.readFile String
path
    String
boundary <- IO String
genBoundary
    let !body :: ByteString
body = ByteString -> ByteString -> ByteString
formatBody ByteString
content (String -> ByteString
LBS8.pack String
boundary)
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
body, String
boundary)
  where
    formatBody :: ByteString -> ByteString -> ByteString
formatBody ByteString
content ByteString
boundary =
        [ByteString] -> ByteString
LBS8.concat forall a b. (a -> b) -> a -> b
$
        [ ByteString
crlf, ByteString
dd, ByteString
boundary, ByteString
crlf ]
     forall a. [a] -> [a] -> [a]
++ [ String -> ByteString
LBS8.pack (forall a. Show a => a -> String
show Header
header) | Header
header <- [Header]
headers ]
     forall a. [a] -> [a] -> [a]
++ [ ByteString
crlf
        , ByteString
content
        , ByteString
crlf, ByteString
dd, ByteString
boundary, ByteString
dd, ByteString
crlf ]

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

    crlf :: ByteString
crlf = String -> ByteString
LBS8.pack String
"\r\n"
    dd :: ByteString
dd   = String -> ByteString
LBS8.pack String
"--"

genBoundary :: IO String
genBoundary :: IO String
genBoundary = do
    Integer
i <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Integer
0x10000000000000,Integer
0xFFFFFFFFFFFFFF) :: IO Integer
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> String -> String
showHex Integer
i String
""