{-# 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
(DownloadResult -> DownloadResult -> Bool)
-> (DownloadResult -> DownloadResult -> Bool) -> Eq DownloadResult
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
(DownloadCheck -> DownloadCheck -> Bool)
-> (DownloadCheck -> DownloadCheck -> Bool) -> Eq DownloadCheck
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 -> FilePath -> IO DownloadResult
downloadURI HttpTransport
_transport Verbosity
verbosity URI
uri FilePath
path | URI -> FilePath
uriScheme URI
uri FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"file:" = do
  Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose Verbosity
verbosity (URI -> FilePath
uriPath URI
uri) FilePath
path
  DownloadResult -> IO DownloadResult
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> DownloadResult
FileDownloaded FilePath
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 FilePath
path = do

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

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

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

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

      -- if there are no uri fragment, use ETag
      else do
        Bool
etagPathExists <- FilePath -> IO Bool
doesFileExist FilePath
etagPath
        -- In rare cases the target file doesn't exist, but the etag does.
        if Bool
targetExists Bool -> Bool -> Bool
&& Bool
etagPathExists
        then DownloadCheck -> IO DownloadCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> DownloadCheck
CheckETag FilePath
etagPath)
        else DownloadCheck -> IO DownloadCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload Maybe ByteString
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 -> FilePath
uriScheme URI
uri FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"http:"
          , Bool -> Bool
not (HttpTransport -> Bool
transportManuallySelected HttpTransport
transport)
          = HttpTransport
plainHttpTransport

          | Bool
otherwise
          = HttpTransport
transport

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

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

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

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

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

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

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

    fragmentParser :: ParsecParser ByteString
fragmentParser = do
        FilePath
_ <- FilePath -> ParsecParser FilePath
forall (m :: * -> *). CharParsing m => FilePath -> m FilePath
P.string FilePath
"#sha256="
        FilePath
str <- ParsecParser Char -> ParsecParser FilePath
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecParser Char
forall (m :: * -> *). CharParsing m => m Char
P.hexDigit
        let bs :: Either FilePath ByteString
bs = ByteString -> Either FilePath ByteString
Base16.decode (FilePath -> ByteString
BS8.pack FilePath
str)
#if MIN_VERSION_base16_bytestring(1,0,0)
        (FilePath -> ParsecParser ByteString)
-> (ByteString -> ParsecParser ByteString)
-> Either FilePath ByteString
-> ParsecParser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> ParsecParser ByteString
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail ByteString -> ParsecParser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return Either FilePath 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 -> FilePath
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"https:"
  , Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
  = Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"The remote repository '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' specifies a URL that " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
requiresHttpsErrorMessage
  | Bool
otherwise = () -> IO ()
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 -> FilePath
uriScheme URI
uri FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"https:"
  , Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
              = Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"The URL " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ URI -> FilePath
forall a. Show a => a -> FilePath
show URI
uri
                   FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
requiresHttpsErrorMessage
  | Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

  | Bool
otherwise
  = RemoteRepo -> IO RemoteRepo
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 -> FilePath
uriRegName = FilePath
"hackage.haskell.org"}) ->
            FilePath -> [FilePath]
FilePath.Posix.splitDirectories (URI -> FilePath
uriPath URI
uri)
            [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"/",FilePath
"packages",FilePath
"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 FilePath
-> FilePath
-> [Header]
-> IO (HttpCode, Maybe FilePath)
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
-> FilePath
-> Maybe Auth
-> IO (HttpCode, FilePath)
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
-> FilePath
-> Maybe Auth
-> IO (HttpCode, FilePath)
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
-> FilePath
-> Maybe Auth
-> [Header]
-> IO (HttpCode, FilePath)
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 -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath)
noPostYet Verbosity
verbosity URI
_ FilePath
_ Maybe Auth
_ = Verbosity -> FilePath -> IO (HttpCode, FilePath)
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Posting (for report upload) is not implemented yet"

supportedTransports :: [(String, Maybe Program, Bool,
                         ProgramDb -> Maybe HttpTransport)]
