{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
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
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
| CheckETag String
| NeedsDownload (Maybe BS.ByteString)
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
-> FilePath
-> 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)
downloadURI HttpTransport
transport Verbosity
verbosity URI
uri FilePath
path = do
Bool
targetExists <- FilePath -> IO Bool
doesFileExist FilePath
path
DownloadCheck
downloadCheck <-
if Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
uriFrag)
then case Either FilePath ByteString
sha256parsed of
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))
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))
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
else do
Bool
etagPathExists <- FilePath -> IO Bool
doesFileExist FilePath
etagPath
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)
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 []
case (HttpCode, Maybe FilePath)
result of
(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
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
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
data HttpTransport = HttpTransport {
HttpTransport
-> Verbosity
-> URI
-> Maybe FilePath
-> FilePath
-> [Header]
-> IO (HttpCode, Maybe FilePath)
getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
-> IO (HttpCode, Maybe ETag),
HttpTransport
-> Verbosity
-> URI
-> FilePath
-> Maybe Auth
-> IO (HttpCode, FilePath)
postHttp :: Verbosity -> URI -> String -> Maybe Auth
-> IO (HttpCode, String),
HttpTransport
-> Verbosity
-> URI
-> FilePath
-> Maybe Auth
-> IO (HttpCode, FilePath)
postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
-> IO (HttpCode, String),
HttpTransport
-> Verbosity
-> URI
-> FilePath
-> Maybe Auth
-> [Header]
-> IO (HttpCode, FilePath)
putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]
-> IO (HttpCode, String),
HttpTransport -> Bool
transportSupportsHttps :: Bool,
HttpTransport -> Bool
transportManuallySelected :: Bool
}
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) =
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
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
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 }
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
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
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)
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
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)) ]
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
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
""
}
(FilePath
_, FilePath
resp, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (FilePath, FilePath, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity
ProgramInvocation
invocation
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
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"
, 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
"}"
]
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)
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
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
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
""