{-# 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
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
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 -> String -> IO DownloadResult
downloadURI HttpTransport
_transport Verbosity
verbosity URI
uri String
path | URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"file:" = do
Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
verbosity (URI -> String
uriPath URI
uri) String
path
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadResult
FileDownloaded String
path)
downloadURI HttpTransport
transport Verbosity
verbosity URI
uri String
path = do
Bool
targetExists <- String -> IO Bool
doesFileExist String
path
DownloadCheck
downloadCheck <-
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriFrag)
then case Either String ByteString
sha256parsed of
Right ByteString
expected | Bool
targetExists -> do
ByteString
contents <- String -> IO ByteString
LBS.readFile String
path
let actual :: ByteString
actual = ByteString -> ByteString
SHA256.hashlazy ByteString
contents
if ByteString
expected forall a. Eq a => a -> a -> Bool
== ByteString
actual
then forall (m :: * -> *) a. Monad m => a -> m a
return DownloadCheck
Downloaded
else forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload (forall a. a -> Maybe a
Just ByteString
expected))
Right ByteString
expected -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload (forall a. a -> Maybe a
Just ByteString
expected))
Left String
err -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String
"Cannot parse URI fragment " forall a. [a] -> [a] -> [a]
++ String
uriFrag forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
err
else do
Bool
etagPathExists <- String -> IO Bool
doesFileExist String
etagPath
if Bool
targetExists Bool -> Bool -> Bool
&& Bool
etagPathExists
then forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadCheck
CheckETag String
etagPath)
else forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload forall a. Maybe a
Nothing)
let transport' :: HttpTransport
transport'
| URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"http:"
, Bool -> Bool
not (HttpTransport -> Bool
transportManuallySelected HttpTransport
transport)
= HttpTransport
plainHttpTransport
| Bool
otherwise
= HttpTransport
transport
case DownloadCheck
downloadCheck of
DownloadCheck
Downloaded -> forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
CheckETag String
etag -> HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
etag)
NeedsDownload Maybe ByteString
hash -> HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' Maybe ByteString
hash forall a. Maybe a
Nothing
where
makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult
makeDownload :: HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' Maybe ByteString
sha256 Maybe String
etag = forall a. String -> String -> (String -> IO a) -> IO a
withTempFileName (String -> String
takeDirectory String
path) (String -> String
takeFileName String
path) forall a b. (a -> b) -> a -> b
$ \String
tmpFile -> do
(HttpCode, Maybe String)
result <- HttpTransport
-> Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
getHttp HttpTransport
transport' Verbosity
verbosity URI
uri Maybe String
etag String
tmpFile []
case (HttpCode, Maybe String)
result of
(HttpCode
200, Maybe String
_) | Just ByteString
expected <- Maybe ByteString
sha256 -> do
ByteString
contents <- String -> IO ByteString
LBS.readFile String
tmpFile
let actual :: ByteString
actual = ByteString -> ByteString
SHA256.hashlazy ByteString
contents
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
actual forall a. Eq a => a -> a -> Bool
== ByteString
expected) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Failed to download", forall a. Show a => a -> String
show URI
uri
, String
": SHA256 don't match; expected:", ByteString -> String
BS8.unpack (ByteString -> ByteString
Base16.encode ByteString
expected)
, String
"actual:", ByteString -> String
BS8.unpack (ByteString -> ByteString
Base16.encode ByteString
actual)
]
(HttpCode
200, Just String
newEtag) -> String -> String -> IO ()
writeFile String
etagPath String
newEtag
(HttpCode, Maybe String)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
case forall a b. (a, b) -> a
fst (HttpCode, Maybe String)
result of
HttpCode
200 -> do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Downloaded to " forall a. [a] -> [a] -> [a]
++ String
path)
String -> String -> IO ()
renameFile String
tmpFile String
path
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadResult
FileDownloaded String
path)
HttpCode
304 -> do
Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Skipping download: local and remote files match."
forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
HttpCode
errCode -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"failed to download " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri
forall a. [a] -> [a] -> [a]
++ String
" : HTTP code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HttpCode
errCode
etagPath :: String
etagPath = String
path String -> String -> String
<.> String
"etag"
uriFrag :: String
uriFrag = URI -> String
uriFragment URI
uri
sha256parsed :: Either String BS.ByteString
sha256parsed :: Either String ByteString
sha256parsed = forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser ByteString
fragmentParser String
uriFrag
fragmentParser :: ParsecParser ByteString
fragmentParser = do
String
_ <- forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"#sha256="
String
str <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
P.hexDigit
let bs :: Either String ByteString
bs = ByteString -> Either String ByteString
Base16.decode (String -> ByteString
BS8.pack String
str)
#if MIN_VERSION_base16_bytestring(1,0,0)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return Either String ByteString
bs
#else
return (fst bs)
#endif
remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps Verbosity
verbosity HttpTransport
transport RemoteRepo
repo
| URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) forall a. Eq a => a -> a -> Bool
== String
"https:"
, Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
= forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The remote repository '" forall a. [a] -> [a] -> [a]
++ RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
forall a. [a] -> [a] -> [a]
++ String
"' specifies a URL that " forall a. [a] -> [a] -> [a]
++ String
requiresHttpsErrorMessage
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps Verbosity
verbosity HttpTransport
transport URI
uri
| URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"https:"
, Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
= forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The URL " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
requiresHttpsErrorMessage
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage =
String
"requires HTTPS however the built-in HTTP implementation "
forall a. [a] -> [a] -> [a]
++ String
"does not support HTTPS. The transport implementations with HTTPS "
forall a. [a] -> [a] -> [a]
++ String
"support are " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", "
[ String
name | (String
name, Maybe Program
_, Bool
True, ProgramDb -> Maybe HttpTransport
_ ) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]
forall a. [a] -> [a] -> [a]
++ String
". One of these will be selected automatically if the corresponding "
forall a. [a] -> [a] -> [a]
++ String
"external program is available, or one can be selected specifically "
forall a. [a] -> [a] -> [a]
++ String
"with the global flag --http-transport="
remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps Verbosity
verbosity HttpTransport
transport RemoteRepo
repo
| RemoteRepo -> Bool
remoteRepoShouldTryHttps RemoteRepo
repo
, URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) forall a. Eq a => a -> a -> Bool
== String
"http:"
, Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
, Bool -> Bool
not (HttpTransport -> Bool
transportManuallySelected HttpTransport
transport)
= forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The builtin HTTP implementation does not support HTTPS, but using "
forall a. [a] -> [a] -> [a]
++ String
"HTTPS for authenticated uploads is recommended. "
forall a. [a] -> [a] -> [a]
++ String
"The transport implementations with HTTPS support are "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ String
name | (String
name, Maybe Program
_, Bool
True, ProgramDb -> Maybe HttpTransport
_ ) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]
forall a. [a] -> [a] -> [a]
++ String
"but they require the corresponding external program to be "
forall a. [a] -> [a] -> [a]
++ String
"available. You can either make one available or use plain HTTP by "
forall a. [a] -> [a] -> [a]
++ String
"using the global flag --http-transport=plain-http (or putting the "
forall a. [a] -> [a] -> [a]
++ String
"equivalent in the config file). With plain HTTP, your password "
forall a. [a] -> [a] -> [a]
++ String
"is sent using HTTP digest authentication so it cannot be easily "
forall a. [a] -> [a] -> [a]
++ String
"intercepted, but it is not as secure as using HTTPS."
| RemoteRepo -> Bool
remoteRepoShouldTryHttps RemoteRepo
repo
, URI -> String
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) forall a. Eq a => a -> a -> Bool
== String
"http:"
, HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport
= forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
repo {
remoteRepoURI :: URI
remoteRepoURI = (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) { uriScheme :: String
uriScheme = String
"https:" }
}
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
repo
isOldHackageURI :: URI -> Bool
isOldHackageURI :: URI -> Bool
isOldHackageURI URI
uri
= case URI -> Maybe URIAuth
uriAuthority URI
uri of
Just (URIAuth {uriRegName :: URIAuth -> String
uriRegName = String
"hackage.haskell.org"}) ->
String -> [String]
FilePath.Posix.splitDirectories (URI -> String
uriPath URI
uri)
forall a. Eq a => a -> a -> Bool
== [String
"/",String
"packages",String
"archive"]
Maybe URIAuth
_ -> Bool
False
data HttpTransport = HttpTransport {
HttpTransport
-> Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
-> IO (HttpCode, Maybe ETag),
HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> IO (HttpCode, String)
postHttp :: Verbosity -> URI -> String -> Maybe Auth
-> IO (HttpCode, String),
HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> IO (HttpCode, String)
postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
-> IO (HttpCode, String),
HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String)
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 -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet Verbosity
verbosity URI
_ String
_ Maybe Auth
_ = forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Posting (for report upload) is not implemented yet"
supportedTransports :: [(String, Maybe Program, Bool,
ProgramDb -> Maybe HttpTransport)]
supportedTransports :: [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports =
[ let prog :: Program
prog = String -> Program
simpleProgram String
"curl" in
( String
"curl", forall a. a -> Maybe a
Just Program
prog, Bool
True
, \ProgramDb
db -> ConfiguredProgram -> HttpTransport
curlTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )
, let prog :: Program
prog = String -> Program
simpleProgram String
"wget" in
( String
"wget", forall a. a -> Maybe a
Just Program
prog, Bool
True
, \ProgramDb
db -> ConfiguredProgram -> HttpTransport
wgetTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )
, let prog :: Program
prog = String -> Program
simpleProgram String
"powershell" in
( String
"powershell", forall a. a -> Maybe a
Just Program
prog, Bool
True
, \ProgramDb
db -> ConfiguredProgram -> HttpTransport
powershellTransport forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
prog ProgramDb
db )
, ( String
"plain-http", forall a. Maybe a
Nothing, Bool
False
, \ProgramDb
_ -> forall a. a -> Maybe a
Just HttpTransport
plainHttpTransport )
]
configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport
configureTransport :: Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity [String]
extraPath (Just String
name) =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(String
name',Maybe Program
_,Bool
_,ProgramDb -> Maybe HttpTransport
_) -> String
name' forall a. Eq a => a -> a -> Bool
== String
name) [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports of
Just (String
_, Maybe Program
mprog, Bool
_tls, ProgramDb -> Maybe HttpTransport
mkTrans) -> do
let baseProgDb :: ProgramDb
baseProgDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath (\ProgramSearchPath
p -> forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
ProgramDb
progdb <- case Maybe Program
mprog of
Maybe Program
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ProgramDb
emptyProgramDb
Just Program
prog -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
prog ProgramDb
baseProgDb
let transport :: HttpTransport
transport = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"configureTransport: failed to make transport") forall a b. (a -> b) -> a -> b
$ ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected :: Bool
transportManuallySelected = Bool
True }
Maybe
(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)
Nothing -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Unknown HTTP transport specified: " forall a. [a] -> [a] -> [a]
++ String
name
forall a. [a] -> [a] -> [a]
++ String
". The supported transports are "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", "
[ String
name' | (String
name', Maybe Program
_, Bool
_, ProgramDb -> Maybe HttpTransport
_ ) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]
configureTransport Verbosity
verbosity [String]
extraPath Maybe String
Nothing = do
let baseProgDb :: ProgramDb
baseProgDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath (\ProgramSearchPath
p -> forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
ProgramDb
progdb <- Verbosity -> ProgramDb -> IO ProgramDb
configureAllKnownPrograms Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
[Program] -> ProgramDb -> ProgramDb
addKnownPrograms
[ Program
prog | (String
_, Just Program
prog, Bool
_, ProgramDb -> Maybe HttpTransport
_) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports ]
ProgramDb
baseProgDb
let availableTransports :: [(String, HttpTransport)]
availableTransports =
[ (String
name, HttpTransport
transport)
| (String
name, Maybe Program
_, Bool
_, ProgramDb -> Maybe HttpTransport
mkTrans) <- [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)]
supportedTransports
, HttpTransport
transport <- forall a. Maybe a -> [a]
maybeToList (ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb) ]
let (String
name, HttpTransport
transport) =
forall a. a -> Maybe a -> a
fromMaybe (String
"plain-http", HttpTransport
plainHttpTransport) (forall a. [a] -> Maybe a
safeHead [(String, HttpTransport)]
availableTransports)
Verbosity -> String -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Selected http transport implementation: " forall a. [a] -> [a] -> [a]
++ String
name
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected :: Bool
transportManuallySelected = Bool
False }
curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport ConfiguredProgram
prog =
(Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Bool
True Bool
False
where
gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
destPath)
String
"curl-headers.txt" forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle -> do
Handle -> IO ()
hClose Handle
tmpHandle
let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
, String
"--output", String
destPath
, String
"--location"
, String
"--write-out", String
"%{http_code}"
, String
"--user-agent", String
userAgent
, String
"--silent", String
"--show-error"
, String
"--dump-header", String
tmpFile ]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", String
"If-None-Match: " forall a. [a] -> [a] -> [a]
++ String
t]
| String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value]
| Header HeaderName
name String
value <- [Header]
reqHeaders ]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig forall a. Maybe a
Nothing URI
uri
(ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tmpFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
String
headers <- Handle -> IO String
hGetContents Handle
hnd
(HttpCode
code, String
_err, Maybe String
etag') <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
headers
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (HttpCode
code, Maybe String
etag')
posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet
addAuthConfig :: Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
explicitAuth URI
uri ProgramInvocation
progInvocation = do
let uriDerivedAuth :: Maybe String
uriDerivedAuth = case URI -> Maybe URIAuth
uriAuthority URI
uri of
(Just (URIAuth String
u String
_ String
_)) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'@') String
u
Maybe URIAuth
_ -> forall a. Maybe a
Nothing
let mbAuthString :: Maybe String
mbAuthString = case (Maybe Auth
explicitAuth, Maybe String
uriDerivedAuth) of
(Just (String
uname, String
passwd), Maybe String
_) -> forall a. a -> Maybe a
Just (String
uname forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
passwd)
(Maybe Auth
Nothing, Just String
a) -> forall a. a -> Maybe a
Just String
a
(Maybe Auth
Nothing, Maybe String
Nothing) -> forall a. Maybe a
Nothing
case Maybe String
mbAuthString of
Just String
up -> ProgramInvocation
progInvocation
{ progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOData
IODataText forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
[ String
"--digest"
, String
"--user " forall a. [a] -> [a] -> [a]
++ String
up
]
, progInvokeArgs :: [String]
progInvokeArgs = [String
"--config", String
"-"] forall a. [a] -> [a] -> [a]
++ ProgramInvocation -> [String]
progInvokeArgs ProgramInvocation
progInvocation
}
Maybe String
Nothing -> ProgramInvocation
progInvocation
posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth = do
let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
, String
"--form", String
"package=@"forall a. [a] -> [a] -> [a]
++String
path
, String
"--write-out", String
"\n%{http_code}"
, String
"--user-agent", String
userAgent
, String
"--silent", String
"--show-error"
, String
"--header", String
"Accept: text/plain"
, String
"--location"
]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
auth URI
uri
(ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
(HttpCode
code, String
err, Maybe String
_etag) <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
""
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, String
err)
puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
let args :: [String]
args = [ forall a. Show a => a -> String
show URI
uri
, String
"--request", String
"PUT", String
"--data-binary", String
"@"forall a. [a] -> [a] -> [a]
++String
path
, String
"--write-out", String
"\n%{http_code}"
, String
"--user-agent", String
userAgent
, String
"--silent", String
"--show-error"
, String
"--location"
, String
"--header", String
"Accept: text/plain"
]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value]
| Header HeaderName
name String
value <- [Header]
headers ]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
auth URI
uri
(ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
(HttpCode
code, String
err, Maybe String
_etag) <- Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
""
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, String
err)
parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)
parseResponse :: Verbosity
-> URI -> String -> String -> IO (HttpCode, String, Maybe String)
parseResponse Verbosity
verbosity URI
uri String
resp String
headers =
let codeerr :: Maybe (HttpCode, String)
codeerr =
case forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp) of
(String
codeLine:[String]
rerrLines) ->
case forall a. Read a => String -> Maybe a
readMaybe (String -> String
trim String
codeLine) of
Just HttpCode
i -> let errstr :: String
errstr = [String] -> String
mkErrstr [String]
rerrLines
in forall a. a -> Maybe a
Just (HttpCode
i, String
errstr)
Maybe HttpCode
Nothing -> forall a. Maybe a
Nothing
[] -> forall a. Maybe a
Nothing
mkErrstr :: [String] -> String
mkErrstr = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace)
mb_etag :: Maybe ETag
mb_etag :: Maybe String
mb_etag = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
[ String
etag
| [String
"ETag:", String
etag] <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (String -> [String]
lines String
headers) ]
in case Maybe (HttpCode, String)
codeerr of
Just (HttpCode
i, String
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
i, String
err, Maybe String
mb_etag)
Maybe (HttpCode, String)
_ -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport ConfiguredProgram
prog =
(Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport forall {a}.
Read a =>
Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (a, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp forall {a}.
(Read a, NFData a) =>
Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile forall {a}.
(Read a, NFData a) =>
Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Bool
True Bool
False
where
gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (a, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
String
resp <- Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity URI
uri [String]
args
let hasRangeHeader :: Bool
hasRangeHeader = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Header -> Bool
isRangeHeader [Header]
reqHeaders
warningMsg :: String
warningMsg = String
"the 'wget' transport currently doesn't support"
forall a. [a] -> [a] -> [a]
++ String
" range requests, which wastes network bandwidth."
forall a. [a] -> [a] -> [a]
++ String
" To fix this, set 'http-transport' to 'curl' or"
forall a. [a] -> [a] -> [a]
++ String
" 'plain-http' in '~/.config/cabal/config'."
forall a. [a] -> [a] -> [a]
++ String
" Note that the 'plain-http' transport doesn't"
forall a. [a] -> [a] -> [a]
++ String
" support HTTPS.\n"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasRangeHeader) forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity String
warningMsg
(a
code, Maybe String
etag') <- forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
resp
forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, Maybe String
etag')
where
args :: [String]
args = [ String
"--output-document=" forall a. [a] -> [a] -> [a]
++ String
destPath
, String
"--user-agent=" forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--tries=5"
, String
"--timeout=15"
, String
"--server-response" ]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", String
"If-None-Match: " forall a. [a] -> [a] -> [a]
++ String
t]
| String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
forall a. [a] -> [a] -> [a]
++ [ String
"--header=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value
| hdr :: Header
hdr@(Header HeaderName
name String
value) <- [Header]
reqHeaders
, (Bool -> Bool
not (Header -> Bool
isRangeHeader Header
hdr)) ]
isRangeHeader :: Header -> Bool
isRangeHeader :: Header -> Bool
isRangeHeader (Header HeaderName
HdrRange String
_) = Bool
True
isRangeHeader Header
_ = Bool
False
posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet
posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth =
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path)
(String -> String
takeFileName String
path) forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle ->
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path) String
"response" forall a b. (a -> b) -> a -> b
$
\String
responseFile Handle
responseHandle -> do
Handle -> IO ()
hClose Handle
responseHandle
(ByteString
body, String
boundary) <- String -> IO (ByteString, String)
generateMultipartBody String
path
Handle -> ByteString -> IO ()
LBS.hPut Handle
tmpHandle ByteString
body
Handle -> IO ()
hClose Handle
tmpHandle
let args :: [String]
args = [ String
"--post-file=" forall a. [a] -> [a] -> [a]
++ String
tmpFile
, String
"--user-agent=" forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--server-response"
, String
"--output-document=" forall a. [a] -> [a] -> [a]
++ String
responseFile
, String
"--header=Accept: text/plain"
, String
"--header=Content-type: multipart/form-data; " forall a. [a] -> [a] -> [a]
++
String
"boundary=" forall a. [a] -> [a] -> [a]
++ String
boundary ]
String
out <- Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity (Maybe Auth -> URI -> URI
addUriAuth Maybe Auth
auth URI
uri) [String]
args
(a
code, Maybe String
_etag) <- forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
out
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
responseFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
String
resp <- Handle -> IO String
hGetContents Handle
hnd
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (a
code, String
resp)
puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers =
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path) String
"response" forall a b. (a -> b) -> a -> b
$
\String
responseFile Handle
responseHandle -> do
Handle -> IO ()
hClose Handle
responseHandle
let args :: [String]
args = [ String
"--method=PUT", String
"--body-file="forall a. [a] -> [a] -> [a]
++String
path
, String
"--user-agent=" forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--server-response"
, String
"--output-document=" forall a. [a] -> [a] -> [a]
++ String
responseFile
, String
"--header=Accept: text/plain" ]
forall a. [a] -> [a] -> [a]
++ [ String
"--header=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HeaderName
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
value
| Header HeaderName
name String
value <- [Header]
headers ]
String
out <- Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity (Maybe Auth -> URI -> URI
addUriAuth Maybe Auth
auth URI
uri) [String]
args
(a
code, Maybe String
_etag) <- forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
out
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
responseFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
String
resp <- Handle -> IO String
hGetContents Handle
hnd
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force (a
code, String
resp)
addUriAuth :: Maybe Auth -> URI -> URI
addUriAuth Maybe Auth
Nothing URI
uri = URI
uri
addUriAuth (Just (String
user, String
pass)) URI
uri = URI
uri
{ uriAuthority :: Maybe URIAuth
uriAuthority = forall a. a -> Maybe a
Just URIAuth
a { uriUserInfo :: String
uriUserInfo = String
user forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
pass forall a. [a] -> [a] -> [a]
++ String
"@" }
}
where
a :: URIAuth
a = forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> URIAuth
URIAuth String
"" String
"" String
"") (URI -> Maybe URIAuth
uriAuthority URI
uri)
runWGet :: Verbosity -> URI -> [String] -> IO String
runWGet Verbosity
verbosity URI
uri [String]
args = do
let
invocation :: ProgramInvocation
invocation = (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog (String
"--input-file=-" forall a. a -> [a] -> [a]
: [String]
args))
{ progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
""
}
(String
_, String
resp, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity
ProgramInvocation
invocation
if ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
|| ExitCode
exitCode forall a. Eq a => a -> a -> Bool
== HttpCode -> ExitCode
ExitFailure HttpCode
8
then forall (m :: * -> *) a. Monad m => a -> m a
return String
resp
else forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
prog
forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" forall a. [a] -> [a] -> [a]
++ String
resp
parseOutput :: Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
resp =
let parsedCode :: Maybe a
parsedCode = forall a. [a] -> Maybe a
listToMaybe
[ a
code
| (String
protocol:String
codestr:[String]
_err) <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp))
, String
"HTTP/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
protocol
, a
code <- forall a. Maybe a -> [a]
maybeToList (forall a. Read a => String -> Maybe a
readMaybe String
codestr) ]
mb_etag :: Maybe ETag
mb_etag :: Maybe String
mb_etag = forall a. [a] -> Maybe a
listToMaybe
[ String
etag
| [String
"ETag:", String
etag] <- forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words (forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp)) ]
in case Maybe a
parsedCode of
Just a
i -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
i, Maybe String
mb_etag)
Maybe a
_ -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp
powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport ConfiguredProgram
prog =
(Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp forall {a}.
Read a =>
Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile forall {a}.
Read a =>
Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Bool
True Bool
False
where
gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (forall a. Show a => a -> String
show URI
uri))
((String
"$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " forall a. [a] -> [a] -> [a]
++ (String -> String
escape String
destPath) forall a. [a] -> [a] -> [a]
++ String
", Create")
forall a. a -> [a] -> [a]
:([Header] -> [String]
setupHeaders ((Header
useragentHeader forall a. a -> [a] -> [a]
: [Header]
etagHeader) forall a. [a] -> [a] -> [a]
++ [Header]
reqHeaders)))
[ String
"$response = $request.GetResponse()"
, String
"$responseStream = $response.GetResponseStream()"
, String
"$buffer = new-object byte[] 10KB"
, String
"$count = $responseStream.Read($buffer, 0, $buffer.length)"
, String
"while ($count -gt 0)"
, String
"{"
, String
" $targetStream.Write($buffer, 0, $count)"
, String
" $count = $responseStream.Read($buffer, 0, $buffer.length)"
, String
"}"
, String
"Write-Host ($response.StatusCode -as [int]);"
, String
"Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
]
[ String
"$targetStream.Flush()"
, String
"$targetStream.Close()"
, String
"$targetStream.Dispose()"
, String
"$responseStream.Dispose()"
]
String -> IO (HttpCode, Maybe String)
parseResponse String
resp
where
parseResponse :: String -> IO (HttpCode, Maybe ETag)
parseResponse :: String -> IO (HttpCode, Maybe String)
parseResponse String
x =
case String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String -> String
trim String
x of
(String
code:String
etagv:[String]
_) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HttpCode
c -> (HttpCode
c, forall a. a -> Maybe a
Just String
etagv)) forall a b. (a -> b) -> a -> b
$ String -> String -> IO HttpCode
parseCode String
code String
x
(String
code: [String]
_) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HttpCode
c -> (HttpCode
c, forall a. Maybe a
Nothing )) forall a b. (a -> b) -> a -> b
$ String -> String -> IO HttpCode
parseCode String
code String
x
[String]
_ -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
x
parseCode :: String -> String -> IO HttpCode
parseCode :: String -> String -> IO HttpCode
parseCode String
code String
x = case forall a. Read a => String -> Maybe a
readMaybe String
code of
Just HttpCode
i -> forall (m :: * -> *) a. Monad m => a -> m a
return HttpCode
i
Maybe HttpCode
Nothing -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
x
etagHeader :: [Header]
etagHeader = [ HeaderName -> String -> Header
Header HeaderName
HdrIfNoneMatch String
t | String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet
posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth =
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path)
(String -> String
takeFileName String
path) forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle -> do
(ByteString
body, String
boundary) <- String -> IO (ByteString, String)
generateMultipartBody String
path
Handle -> ByteString -> IO ()
LBS.hPut Handle
tmpHandle ByteString
body
Handle -> IO ()
hClose Handle
tmpHandle
String
fullPath <- String -> IO String
canonicalizePath String
tmpFile
let contentHeader :: Header
contentHeader = HeaderName -> String -> Header
Header HeaderName
HdrContentType
(String
"multipart/form-data; boundary=" forall a. [a] -> [a] -> [a]
++ String
boundary)
String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (forall a. Show a => a -> String
show URI
uri))
([Header] -> [String]
setupHeaders (Header
contentHeader forall a. a -> [a] -> [a]
: [Header]
extraHeaders) forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
(forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"POST" URI
uri String
fullPath)
[String]
uploadFileCleanup
forall {a}. Read a => Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp
puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (a, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
String
fullPath <- String -> IO String
canonicalizePath String
path
String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (forall a. Show a => a -> String
show URI
uri))
([Header] -> [String]
setupHeaders ([Header]
extraHeaders forall a. [a] -> [a] -> [a]
++ [Header]
headers) forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
(forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"PUT" URI
uri String
fullPath)
[String]
uploadFileCleanup
forall {a}. Read a => Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp
runPowershellScript :: Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity String
script = do
let args :: [String]
args =
[ String
"-InputFormat", String
"None"
, String
"-ExecutionPolicy", String
"bypass"
, String
"-NoProfile", String
"-NonInteractive"
, String
"-Command", String
"-"
]
Verbosity -> String -> IO ()
debug Verbosity
verbosity String
script
Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
{ progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText forall a b. (a -> b) -> a -> b
$ String
script forall a. [a] -> [a] -> [a]
++ String
"\nExit(0);"
}
escape :: String -> String
escape = forall a. Show a => a -> String
show
useragentHeader :: Header
useragentHeader = HeaderName -> String -> Header
Header HeaderName
HdrUserAgent String
userAgent
extraHeaders :: [Header]
extraHeaders = [HeaderName -> String -> Header
Header HeaderName
HdrAccept String
"text/plain", Header
useragentHeader]
setupHeaders :: [Header] -> [String]
setupHeaders [Header]
headers =
[ String
"$request." forall a. [a] -> [a] -> [a]
++ HeaderName -> String -> String
addHeader HeaderName
name String
value
| Header HeaderName
name String
value <- [Header]
headers
]
where
addHeader :: HeaderName -> String -> String
addHeader HeaderName
header String
value
= case HeaderName
header of
HeaderName
HdrAccept -> String
"Accept = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrUserAgent -> String
"UserAgent = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrConnection -> String
"Connection = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrContentLength -> String
"ContentLength = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrContentType -> String
"ContentType = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrDate -> String
"Date = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrExpect -> String
"Expect = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrHost -> String
"Host = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrIfModifiedSince -> String
"IfModifiedSince = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrReferer -> String
"Referer = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrTransferEncoding -> String
"TransferEncoding = " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrRange -> let (String
start, String
end) =
if String
"bytes=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
value
then case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'-') String
value' of
(String
start', Char
'-':String
end') -> (String
start', String
end')
Auth
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not decode range: " forall a. [a] -> [a] -> [a]
++ String
value
else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Could not decode range: " forall a. [a] -> [a] -> [a]
++ String
value
value' :: String
value' = forall a. HttpCode -> [a] -> [a]
drop HttpCode
6 String
value
in String
"AddRange(\"bytes\", " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
start forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ String -> String
escape String
end forall a. [a] -> [a] -> [a]
++ String
");"
HeaderName
name -> String
"Headers.Add(" forall a. [a] -> [a] -> [a]
++ String -> String
escape (forall a. Show a => a -> String
show HeaderName
name) forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value forall a. [a] -> [a] -> [a]
++ String
");"
setupAuth :: Maybe Auth -> [String]
setupAuth Maybe Auth
auth =
[ String
"$request.Credentials = new-object System.Net.NetworkCredential("
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
uname forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ String -> String
escape String
passwd forall a. [a] -> [a] -> [a]
++ String
",\"\");"
| (String
uname,String
passwd) <- forall a. Maybe a -> [a]
maybeToList Maybe Auth
auth
]
uploadFileAction :: a -> p -> String -> [String]
uploadFileAction a
method p
_uri String
fullPath =
[ String
"$request.Method = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
method
, String
"$requestStream = $request.GetRequestStream()"
, String
"$fileStream = [System.IO.File]::OpenRead(" forall a. [a] -> [a] -> [a]
++ String -> String
escape String
fullPath forall a. [a] -> [a] -> [a]
++ String
")"
, String
"$bufSize=10000"
, String
"$chunk = New-Object byte[] $bufSize"
, String
"while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"
, String
"{"
, String
" $requestStream.write($chunk, 0, $bytesRead)"
, String
" $requestStream.Flush()"
, String
"}"
, String
""
, String
"$responseStream = $request.getresponse()"
, String
"$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"
, String
"$code = $response.StatusCode -as [int]"
, String
"if ($code -eq 0) {"
, String
" $code = 200;"
, String
"}"
, String
"Write-Host $code"
, String
"Write-Host $responseReader.ReadToEnd()"
]
uploadFileCleanup :: [String]
uploadFileCleanup =
[ String
"$fileStream.Close()"
, String
"$requestStream.Close()"
, String
"$responseStream.Close()"
]
parseUploadResponse :: Verbosity -> URI -> String -> IO (a, String)
parseUploadResponse Verbosity
verbosity URI
uri String
resp = case String -> [String]
lines (String -> String
trim String
resp) of
(String
codeStr : [String]
message)
| Just a
code <- forall a. Read a => String -> Maybe a
readMaybe String
codeStr -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, [String] -> String
unlines [String]
message)
[String]
_ -> forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
resp
webclientScript :: String -> [String] -> [String] -> [String] -> String
webclientScript String
uri [String]
setup [String]
action [String]
cleanup = [String] -> String
unlines
[ String
"[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
, String
"$uri = New-Object \"System.Uri\" " forall a. [a] -> [a] -> [a]
++ String
uri
, String
"$request = [System.Net.HttpWebRequest]::Create($uri)"
, [String] -> String
unlines [String]
setup
, String
"Try {"
, [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
" " forall a. [a] -> [a] -> [a]
++) [String]
action)
, String
"} Catch [System.Net.WebException] {"
, String
" $exception = $_.Exception;"
, String
" If ($exception.Status -eq "
forall a. [a] -> [a] -> [a]
++ String
"[System.Net.WebExceptionStatus]::ProtocolError) {"
, String
" $response = $exception.Response -as [System.Net.HttpWebResponse];"
, String
" $reader = new-object "
forall a. [a] -> [a] -> [a]
++ String
"System.IO.StreamReader($response.GetResponseStream());"
, String
" Write-Host ($response.StatusCode -as [int]);"
, String
" Write-Host $reader.ReadToEnd();"
, String
" } Else {"
, String
" Write-Host $exception.Message;"
, String
" }"
, String
"} Catch {"
, String
" Write-Host $_.Exception.Message;"
, String
"} finally {"
, [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
" " forall a. [a] -> [a] -> [a]
++) [String]
cleanup)
, String
"}"
]
plainHttpTransport :: HttpTransport
plainHttpTransport :: HttpTransport
plainHttpTransport =
(Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI -> String -> Maybe Auth -> IO (HttpCode, String))
-> (Verbosity
-> URI
-> String
-> Maybe Auth
-> [Header]
-> IO (HttpCode, String))
-> Bool
-> Bool
-> HttpTransport
HttpTransport Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Bool
False Bool
False
where
gethttp :: Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
gethttp Verbosity
verbosity URI
uri Maybe String
etag String
destPath [Header]
reqHeaders = do
let req :: Request ByteString
req = Request{
rqURI :: URI
rqURI = URI
uri,
rqMethod :: RequestMethod
rqMethod = RequestMethod
GET,
rqHeaders :: [Header]
rqHeaders = [ HeaderName -> String -> Header
Header HeaderName
HdrIfNoneMatch String
t
| String
t <- forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
forall a. [a] -> [a] -> [a]
++ [Header]
reqHeaders,
rqBody :: ByteString
rqBody = ByteString
LBS.empty
}
(URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity forall a. Maybe a
Nothing (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
let code :: HttpCode
code = forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp)
etag' :: Maybe String
etag' = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrETag (forall a. Response a -> [Header]
rspHeaders Response ByteString
resp)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HttpCode
codeforall a. Eq a => a -> a -> Bool
==HttpCode
200 Bool -> Bool -> Bool
|| HttpCode
codeforall a. Eq a => a -> a -> Bool
==HttpCode
206) forall a b. (a -> b) -> a -> b
$
String -> ByteString -> IO ()
writeFileAtomic String
destPath forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
rspBody Response ByteString
resp
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
code, Maybe String
etag')
posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp = Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
noPostYet
posthttpfile :: Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth = do
(ByteString
body, String
boundary) <- String -> IO (ByteString, String)
generateMultipartBody String
path
let headers :: [Header]
headers = [ HeaderName -> String -> Header
Header HeaderName
HdrContentType
(String
"multipart/form-data; boundary="forall a. [a] -> [a] -> [a]
++String
boundary)
, HeaderName -> String -> Header
Header HeaderName
HdrContentLength (forall a. Show a => a -> String
show (ByteString -> Int64
LBS8.length ByteString
body))
, HeaderName -> String -> Header
Header HeaderName
HdrAccept (String
"text/plain")
]
req :: Request ByteString
req = Request {
rqURI :: URI
rqURI = URI
uri,
rqMethod :: RequestMethod
rqMethod = RequestMethod
POST,
rqHeaders :: [Header]
rqHeaders = [Header]
headers,
rqBody :: ByteString
rqBody = ByteString
body
}
(URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp), Response ByteString -> String
rspErrorString Response ByteString
resp)
puthttpfile :: Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
puthttpfile Verbosity
verbosity URI
uri String
path Maybe Auth
auth [Header]
headers = do
ByteString
body <- String -> IO ByteString
LBS8.readFile String
path
let req :: Request ByteString
req = Request {
rqURI :: URI
rqURI = URI
uri,
rqMethod :: RequestMethod
rqMethod = RequestMethod
PUT,
rqHeaders :: [Header]
rqHeaders = HeaderName -> String -> Header
Header HeaderName
HdrContentLength (forall a. Show a => a -> String
show (ByteString -> Int64
LBS8.length ByteString
body))
forall a. a -> [a] -> [a]
: HeaderName -> String -> Header
Header HeaderName
HdrAccept String
"text/plain"
forall a. a -> [a] -> [a]
: [Header]
headers,
rqBody :: ByteString
rqBody = ByteString
body
}
(URI
_, Response ByteString
resp) <- forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Num a => (a, a, a) -> a
convertRspCode (forall a. Response a -> ResponseCode
rspCode Response ByteString
resp), Response ByteString -> String
rspErrorString Response ByteString
resp)
convertRspCode :: (a, a, a) -> a
convertRspCode (a
a,a
b,a
c) = a
aforall a. Num a => a -> a -> a
*a
100 forall a. Num a => a -> a -> a
+ a
bforall a. Num a => a -> a -> a
*a
10 forall a. Num a => a -> a -> a
+ a
c
rspErrorString :: Response ByteString -> String
rspErrorString Response ByteString
resp =
case HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentType (forall a. Response a -> [Header]
rspHeaders Response ByteString
resp) of
Just String
contenttype
| forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
';') String
contenttype forall a. Eq a => a -> a -> Bool
== String
"text/plain"
-> ByteString -> String
LBS8.unpack (forall a. Response a -> a
rspBody Response ByteString
resp)
Maybe String
_ -> forall a. Response a -> String
rspReason Response ByteString
resp
cabalBrowse :: Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth BrowserAction conn b
act = do
Proxy
p <- Proxy -> Proxy
fixupEmptyProxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO Proxy
fetchProxy Bool
True
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust
(forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
(forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Couldn't establish HTTP connection. "
forall a. [a] -> [a] -> [a]
++ String
"Possible cause: HTTP proxy server is down.") forall a b. (a -> b) -> a -> b
$
forall conn a. BrowserAction conn a -> IO a
browse forall a b. (a -> b) -> a -> b
$ do
forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler (Verbosity -> String -> IO ()
warn Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"http error: "forall a. [a] -> [a] -> [a]
++))
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler (Verbosity -> String -> IO ()
debug Verbosity
verbosity)
forall t. String -> BrowserAction t ()
setUserAgent String
userAgent
forall t. Bool -> BrowserAction t ()
setAllowBasicAuth Bool
False
forall t. (URI -> String -> IO (Maybe Auth)) -> BrowserAction t ()
setAuthorityGen (\URI
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Auth
auth)
BrowserAction conn b
act
fixupEmptyProxy :: Proxy -> Proxy
fixupEmptyProxy (Proxy String
uri Maybe Authority
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri = Proxy
NoProxy
fixupEmptyProxy Proxy
p = Proxy
p
userAgent :: String
userAgent :: String
userAgent = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"cabal-install/", forall a. Pretty a => a -> String
prettyShow Version
cabalInstallVersion
, String
" (", forall a. Pretty a => a -> String
prettyShow OS
buildOS, String
"; ", forall a. Pretty a => a -> String
prettyShow Arch
buildArch, String
")"
]
statusParseFail :: Verbosity -> URI -> String -> IO a
statusParseFail :: forall a. Verbosity -> URI -> String -> IO a
statusParseFail Verbosity
verbosity URI
uri String
r =
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Failed to download " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
uri forall a. [a] -> [a] -> [a]
++ String
" : "
forall a. [a] -> [a] -> [a]
++ String
"No Status Code could be parsed from response: " forall a. [a] -> [a] -> [a]
++ String
r
generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
generateMultipartBody :: String -> IO (ByteString, String)
generateMultipartBody String
path = do
ByteString
content <- String -> IO ByteString
LBS.readFile String
path
String
boundary <- IO String
genBoundary
let !body :: ByteString
body = ByteString -> ByteString -> ByteString
formatBody ByteString
content (String -> ByteString
LBS8.pack String
boundary)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
body, String
boundary)
where
formatBody :: ByteString -> ByteString -> ByteString
formatBody ByteString
content ByteString
boundary =
[ByteString] -> ByteString
LBS8.concat forall a b. (a -> b) -> a -> b
$
[ ByteString
crlf, ByteString
dd, ByteString
boundary, ByteString
crlf ]
forall a. [a] -> [a] -> [a]
++ [ String -> ByteString
LBS8.pack (forall a. Show a => a -> String
show Header
header) | Header
header <- [Header]
headers ]
forall a. [a] -> [a] -> [a]
++ [ ByteString
crlf
, ByteString
content
, ByteString
crlf, ByteString
dd, ByteString
boundary, ByteString
dd, ByteString
crlf ]
headers :: [Header]
headers =
[ HeaderName -> String -> Header
Header (String -> HeaderName
HdrCustom String
"Content-disposition")
(String
"form-data; name=package; " forall a. [a] -> [a] -> [a]
++
String
"filename=\"" forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
path forall a. [a] -> [a] -> [a]
++ String
"\"")
, HeaderName -> String -> Header
Header HeaderName
HdrContentType String
"application/x-gzip"
]
crlf :: ByteString
crlf = String -> ByteString
LBS8.pack String
"\r\n"
dd :: ByteString
dd = String -> ByteString
LBS8.pack String
"--"
genBoundary :: IO String
genBoundary :: IO String
genBoundary = do
Integer
i <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Integer
0x10000000000000,Integer
0xFFFFFFFFFFFFFF) :: IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> String -> String
showHex Integer
i String
""