supportedTransports :: [(FilePath, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports =
    [ let prog :: Program
prog = FilePath -> Program
simpleProgram FilePath
"curl" in
      ( FilePath
"curl", Program -> Maybe Program
forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
curlTransport (ConfiguredProgram -> HttpTransport)
-> Maybe ConfiguredProgram -> Maybe HttpTransport
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 = FilePath -> Program
simpleProgram FilePath
"wget" in
      ( FilePath
"wget", Program -> Maybe Program
forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
wgetTransport (ConfiguredProgram -> HttpTransport)
-> Maybe ConfiguredProgram -> Maybe HttpTransport
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 = FilePath -> Program
simpleProgram FilePath
"powershell" in
      ( FilePath
"powershell", Program -> Maybe Program
forall a. a -> Maybe a
Just Program
prog, Bool
True
      , \ProgramDb
db -> ConfiguredProgram -> HttpTransport
powershellTransport (ConfiguredProgram -> HttpTransport)
-> Maybe ConfiguredProgram -> Maybe HttpTransport
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )

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

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

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

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

        let baseProgDb :: ProgramDb
baseProgDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath (\ProgramSearchPath
p -> (FilePath -> ProgramSearchPathEntry)
-> [FilePath] -> ProgramSearchPath
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ProgramSearchPathEntry
ProgramSearchPathDir [FilePath]
extraPath ProgramSearchPath -> ProgramSearchPath -> ProgramSearchPath
forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
        ProgramDb
progdb <- case Maybe Program
mprog of
          Maybe Program
Nothing   -> ProgramDb -> IO ProgramDb
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramDb
emptyProgramDb
          Just Program
prog -> (ConfiguredProgram, ProgramDb) -> ProgramDb
forall a b. (a, b) -> b
snd ((ConfiguredProgram, ProgramDb) -> ProgramDb)
-> IO (ConfiguredProgram, ProgramDb) -> IO ProgramDb
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 = HttpTransport -> Maybe HttpTransport -> HttpTransport
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> HttpTransport
forall a. HasCallStack => FilePath -> a
error FilePath
"configureTransport: failed to make transport") (Maybe HttpTransport -> HttpTransport)
-> Maybe HttpTransport -> HttpTransport
forall a b. (a -> b) -> a -> b
$ ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb
        HttpTransport -> IO HttpTransport
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected :: Bool
transportManuallySelected = Bool
True }

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

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

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

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

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

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

    posthttp :: Verbosity
-> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath)
posthttp = Verbosity
-> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath)
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 FilePath
uriDerivedAuth = case URI -> Maybe URIAuth
uriAuthority URI
uri of
                               (Just (URIAuth FilePath
u FilePath
_ FilePath
_)) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
u) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@') FilePath
u
                               Maybe URIAuth
_ -> Maybe FilePath
forall a. Maybe a
Nothing
      -- prefer passed in auth to auth derived from uri. If neither exist, then no auth
      let mbAuthString :: Maybe FilePath
mbAuthString = case (Maybe Auth
explicitAuth, Maybe FilePath
uriDerivedAuth) of
                          (Just (FilePath
uname, FilePath
passwd), Maybe FilePath
_) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
uname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
passwd)
                          (Maybe Auth
Nothing, Just FilePath
a) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
a
                          (Maybe Auth
Nothing, Maybe FilePath
Nothing) -> Maybe FilePath
forall a. Maybe a
Nothing
      case Maybe FilePath
mbAuthString of
        Just FilePath
up -> ProgramInvocation
progInvocation
          { progInvokeInput :: Maybe IOData
progInvokeInput = IOData -> Maybe IOData
forall a. a -> Maybe a
Just (IOData -> Maybe IOData)
-> ([FilePath] -> IOData) -> [FilePath] -> Maybe IOData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOData
IODataText (FilePath -> IOData)
-> ([FilePath] -> FilePath) -> [FilePath] -> IOData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines ([FilePath] -> Maybe IOData) -> [FilePath] -> Maybe IOData
forall a b. (a -> b) -> a -> b
$
              [ FilePath
"--digest"
              , FilePath
"--user " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
up
              ]
          , progInvokeArgs :: [FilePath]
progInvokeArgs = [FilePath
"--config", FilePath
"-"] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> [FilePath]
progInvokeArgs ProgramInvocation
progInvocation
          }
        Maybe FilePath
Nothing -> ProgramInvocation
progInvocation

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

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

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

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

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


wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport ConfiguredProgram
prog =
  (Verbosity
 -> URI
 -> Maybe FilePath
 -> FilePath
 -> [Header]
 -> IO (HttpCode, Maybe FilePath))
-> (Verbosity
    -> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath))
-> (Verbosity
    -> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath))
-> (Verbosity
    -> URI
    -> FilePath
    -> Maybe Auth
    -> [Header]
    -> IO (HttpCode, FilePath))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe FilePath
