{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Distribution.Client.HttpUtils (
DownloadResult(..),
configureTransport,
HttpTransport(..),
HttpCode,
downloadURI,
transportCheckHttps,
remoteRepoCheckHttps,
remoteRepoTryUpgradeToHttps,
isOldHackageURI
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (Proxy (..))
import Distribution.Utils.Generic
import Network.HTTP
( Request (..), Response (..), RequestMethod (..)
, Header(..), HeaderName(..), lookupHeader )
import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
import Network.URI
( URI (..), URIAuth (..), uriToString )
import Network.Browser
( browse, setOutHandler, setErrHandler, setProxy
, setAuthorityGen, request, setAllowBasicAuth, setUserAgent )
import qualified Control.Exception as Exception
import Distribution.Simple.Utils
( die', info, warn, debug, notice
, copyFileVerbose, withTempFile, IOData (..) )
import Distribution.Utils.String (trim)
import Distribution.Client.Utils
( withTempFileName )
import Distribution.Client.Version
( cabalInstallVersion )
import Distribution.Client.Types
( unRepoName, RemoteRepo(..) )
import Distribution.System
( buildOS, buildArch )
import qualified System.FilePath.Posix as FilePath.Posix
( splitDirectories )
import System.FilePath
( (<.>), takeFileName, takeDirectory )
import System.Directory
( doesFileExist, renameFile, canonicalizePath )
import System.IO
( withFile, IOMode(ReadMode), hGetContents, hClose )
import System.IO.Error
( isDoesNotExistError )
import Distribution.Simple.Program
( Program, simpleProgram, ConfiguredProgram, programPath
, ProgramInvocation(..), programInvocation
, ProgramSearchPathEntry(..)
, getProgramInvocationOutput )
import Distribution.Simple.Program.Db
( ProgramDb, emptyProgramDb, addKnownPrograms
, configureAllKnownPrograms
, requireProgram, lookupProgram
, modifyProgramSearchPath )
import Distribution.Simple.Program.Run
( getProgramInvocationOutputAndErrors )
import Numeric (showHex)
import System.Random (randomRIO)
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as Base16
import qualified Distribution.Compat.CharParsing as P
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
data DownloadResult = FileAlreadyInCache
| FileDownloaded FilePath
deriving (DownloadResult -> DownloadResult -> Bool
(DownloadResult -> DownloadResult -> Bool)
-> (DownloadResult -> DownloadResult -> Bool) -> Eq DownloadResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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 -> String -> IO DownloadResult
downloadURI HttpTransport
_transport Verbosity
verbosity URI
uri String
path | URI -> String
uriScheme URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"file:" = do
Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
verbosity (URI -> String
uriPath URI
uri) String
path
DownloadResult -> IO DownloadResult
forall a. a -> IO a
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 (String -> Bool
forall a. [a] -> Bool
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
actual
then DownloadCheck -> IO DownloadCheck
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DownloadCheck
Downloaded
else 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))
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 String
err -> Verbosity -> String -> IO DownloadCheck
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO DownloadCheck) -> String -> IO DownloadCheck
forall a b. (a -> b) -> a -> b
$
String
"Cannot parse URI fragment " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uriFrag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> 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 DownloadCheck -> IO DownloadCheck
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DownloadCheck
CheckETag String
etagPath)
else DownloadCheck -> IO DownloadCheck
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> DownloadCheck
NeedsDownload Maybe ByteString
forall a. Maybe a
Nothing)
let transport' :: HttpTransport
transport'
| URI -> String
uriScheme URI
uri String -> String -> Bool
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 -> DownloadResult -> IO DownloadResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
CheckETag String
etag -> HttpTransport
-> Maybe ByteString -> Maybe String -> IO DownloadResult
makeDownload HttpTransport
transport' Maybe ByteString
forall a. Maybe a
Nothing (String -> Maybe String
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 Maybe String
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 = String
-> String -> (String -> IO DownloadResult) -> IO DownloadResult
forall a. String -> String -> (String -> IO a) -> IO a
withTempFileName (String -> String
takeDirectory String
path) (String -> String
takeFileName String
path) ((String -> IO DownloadResult) -> IO DownloadResult)
-> (String -> IO DownloadResult) -> IO DownloadResult
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
actual ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expected) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Failed to download", URI -> String
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)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case (HttpCode, Maybe String) -> HttpCode
forall a b. (a, b) -> a
fst (HttpCode, Maybe String)
result of
HttpCode
200 -> do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Downloaded to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path)
String -> String -> IO ()
renameFile String
tmpFile String
path
DownloadResult -> IO DownloadResult
forall a. a -> IO a
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."
DownloadResult -> IO DownloadResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DownloadResult
FileAlreadyInCache
HttpCode
errCode -> Verbosity -> String -> IO DownloadResult
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO DownloadResult) -> String -> IO DownloadResult
forall a b. (a -> b) -> a -> b
$ String
"failed to download " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : HTTP code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpCode -> String
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 = ParsecParser ByteString -> String -> Either String ByteString
forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser ByteString
fragmentParser String
uriFrag
fragmentParser :: ParsecParser ByteString
fragmentParser = do
String
_ <- String -> ParsecParser String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"#sha256="
String
str <- ParsecParser Char -> ParsecParser String
forall a. ParsecParser a -> ParsecParser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecParser Char
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)
(String -> ParsecParser ByteString)
-> (ByteString -> ParsecParser ByteString)
-> Either String ByteString
-> ParsecParser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ParsecParser ByteString
forall a. String -> ParsecParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> ParsecParser ByteString
forall a. a -> ParsecParser a
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) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"https:"
, Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
= Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"The remote repository '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' specifies a URL that " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 -> String
uriScheme URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"https:"
, Bool -> Bool
not (HttpTransport -> Bool
transportSupportsHttps HttpTransport
transport)
= Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"The URL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
requiresHttpsErrorMessage
| Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage =
String
"requires HTTPS however the built-in HTTP implementation "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"does not support HTTPS. The transport implementations with HTTPS "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"support are " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
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 ]
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". One of these will be selected automatically if the corresponding "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"external program is available, or one can be selected specifically "
String -> String -> String
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) String -> String -> Bool
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)
= Verbosity -> String -> IO RemoteRepo
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO RemoteRepo) -> String -> IO RemoteRepo
forall a b. (a -> b) -> a -> b
$ String
"The builtin HTTP implementation does not support HTTPS, but using "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"HTTPS for authenticated uploads is recommended. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"The transport implementations with HTTPS support are "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
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 ]
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"but they require the corresponding external program to be "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"available. You can either make one available or use plain HTTP by "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"using the global flag --http-transport=plain-http (or putting the "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"equivalent in the config file). With plain HTTP, your password "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is sent using HTTP digest authentication so it cannot be easily "
String -> String -> String
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) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"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 -> String
uriRegName = String
"hackage.haskell.org"}) ->
String -> [String]
FilePath.Posix.splitDirectories (URI -> String
uriPath URI
uri)
[String] -> [String] -> Bool
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
_ = Verbosity -> String -> IO (HttpCode, String)
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", 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 = String -> Program
simpleProgram String
"wget" in
( String
"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 = String -> Program
simpleProgram String
"powershell" in
( String
"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 )
, ( String
"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 -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity [String]
extraPath (Just String
name) =
case ((String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)
-> Bool)
-> [(String, Maybe Program, Bool,
ProgramDb -> Maybe HttpTransport)]
-> Maybe
(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(String
name',Maybe Program
_,Bool
_,ProgramDb -> Maybe HttpTransport
_) -> String
name' String -> String -> Bool
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 -> (String -> ProgramSearchPathEntry) -> [String] -> ProgramSearchPath
forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath ProgramSearchPath -> ProgramSearchPath -> ProgramSearchPath
forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
ProgramDb
progdb <- case Maybe Program
mprog of
Maybe Program
Nothing -> ProgramDb -> IO ProgramDb
forall 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
transport = HttpTransport -> Maybe HttpTransport -> HttpTransport
forall a. a -> Maybe a -> a
fromMaybe (String -> HttpTransport
forall a. HasCallStack => String -> a
error String
"configureTransport: failed to make transport") (Maybe HttpTransport -> HttpTransport)
-> Maybe HttpTransport -> HttpTransport
forall a b. (a -> b) -> a -> b
$ ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb
HttpTransport -> IO HttpTransport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected = True }
Maybe
(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)
Nothing -> Verbosity -> String -> IO HttpTransport
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO HttpTransport) -> String -> IO HttpTransport
forall a b. (a -> b) -> a -> b
$ String
"Unknown HTTP transport specified: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". The supported transports are "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
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 -> (String -> ProgramSearchPathEntry) -> [String] -> ProgramSearchPath
forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath ProgramSearchPath -> ProgramSearchPath -> ProgramSearchPath
forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
p) ProgramDb
emptyProgramDb
ProgramDb
progdb <- Verbosity -> ProgramDb -> IO ProgramDb
configureAllKnownPrograms Verbosity
verbosity (ProgramDb -> IO ProgramDb) -> ProgramDb -> IO ProgramDb
forall a b. (a -> b) -> a -> b
$
[Program] -> ProgramDb -> ProgramDb
addKnownPrograms
[ Program
prog | (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 <- Maybe HttpTransport -> [HttpTransport]
forall a. Maybe a -> [a]
maybeToList (ProgramDb -> Maybe HttpTransport
mkTrans ProgramDb
progdb) ]
let (String
name, HttpTransport
transport) =
(String, HttpTransport)
-> Maybe (String, HttpTransport) -> (String, HttpTransport)
forall a. a -> Maybe a -> a
fromMaybe (String
"plain-http", HttpTransport
plainHttpTransport) ([(String, HttpTransport)] -> Maybe (String, HttpTransport)
forall a. [a] -> Maybe a
safeHead [(String, HttpTransport)]
availableTransports)
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Selected http transport implementation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
HttpTransport -> IO HttpTransport
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HttpTransport
transport { transportManuallySelected = 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
String
-> String
-> (String -> Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String)
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
destPath)
String
"curl-headers.txt" ((String -> Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String))
-> (String -> Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String)
forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle -> do
Handle -> IO ()
hClose Handle
tmpHandle
let args :: [String]
args = [ URI -> String
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 ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", String
"If-None-Match: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t]
| String
t <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value]
| Header HeaderName
name String
value <- [Header]
reqHeaders ]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ProgramInvocation -> IO String) -> ProgramInvocation -> IO String
forall a b. (a -> b) -> a -> b
$ Maybe Auth -> URI -> ProgramInvocation -> ProgramInvocation
addAuthConfig Maybe Auth
forall a. Maybe a
Nothing URI
uri
(ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args)
String
-> IOMode
-> (Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tmpFile IOMode
ReadMode ((Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String))
-> (Handle -> IO (HttpCode, Maybe String))
-> IO (HttpCode, Maybe String)
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
(HttpCode, Maybe String) -> IO (HttpCode, Maybe String)
forall a. a -> IO a
evaluate ((HttpCode, Maybe String) -> IO (HttpCode, Maybe String))
-> (HttpCode, Maybe String) -> IO (HttpCode, Maybe String)
forall a b. (a -> b) -> a -> b
$ (HttpCode, Maybe String) -> (HttpCode, Maybe String)
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 (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@') String
u
Maybe URIAuth
_ -> Maybe String
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
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (String
uname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
passwd)
(Maybe Auth
Nothing, Just String
a) -> String -> Maybe String
forall a. a -> Maybe a
Just String
a
(Maybe Auth
Nothing, Maybe String
Nothing) -> Maybe String
forall a. Maybe a
Nothing
case Maybe String
mbAuthString of
Just String
up -> ProgramInvocation
progInvocation
{ progInvokeInput = Just . IODataText . unlines $
[ "--digest"
, "--user " ++ up
]
, progInvokeArgs = ["--config", "-"] ++ progInvokeArgs 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 = [ URI -> String
forall a. Show a => a -> String
show URI
uri
, String
"--form", String
"package=@"String -> String -> 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
"--header", String
"Accept: text/plain"
, String
"--location"
]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ProgramInvocation -> IO String) -> ProgramInvocation -> IO String
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
""
(HttpCode, String) -> IO (HttpCode, String)
forall a. a -> IO a
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 = [ URI -> String
forall a. Show a => a -> String
show URI
uri
, String
"--request", String
"PUT", String
"--data-binary", String
"@"String -> String -> 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"
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value]
| Header HeaderName
name String
value <- [Header]
headers ]
String
resp <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ProgramInvocation -> IO String) -> ProgramInvocation -> IO String
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
""
(HttpCode, String) -> IO (HttpCode, String)
forall a. a -> IO a
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 [String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp) of
(String
codeLine:[String]
rerrLines) ->
case String -> Maybe HttpCode
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 (HttpCode, String) -> Maybe (HttpCode, String)
forall a. a -> Maybe a
Just (HttpCode
i, String
errstr)
Maybe HttpCode
Nothing -> Maybe (HttpCode, String)
forall a. Maybe a
Nothing
[] -> Maybe (HttpCode, String)
forall a. Maybe a
Nothing
mkErrstr :: [String] -> String
mkErrstr = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace)
mb_etag :: Maybe ETag
mb_etag :: Maybe String
mb_etag = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse
[ String
etag
| [String
"ETag:", String
etag] <- (String -> [String]) -> [String] -> [[String]]
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) -> (HttpCode, String, Maybe String)
-> IO (HttpCode, String, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpCode
i, String
err, Maybe String
mb_etag)
Maybe (HttpCode, String)
_ -> Verbosity -> URI -> String -> IO (HttpCode, String, Maybe 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 Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (HttpCode, Maybe String)
forall {a}.
Read a =>
Verbosity
-> URI
-> Maybe String
-> String
-> [Header]
-> IO (a, Maybe String)
gethttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
posthttp Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
forall {a}.
(Read a, NFData a) =>
Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
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 = (Header -> Bool) -> [Header] -> Bool
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"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" range requests, which wastes network bandwidth."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" To fix this, set 'http-transport' to 'curl' or"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 'plain-http' in '~/.config/cabal/config'."
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Note that the 'plain-http' transport doesn't"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" support HTTPS.\n"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasRangeHeader) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
warn Verbosity
verbosity String
warningMsg
(a
code, Maybe String
etag') <- Verbosity -> URI -> String -> IO (a, Maybe String)
forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
resp
(a, Maybe String) -> IO (a, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, Maybe String
etag')
where
args :: [String]
args = [ String
"--output-document=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destPath
, String
"--user-agent=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--tries=5"
, String
"--timeout=15"
, String
"--server-response" ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--header", String
"If-None-Match: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t]
| String
t <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--header=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> 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 =
String
-> String -> (String -> Handle -> IO (a, String)) -> IO (a, String)
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path)
(String -> String
takeFileName String
path) ((String -> Handle -> IO (a, String)) -> IO (a, String))
-> (String -> Handle -> IO (a, String)) -> IO (a, String)
forall a b. (a -> b) -> a -> b
$ \String
tmpFile Handle
tmpHandle ->
String
-> String -> (String -> Handle -> IO (a, String)) -> IO (a, String)
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path) String
"response" ((String -> Handle -> IO (a, String)) -> IO (a, String))
-> (String -> Handle -> IO (a, String)) -> IO (a, String)
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tmpFile
, String
"--user-agent=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--server-response"
, String
"--output-document=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
responseFile
, String
"--header=Accept: text/plain"
, String
"--header=Content-type: multipart/form-data; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"boundary=" String -> String -> String
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) <- Verbosity -> URI -> String -> IO (a, Maybe String)
forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
out
String -> IOMode -> (Handle -> IO (a, String)) -> IO (a, String)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
responseFile IOMode
ReadMode ((Handle -> IO (a, String)) -> IO (a, String))
-> (Handle -> IO (a, String)) -> IO (a, String)
forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
String
resp <- Handle -> IO String
hGetContents Handle
hnd
(a, String) -> IO (a, String)
forall a. a -> IO a
evaluate ((a, String) -> IO (a, String)) -> (a, String) -> IO (a, String)
forall a b. (a -> b) -> a -> b
$ (a, String) -> (a, String)
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 =
String
-> String -> (String -> Handle -> IO (a, String)) -> IO (a, String)
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path) String
"response" ((String -> Handle -> IO (a, String)) -> IO (a, String))
-> (String -> Handle -> IO (a, String)) -> IO (a, String)
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="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path
, String
"--user-agent=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userAgent
, String
"--server-response"
, String
"--output-document=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
responseFile
, String
"--header=Accept: text/plain" ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--header=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> 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) <- Verbosity -> URI -> String -> IO (a, Maybe String)
forall {a}.
Read a =>
Verbosity -> URI -> String -> IO (a, Maybe String)
parseOutput Verbosity
verbosity URI
uri String
out
String -> IOMode -> (Handle -> IO (a, String)) -> IO (a, String)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
responseFile IOMode
ReadMode ((Handle -> IO (a, String)) -> IO (a, String))
-> (Handle -> IO (a, String)) -> IO (a, String)
forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
String
resp <- Handle -> IO String
hGetContents Handle
hnd
(a, String) -> IO (a, String)
forall a. a -> IO a
evaluate ((a, String) -> IO (a, String)) -> (a, String) -> IO (a, String)
forall a b. (a -> b) -> a -> b
$ (a, String) -> (a, String)
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 = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }
}
where
a :: URIAuth
a = URIAuth -> Maybe URIAuth -> URIAuth
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=-" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args))
{ progInvokeInput = Just $ IODataText $ uriToString id uri ""
}
(String
_, String
resp, ExitCode
exitCode) <- Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity
ProgramInvocation
invocation
if ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
|| ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== HttpCode -> ExitCode
ExitFailure HttpCode
8
then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
resp
else Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
prog
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' exited with an error:\n" String -> String -> String
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 = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe
[ a
code
| (String
protocol:String
codestr:[String]
_err) <- (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words ([String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp))
, String
"HTTP/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
protocol
, a
code <- Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
codestr) ]
mb_etag :: Maybe ETag
mb_etag :: Maybe String
mb_etag = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe
[ String
etag
| [String
"ETag:", String
etag] <- (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
words ([String] -> [String]
forall a. [a] -> [a]
reverse (String -> [String]
lines String
resp)) ]
in case Maybe a
parsedCode of
Just a
i -> (a, Maybe String) -> IO (a, Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
i, Maybe String
mb_etag)
Maybe a
_ -> Verbosity -> URI -> String -> IO (a, Maybe String)
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 Verbosity -> URI -> String -> Maybe Auth -> IO (HttpCode, String)
forall {a}.
Read a =>
Verbosity -> URI -> String -> Maybe Auth -> IO (a, String)
posthttpfile Verbosity
-> URI -> String -> Maybe Auth -> [Header] -> IO (HttpCode, String)
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 (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (URI -> String
forall a. Show a => a -> String
show URI
uri))
((String
"$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escape String
destPath) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", Create")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
:([Header] -> [String]
setupHeaders ((Header
useragentHeader Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
etagHeader) [Header] -> [Header] -> [Header]
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 (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
trim String
x of
(String
code:String
etagv:[String]
_) -> (HttpCode -> (HttpCode, Maybe String))
-> IO HttpCode -> IO (HttpCode, Maybe String)
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, String -> Maybe String
forall a. a -> Maybe a
Just String
etagv)) (IO HttpCode -> IO (HttpCode, Maybe String))
-> IO HttpCode -> IO (HttpCode, Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String -> IO HttpCode
parseCode String
code String
x
(String
code: [String]
_) -> (HttpCode -> (HttpCode, Maybe String))
-> IO HttpCode -> IO (HttpCode, Maybe String)
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 String
forall a. Maybe a
Nothing )) (IO HttpCode -> IO (HttpCode, Maybe String))
-> IO HttpCode -> IO (HttpCode, Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String -> IO HttpCode
parseCode String
code String
x
[String]
_ -> Verbosity -> URI -> String -> IO (HttpCode, Maybe 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 String -> Maybe HttpCode
forall a. Read a => String -> Maybe a
readMaybe String
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 -> String -> IO HttpCode
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 <- Maybe String -> [String]
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 =
String
-> String -> (String -> Handle -> IO (a, String)) -> IO (a, String)
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile (String -> String
takeDirectory String
path)
(String -> String
takeFileName String
path) ((String -> Handle -> IO (a, String)) -> IO (a, String))
-> (String -> Handle -> IO (a, String)) -> IO (a, String)
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
boundary)
String
resp <- Verbosity -> String -> IO String
runPowershellScript Verbosity
verbosity (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (URI -> String
forall a. Show a => a -> String
show URI
uri))
([Header] -> [String]
setupHeaders (Header
contentHeader Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
extraHeaders) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
(String -> URI -> String -> [String]
forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"POST" URI
uri String
fullPath)
[String]
uploadFileCleanup
Verbosity -> URI -> String -> IO (a, String)
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 (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String] -> [String] -> String
webclientScript
(String -> String
escape (URI -> String
forall a. Show a => a -> String
show URI
uri))
([Header] -> [String]
setupHeaders ([Header]
extraHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
headers) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe Auth -> [String]
setupAuth Maybe Auth
auth)
(String -> URI -> String -> [String]
forall {a} {p}. Show a => a -> p -> String -> [String]
uploadFileAction String
"PUT" URI
uri String
fullPath)
[String]
uploadFileCleanup
Verbosity -> URI -> String -> IO (a, String)
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 = Just $ IODataText $ script ++ "\nExit(0);"
}
escape :: String -> String
escape = String -> String
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." String -> String -> String
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 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrUserAgent -> String
"UserAgent = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrConnection -> String
"Connection = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrContentLength -> String
"ContentLength = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrContentType -> String
"ContentType = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrDate -> String
"Date = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrExpect -> String
"Expect = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrHost -> String
"Host = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrIfModifiedSince -> String
"IfModifiedSince = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrReferer -> String
"Referer = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrTransferEncoding -> String
"TransferEncoding = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value
HeaderName
HdrRange -> let (String
start, String
end) =
if String
"bytes=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
value
then case (Char -> Bool) -> String -> Auth
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') String
value' of
(String
start', Char
'-':String
end') -> (String
start', String
end')
Auth
_ -> String -> Auth
forall a. HasCallStack => String -> a
error (String -> Auth) -> String -> Auth
forall a b. (a -> b) -> a -> b
$ String
"Could not decode range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value
else String -> Auth
forall a. HasCallStack => String -> a
error (String -> Auth) -> String -> Auth
forall a b. (a -> b) -> a -> b
$ String
"Could not decode range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
value
value' :: String
value' = HttpCode -> String -> String
forall a. HttpCode -> [a] -> [a]
drop HttpCode
6 String
value
in String
"AddRange(\"bytes\", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
start String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
end String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
HeaderName
name -> String
"Headers.Add(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape (HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");"
setupAuth :: Maybe Auth -> [String]
setupAuth Maybe Auth
auth =
[ String
"$request.Credentials = new-object System.Net.NetworkCredential("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
uname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
passwd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",\"\");"
| (String
uname,String
passwd) <- Maybe Auth -> [Auth]
forall a. Maybe a -> [a]
maybeToList Maybe Auth
auth
]
uploadFileAction :: a -> p -> String -> [String]
uploadFileAction a
method p
_uri String
fullPath =
[ String
"$request.Method = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
method
, String
"$requestStream = $request.GetRequestStream()"
, String
"$fileStream = [System.IO.File]::OpenRead(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
fullPath String -> String -> String
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 <- String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
codeStr -> (a, String) -> IO (a, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
code, [String] -> String
unlines [String]
message)
[String]
_ -> Verbosity -> URI -> String -> IO (a, 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\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri
, String
"$request = [System.Net.HttpWebRequest]::Create($uri)"
, [String] -> String
unlines [String]
setup
, String
"Try {"
, [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
action)
, String
"} Catch [System.Net.WebException] {"
, String
" $exception = $_.Exception;"
, String
" If ($exception.Status -eq "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[System.Net.WebExceptionStatus]::ProtocolError) {"
, String
" $response = $exception.Response -as [System.Net.HttpWebResponse];"
, String
" $reader = new-object "
String -> String -> String
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 ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> 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 <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
etag ]
[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
reqHeaders,
rqBody :: ByteString
rqBody = ByteString
LBS.empty
}
(URI
_, Response ByteString
resp) <- Verbosity
-> Maybe Auth
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (URI, Response ByteString)
forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
forall a. Maybe a
Nothing (Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
let code :: HttpCode
code = (HttpCode, HttpCode, HttpCode) -> HttpCode
forall {a}. Num a => (a, a, a) -> a
convertRspCode (Response ByteString -> (HttpCode, HttpCode, HttpCode)
forall a. Response a -> (HttpCode, HttpCode, HttpCode)
rspCode Response ByteString
resp)
etag' :: Maybe String
etag' = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrETag (Response ByteString -> [Header]
forall a. Response a -> [Header]
rspHeaders Response ByteString
resp)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HttpCode
codeHttpCode -> HttpCode -> Bool
forall a. Eq a => a -> a -> Bool
==HttpCode
200 Bool -> Bool -> Bool
|| HttpCode
codeHttpCode -> HttpCode -> Bool
forall a. Eq a => a -> a -> Bool
==HttpCode
206) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> ByteString -> IO ()
writeFileAtomic String
destPath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall a. Response a -> a
rspBody Response ByteString
resp
(HttpCode, Maybe String) -> IO (HttpCode, Maybe String)
forall a. a -> IO a
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="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
boundary)
, HeaderName -> String -> Header
Header HeaderName
HdrContentLength (Int64 -> String
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) <- Verbosity
-> Maybe Auth
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (URI, Response ByteString)
forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
(HttpCode, String) -> IO (HttpCode, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HttpCode, HttpCode, HttpCode) -> HttpCode
forall {a}. Num a => (a, a, a) -> a
convertRspCode (Response ByteString -> (HttpCode, HttpCode, HttpCode)
forall a. Response a -> (HttpCode, HttpCode, HttpCode)
rspCode Response ByteString
resp), Response ByteString -> 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 (Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
LBS8.length ByteString
body))
Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: HeaderName -> String -> Header
Header HeaderName
HdrAccept String
"text/plain"
Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers,
rqBody :: ByteString
rqBody = ByteString
body
}
(URI
_, Response ByteString
resp) <- Verbosity
-> Maybe Auth
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
-> IO (URI, Response ByteString)
forall {conn} {b}.
Verbosity -> Maybe Auth -> BrowserAction conn b -> IO b
cabalBrowse Verbosity
verbosity Maybe Auth
auth (Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ByteString
req)
(HttpCode, String) -> IO (HttpCode, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HttpCode, HttpCode, HttpCode) -> HttpCode
forall {a}. Num a => (a, a, a) -> a
convertRspCode (Response ByteString -> (HttpCode, HttpCode, HttpCode)
forall a. Response a -> (HttpCode, HttpCode, HttpCode)
rspCode Response ByteString
resp), Response ByteString -> String
rspErrorString Response ByteString
resp)
convertRspCode :: (a, a, a) -> a
convertRspCode (a
a,a
b,a
c) = a
aa -> a -> a
forall a. Num a => a -> a -> a
*a
100 a -> a -> a
forall a. Num a => a -> a -> a
+ a
ba -> a -> a
forall a. Num a => a -> a -> a
*a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a
c
rspErrorString :: Response ByteString -> String
rspErrorString Response ByteString
resp =
case HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentType (Response ByteString -> [Header]
forall a. Response a -> [Header]
rspHeaders Response ByteString
resp) of
Just String
contenttype
| (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') String
contenttype String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"text/plain"
-> ByteString -> String
LBS8.unpack (Response ByteString -> ByteString
forall a. Response a -> a
rspBody Response ByteString
resp)
Maybe String
_ -> Response ByteString -> 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 (Proxy -> Proxy) -> IO Proxy -> IO Proxy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO Proxy
fetchProxy Bool
True
(IOError -> Maybe ()) -> (() -> IO b) -> IO b -> IO b
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust
(Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
(IO b -> () -> IO b
forall a b. a -> b -> a
const (IO b -> () -> IO b) -> (String -> IO b) -> String -> () -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> IO b
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> () -> IO b) -> String -> () -> IO b
forall a b. (a -> b) -> a -> b
$ String
"Couldn't establish HTTP connection. "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Possible cause: HTTP proxy server is down.") (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$
BrowserAction conn b -> IO b
forall conn a. BrowserAction conn a -> IO a
browse (BrowserAction conn b -> IO b) -> BrowserAction conn b -> IO b
forall a b. (a -> b) -> a -> b
$ do
Proxy -> BrowserAction conn ()
forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p
(String -> IO ()) -> BrowserAction conn ()
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler (Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"http error: "String -> String -> String
forall a. [a] -> [a] -> [a]
++))
(String -> IO ()) -> BrowserAction conn ()
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler (Verbosity -> String -> IO ()
debug Verbosity
verbosity)
String -> BrowserAction conn ()
forall t. String -> BrowserAction t ()
setUserAgent String
userAgent
Bool -> BrowserAction conn ()
forall t. Bool -> BrowserAction t ()
setAllowBasicAuth Bool
False
(URI -> String -> IO (Maybe Auth)) -> BrowserAction conn ()
forall t. (URI -> String -> IO (Maybe Auth)) -> BrowserAction t ()
setAuthorityGen (\URI
_ String
_ -> Maybe Auth -> IO (Maybe Auth)
forall a. a -> IO a
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
_) | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri = Proxy
NoProxy
fixupEmptyProxy Proxy
p = Proxy
p
userAgent :: String
userAgent :: String
userAgent = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"cabal-install/", Version -> String
forall a. Pretty a => a -> String
prettyShow Version
cabalInstallVersion
, String
" (", OS -> String
forall a. Pretty a => a -> String
prettyShow OS
buildOS, String
"; ", Arch -> 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 =
Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Failed to download " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"No Status Code could be parsed from response: " String -> String -> String
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)
(ByteString, String) -> IO (ByteString, String)
forall a. a -> IO a
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 ([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]
++ [ String -> ByteString
LBS8.pack (Header -> String
forall a. Show a => a -> String
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 -> String -> Header
Header (String -> HeaderName
HdrCustom String
"Content-disposition")
(String
"form-data; name=package; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"filename=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
path String -> String -> String
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 <- (Integer, Integer) -> IO Integer
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Integer
0x10000000000000,Integer
0xFFFFFFFFFFFFFF) :: IO Integer
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Integer -> String -> String
forall a. Integral a => a -> String -> String
showHex Integer
i String
""