Skip to content

Commit

Permalink
Pure Haskell https (WIP)
Browse files Browse the repository at this point in the history
  • Loading branch information
@andreabedini
andreabedini committed Apr 26, 2024
1 parent fbd9642 commit bcabfb8
Show file tree
Hide file tree
Showing 3 changed files with 128 additions and 150 deletions.
4 changes: 3 additions & 1 deletion cabal-install/cabal-install.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -217,7 +217,9 @@ library
exceptions >= 0.10.4 && < 0.11,
filepath >= 1.4.0.0 && < 1.5,
hashable >= 1.0 && < 1.5,
HTTP >= 4000.1.5 && < 4000.5,
http-client,
http-client-tls,
http-types,
mtl >= 2.0 && < 2.4,
network-uri >= 2.6.0.2 && < 2.7,
pretty >= 1.1 && < 1.2,
Expand Down
272 changes: 124 additions & 148 deletions cabal-install/src/Distribution/Client/HttpUtils.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

Expand Down Expand Up @@ -70,25 +71,30 @@ import Distribution.System
, 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.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.HTTP.Client as HTTP
import Network.HTTP.Client.MultipartFormData as HTTP
import Network.HTTP.Types
import Network.HTTP.Types.Header
import Network.URI
( URI (..)
, URIAuth (..)
Expand Down Expand Up @@ -127,6 +133,7 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Char as Char
import qualified Distribution.Compat.CharParsing as P
import Data.String (IsString)

------------------------------------------------------------------------------
-- Downloading a URI, given an HttpTransport
Expand Down Expand Up @@ -511,8 +518,9 @@ curlTransport prog =
| t <- maybeToList etag
]
++ concat
[ ["--header", show name ++ ": " ++ value]
| Header name value <- reqHeaders
-- FIXME: BS8.unpack assumes ASCII encoding!!
[ ["--header", show name ++ ": " ++ BS8.unpack value]
| (name, value) <- reqHeaders
]

resp <-
Expand Down Expand Up @@ -594,8 +602,9 @@ curlTransport prog =
, "Accept: text/plain"
]
++ concat
[ ["--header", show name ++ ": " ++ value]
| Header name value <- headers
-- FIXME: BS8.unpack assumes ASCII encoding!!
[ ["--header", show name ++ ": " ++ BS8.unpack value]
| (name, value) <- headers
]
resp <-
getProgramInvocationOutput verbosity $
Expand Down Expand Up @@ -668,16 +677,17 @@ wgetTransport prog =
[ ["--header", "If-None-Match: " ++ t]
| t <- maybeToList etag
]
++ [ "--header=" ++ show name ++ ": " ++ value
| hdr@(Header name value) <- reqHeaders
-- FIXME: BS8.unpack assumes ASCII encoding!!
-- how to do pass a bytestring as argument?
++ [ "--header=" ++ show name ++ ": " ++ BS8.unpack value
| hdr@(name, value) <- reqHeaders
, (not (isRangeHeader hdr))
]

-- wget doesn't support range requests.
-- so, we ignore range request headers, lest we get errors.
isRangeHeader :: Header -> Bool
isRangeHeader (Header HdrRange _) = True
isRangeHeader _ = False
isRangeHeader = (== hRange) . fst

posthttp = noPostYet

Expand Down Expand Up @@ -720,8 +730,9 @@ wgetTransport prog =
, "--output-document=" ++ responseFile
, "--header=Accept: text/plain"
]
++ [ "--header=" ++ show name ++ ": " ++ value
| Header name value <- headers
-- FIXME: BS8.unpack assumes ASCII encoding!!
++ [ "--header=" ++ show name ++ ": " ++ BS8.unpack value
| (name, value) <- headers
]

out <- runWGet verbosity (addUriAuth auth uri) args
Expand Down Expand Up @@ -789,6 +800,7 @@ powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport prog =
HttpTransport gethttp posthttp posthttpfile puthttpfile True False
where
gethttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] -> IO (HttpCode, Maybe ETag)
gethttp verbosity uri etag destPath reqHeaders = do
resp <-
runPowershellScript verbosity $
Expand Down Expand Up @@ -826,7 +838,8 @@ powershellTransport prog =
parseCode code x = case readMaybe code of
Just i -> return i
Nothing -> statusParseFail verbosity uri x
etagHeader = [Header HdrIfNoneMatch t | t <- maybeToList etag]
-- FIXME: BS8.unpack assumes ASCII encoding!!
etagHeader = [(hIfNoneMatch, BS8.pack t) | t <- maybeToList etag] :: [Header]

posthttp = noPostYet

Expand All @@ -839,11 +852,7 @@ powershellTransport prog =
LBS.hPut tmpHandle body
hClose tmpHandle
fullPath <- canonicalizePath tmpFile

let contentHeader =
Header
HdrContentType
("multipart/form-data; boundary=" ++ boundary)
let contentHeader = (hContentType, "multipart/form-data; boundary=" <> BS8.pack boundary) :: Header
resp <-
runPowershellScript verbosity $
webclientScript
Expand Down Expand Up @@ -886,28 +895,29 @@ powershellTransport prog =

escape = show

useragentHeader = Header HdrUserAgent userAgent
extraHeaders = [Header HdrAccept "text/plain", useragentHeader]
useragentHeader = (hUserAgent, userAgent) :: Header
extraHeaders = [(hAccept, "text/plain"), useragentHeader]

setupHeaders :: [Header] -> [[Char]]
setupHeaders headers =
[ "$request." ++ addHeader name value
| Header name value <- headers
-- FIXME: BS8.unpack assumes ASCII encoding!!
[ "$request." ++ addHeader name (BS8.unpack value)
| (name, value) <- headers
]
where
addHeader header value =
case header of
HdrAccept -> "Accept = " ++ escape value
HdrUserAgent -> "UserAgent = " ++ escape value
HdrConnection -> "Connection = " ++ escape value
HdrContentLength -> "ContentLength = " ++ escape value
HdrContentType -> "ContentType = " ++ escape value
HdrDate -> "Date = " ++ escape value
HdrExpect -> "Expect = " ++ escape value
HdrHost -> "Host = " ++ escape value
HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
HdrReferer -> "Referer = " ++ escape value
HdrTransferEncoding -> "TransferEncoding = " ++ escape value
HdrRange ->
addHeader header value
| header == hAccept = "Accept = " ++ escape value
| header == hUserAgent = "UserAgent = " ++ escape value
| header == hConnection = "Connection = " ++ escape value
| header == hContentLength = "ContentLength = " ++ escape value
| header == hContentType = "ContentType = " ++ escape value
| header == hDate = "Date = " ++ escape value
| header == hExpect = "Expect = " ++ escape value
| header == hHost = "Host = " ++ escape value
| header == hIfModifiedSince = "IfModifiedSince = " ++ escape value
| header == hReferer = "Referer = " ++ escape value
| header == hTransferEncoding = "TransferEncoding = " ++ escape value
| header == hRange =
let (start, end) =
if "bytes=" `isPrefixOf` value
then case break (== '-') value' of
Expand All @@ -916,7 +926,7 @@ powershellTransport prog =
else error $ "Could not decode range: " ++ value
value' = drop 6 value
in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
| otherwise = "Headers.Add(" ++ escape (show header) ++ "," ++ escape value ++ ");"

setupAuth auth =
[ "$request.Credentials = new-object System.Net.NetworkCredential("
Expand Down Expand Up @@ -995,99 +1005,71 @@ plainHttpTransport :: HttpTransport
plainHttpTransport =
HttpTransport gethttp posthttp posthttpfile puthttpfile False False
where
gethttp verbosity uri etag destPath reqHeaders = do
let req =
Request
{ rqURI = uri
, rqMethod = GET
, rqHeaders =
[ Header HdrIfNoneMatch t
| t <- maybeToList etag
]
++ reqHeaders
, rqBody = LBS.empty
}
(_, resp) <- cabalBrowse verbosity Nothing (request req)
let code = convertRspCode (rspCode resp)
etag' = lookupHeader HdrETag (rspHeaders resp)
-- 206 Partial Content is a normal response to a range request; see #3385.
when (code == 200 || code == 206) $
writeFileAtomic destPath $
rspBody resp
return (code, etag')

gethttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header] -> IO (Int, Maybe ETag)
gethttp _verbosity uri etag destPath reqHeaders = do
request0 <- requestFromURI uri
-- FIXME: BS8.unpack assumes ASCII encoding!!
let request = request0 { requestHeaders = [ (hIfNoneMatch, BS8.pack t) | t <- maybeToList etag ] ++ reqHeaders }
response <- httpLbs request _manager
-- FIXME: BS8.unpack assumes ASCII encoding!!
let etag' = BS8.unpack <$> lookup hETag (responseHeaders response)
-- FIXME: stream response to disk
writeFileAtomic destPath $ responseBody response
return (statusCode (responseStatus response), etag')

posthttp :: Verbosity -> URI -> String -> Maybe Auth -> IO (Int, String)
posthttp = noPostYet

posthttpfile verbosity uri path auth = do
(body, boundary) <- generateMultipartBody path
let headers =
[ Header
HdrContentType
("multipart/form-data; boundary=" ++ boundary)
, Header HdrContentLength (show (LBS8.length body))
, Header HdrAccept ("text/plain")
]
req =
Request
{ rqURI = uri
, rqMethod = POST
, rqHeaders = headers
, rqBody = body
}
(_, resp) <- cabalBrowse verbosity auth (request req)
return (convertRspCode (rspCode resp), rspErrorString resp)

puthttpfile verbosity uri path auth headers = do
body <- LBS8.readFile path
let req =
Request
{ rqURI = uri
, rqMethod = PUT
, rqHeaders =
Header HdrContentLength (show (LBS8.length body))
: Header HdrAccept "text/plain"
: headers
, rqBody = body
}
(_, resp) <- cabalBrowse verbosity auth (request req)
return (convertRspCode (rspCode resp), rspErrorString resp)

convertRspCode (a, b, c) = a * 100 + b * 10 + c

rspErrorString resp =
case lookupHeader HdrContentType (rspHeaders resp) of
Just contenttype
| takeWhile (/= ';') contenttype == "text/plain" ->
LBS8.unpack (rspBody resp)
_ -> rspReason resp

cabalBrowse verbosity auth act = do
p <- fixupEmptyProxy <$> fetchProxy True
Exception.handleJust
(guard . isDoesNotExistError)
( const . die' verbosity $
"Couldn't establish HTTP connection. "
++ "Possible cause: HTTP proxy server is down."
)
$ browse
$ do
setProxy p
setErrHandler (warn verbosity . ("http error: " ++))
setOutHandler (debug verbosity)
setUserAgent userAgent
setAllowBasicAuth False
setAuthorityGen (\_ _ -> return auth)
act

fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
fixupEmptyProxy p = p
posthttpfile :: Verbosity -> URI -> FilePath -> Maybe Auth -> IO (Int, String)
posthttpfile _verbosity uri path auth = do
request0 <- requestFromURI uri
let request = request0 { requestHeaders = [ (hAccept, "text/plain") ] }
-- FIXME: auth!
response <- formDataBody [ partFileSource "package" path ] request >>= flip httpLbs _manager
-- FIXME: what is the second thing we need to return?
-- FIXME: BS8.unpack assumes ASCII encoding!!
return (statusCode (responseStatus response), LBS8.unpack (responseBody response))

puthttpfile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header] -> IO (Int, String)
puthttpfile _verbosity uri path auth headers = do
reqBody <- streamFile path
request0 <- requestFromURI uri
let request = request0 {
method = "PUT",
requestHeaders = (hAccept, "text/plain") : headers,
requestBody = reqBody }
-- FIXME: auth!
response <- httpLbs request _manager
-- FIXME: BS8.unpack assumes ASCII encoding!!
return (statusCode (responseStatus response), LBS8.unpack (responseBody response))


-- FIXME: auth, logging, error handler, proxy, ...

-- cabalBrowse verbosity auth act = do
-- p <- fixupEmptyProxy <$> fetchProxy True
-- Exception.handleJust
-- (guard . isDoesNotExistError)
-- ( const . die' verbosity $
-- "Couldn't establish HTTP connection. "
-- ++ "Possible cause: HTTP proxy server is down."
-- )
-- $ browse
-- $ do
-- setProxy p
-- setErrHandler (warn verbosity . ("http error: " ++))
-- setOutHandler (debug verbosity)
-- setUserAgent userAgent
-- setAllowBasicAuth False
-- setAuthorityGen (\_ _ -> return auth)
-- act

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

userAgent :: String
userAgent =
userAgent :: IsString s => s
userAgent = fromString $
concat
[ "cabal-install/"
, prettyShow cabalInstallVersion
Expand Down Expand Up @@ -1132,14 +1114,8 @@ generateMultipartBody path = do
]

headers =
[ Header
(HdrCustom "Content-disposition")
( "form-data; name=package; "
++ "filename=\""
++ takeFileName path
++ "\""
)
, Header HdrContentType "application/x-gzip"
[ (hContentDisposition, "form-data; name=package; " ++ "filename=\"" ++ takeFileName path ++ "\"")
, (hContentType, "application/x-gzip")
]

crlf = LBS8.pack "\r\n"
Expand Down
Loading

0 comments on commit bcabfb8

Please sign in to comment.