-> FilePath
-> [Header]
-> IO (HttpCode, Maybe FilePath)
forall a.
Read a =>
Verbosity
-> URI
-> Maybe FilePath
-> FilePath
-> [Header]
-> IO (a, Maybe FilePath)
gethttp Verbosity
-> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath)
posthttp Verbosity
-> URI -> FilePath -> Maybe Auth -> IO (HttpCode, FilePath)
forall a.
(Read a, NFData a) =>
Verbosity -> URI -> FilePath -> Maybe Auth -> IO (a, FilePath)
posthttpfile Verbosity
-> URI
-> FilePath
-> Maybe Auth
-> [Header]
-> IO (HttpCode, FilePath)
forall a.
(Read a, NFData a) =>
Verbosity
-> URI -> FilePath -> Maybe Auth -> [Header] -> IO (a, FilePath)
puthttpfile Bool
True Bool
False
  where
    gethttp :: Verbosity
-> URI
-> Maybe FilePath
-> FilePath
-> [Header]
-> IO (a, Maybe FilePath)
gethttp Verbosity
verbosity URI
uri Maybe FilePath
etag FilePath
destPath [Header]
reqHeaders =  do
        FilePath
resp <- Verbosity -> URI -> [FilePath] -> IO FilePath
runWGet Verbosity
verbosity URI
uri [FilePath]
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 =  (Header -> Bool) -> [Header] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Header -> Bool
isRangeHeader [Header]
reqHeaders
            warningMsg :: FilePath
warningMsg     =  FilePath
"the 'wget' transport currently doesn't support"
                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" range requests, which wastes network bandwidth."
                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" To fix this, set 'http-transport' to 'curl' or"
                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 'plain-http' in '~/.cabal/config'."
                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" Note that the 'plain-http' transport doesn't"
                           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" support HTTPS.\n"

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

    rspErrorString :: Response ByteString -> FilePath
rspErrorString Response ByteString
resp =
      case HeaderName -> [Header] -> Maybe FilePath
lookupHeader HeaderName
HdrContentType (Response ByteString -> [Header]
forall a. Response a -> [Header]
rspHeaders Response ByteString
resp) of
        Just FilePath
contenttype
           | (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') FilePath
contenttype FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"text/plain"
          -> ByteString -> FilePath
LBS8.unpack (Response ByteString -> ByteString
forall a. Response a -> a
rspBody Response ByteString
resp)
        Maybe FilePath
_ -> Response ByteString -> FilePath
forall a. Response a -> FilePath
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 (Proxy -> Proxy) -> IO Proxy -> IO Proxy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO Proxy
fetchProxy Bool
True
      (IOError -> Maybe ()) -> (() -> IO b) -> IO b -> IO b
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust
        (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
        (IO b -> () -> IO b
forall a b. a -> b -> a
const (IO b -> () -> IO b)
-> (FilePath -> IO b) -> FilePath -> () -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> IO b
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> () -> IO b) -> FilePath -> () -> IO b
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't establish HTTP connection. "
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Possible cause: HTTP proxy server is down.") (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$
        BrowserAction conn b -> IO b
forall conn a. BrowserAction conn a -> IO a
browse (BrowserAction conn b -> IO b) -> BrowserAction conn b -> IO b
forall a b. (a -> b) -> a -> b
$ do
          Proxy -> BrowserAction conn ()
forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p
          (FilePath -> IO ()) -> BrowserAction conn ()
forall t. (FilePath -> IO ()) -> BrowserAction t ()
setErrHandler (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"http error: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++))
          (FilePath -> IO ()) -> BrowserAction conn ()
forall t. (FilePath -> IO ()) -> BrowserAction t ()
setOutHandler (Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity)
          FilePath -> BrowserAction conn ()
forall t. FilePath -> BrowserAction t ()
setUserAgent  FilePath
userAgent
          Bool -> BrowserAction conn ()
forall t. Bool -> BrowserAction t ()
setAllowBasicAuth Bool
False
          (URI -> FilePath -> IO (Maybe Auth)) -> BrowserAction conn ()
forall t.
(URI -> FilePath -> IO (Maybe Auth)) -> BrowserAction t ()
setAuthorityGen (\URI
_ FilePath
_ -> Maybe Auth -> IO (Maybe Auth)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Auth
auth)
          BrowserAction conn b
act

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


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

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

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

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

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

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

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

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