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