{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Network.HTTP.Base
(
httpVersion
, Request(..)
, Response(..)
, RequestMethod(..)
, Request_String
, Response_String
, HTTPRequest
, HTTPResponse
, urlEncode
, urlDecode
, urlEncodeVars
, URIAuthority(..)
, parseURIAuthority
, uriToAuthorityString
, uriAuthToString
, uriAuthPort
, reqURIAuth
, parseResponseHead
, parseRequestHead
, ResponseNextStep(..)
, matchResponse
, ResponseData
, ResponseCode
, RequestData
, NormalizeRequestOptions(..)
, defaultNormalizeRequestOptions
, RequestNormalizer
, normalizeRequest
, splitRequestURI
, getAuth
, normalizeRequestURI
, normalizeHostHeader
, findConnClose
, linearTransfer
, hopefulTransfer
, chunkedTransfer
, uglyDeathTransfer
, readTillEmpty1
, readTillEmpty2
, defaultGETRequest
, defaultGETRequest_
, mkRequest
, setRequestBody
, defaultUserAgent
, httpPackageVersion
, libUA
, catchIO
, catchIO_
, responseParseError
, getRequestVersion
, getResponseVersion
, setRequestVersion
, setResponseVersion
, failHTTPS
) where
import Network.URI
( URI(uriAuthority, uriPath, uriScheme)
, URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)
, parseURIReference
)
import Control.Monad ( guard )
import Control.Monad.Error.Class ()
import Data.Bits ( (.&.), (.|.), shiftL, shiftR )
import Data.Word ( Word8 )
import Data.Char ( digitToInt, intToDigit, toLower, isDigit,
isAscii, isAlphaNum, ord, chr )
import Data.List ( partition, find )
import Data.Maybe ( listToMaybe, fromMaybe )
import Numeric ( readHex )
import Network.Stream
import Network.BufferType ( BufferOp(..), BufferType(..) )
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim, crlf, sp, readsOne )
import qualified Network.HTTP.Base64 as Base64 (encode)
import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
( ReadP, readP_to_S, char, (<++), look, munch, munch1 )
import Control.Exception as Exception (catch, IOException)
import qualified Paths_HTTP as Self (version)
import Data.Version (showVersion)
data URIAuthority = URIAuthority { URIAuthority -> Maybe String
user :: Maybe String,
URIAuthority -> Maybe String
password :: Maybe String,
URIAuthority -> String
host :: String,
URIAuthority -> Maybe Int
port :: Maybe Int
} deriving (URIAuthority -> URIAuthority -> Bool
(URIAuthority -> URIAuthority -> Bool)
-> (URIAuthority -> URIAuthority -> Bool) -> Eq URIAuthority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIAuthority -> URIAuthority -> Bool
$c/= :: URIAuthority -> URIAuthority -> Bool
== :: URIAuthority -> URIAuthority -> Bool
$c== :: URIAuthority -> URIAuthority -> Bool
Eq,Int -> URIAuthority -> ShowS
[URIAuthority] -> ShowS
URIAuthority -> String
(Int -> URIAuthority -> ShowS)
-> (URIAuthority -> String)
-> ([URIAuthority] -> ShowS)
-> Show URIAuthority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URIAuthority] -> ShowS
$cshowList :: [URIAuthority] -> ShowS
show :: URIAuthority -> String
$cshow :: URIAuthority -> String
showsPrec :: Int -> URIAuthority -> ShowS
$cshowsPrec :: Int -> URIAuthority -> ShowS
Show)
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority s :: String
s = [URIAuthority] -> Maybe URIAuthority
forall a. [a] -> Maybe a
listToMaybe (((URIAuthority, String) -> URIAuthority)
-> [(URIAuthority, String)] -> [URIAuthority]
forall a b. (a -> b) -> [a] -> [b]
map (URIAuthority, String) -> URIAuthority
forall a b. (a, b) -> a
fst (ReadP URIAuthority -> ReadS URIAuthority
forall a. ReadP a -> ReadS a
readP_to_S ReadP URIAuthority
pURIAuthority String
s))
pURIAuthority :: ReadP URIAuthority
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
(u :: Maybe String
u,pw :: Maybe String
pw) <- (ReadP (Maybe String, Maybe String)
pUserInfo ReadP (Maybe String, Maybe String)
-> ReadP Char -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
`before` Char -> ReadP Char
char '@')
ReadP (Maybe String, Maybe String)
-> ReadP (Maybe String, Maybe String)
-> ReadP (Maybe String, Maybe String)
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Maybe String, Maybe String) -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
String
h <- ReadP String
rfc2732host ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ (Char -> Bool) -> ReadP String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=':')
Maybe Int
p <- ReadP Int -> ReadP (Maybe Int)
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char ':' ReadP Char -> ReadP Int -> ReadP Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Int
forall a. (Eq a, Num a) => ReadP a
readDecP)
ReadP String
look ReadP String -> (String -> ReadP ()) -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ReadP ()) -> (String -> Bool) -> String -> ReadP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
URIAuthority -> ReadP URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority :: Maybe String -> Maybe String -> String -> Maybe Int -> URIAuthority
URIAuthority{ user :: Maybe String
user=Maybe String
u, password :: Maybe String
password=Maybe String
pw, host :: String
host=String
h, port :: Maybe Int
port=Maybe Int
p }
rfc2732host :: ReadP String
rfc2732host :: ReadP String
rfc2732host = do
Char
_ <- Char -> ReadP Char
char '['
String
res <- (Char -> Bool) -> ReadP String
munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=']')
Char
_ <- Char -> ReadP Char
char ']'
String -> ReadP String
forall (m :: * -> *) a. Monad m => a -> m a
return String
res
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
Maybe String
u <- ReadP String -> ReadP (Maybe String)
forall a. ReadP a -> ReadP (Maybe a)
orNothing ((Char -> Bool) -> ReadP String
munch (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ":@"))
Maybe String
p <- ReadP String -> ReadP (Maybe String)
forall a. ReadP a -> ReadP (Maybe a)
orNothing (Char -> ReadP Char
char ':' ReadP Char -> ReadP String -> ReadP String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> ReadP String
munch (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='@'))
(Maybe String, Maybe String) -> ReadP (Maybe String, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
u,Maybe String
p)
before :: Monad m => m a -> m b -> m a
before :: m a -> m b -> m a
before a :: m a
a b :: m b
b = m a
a m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: a
x -> m b
b m b -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing p :: ReadP a
p = (a -> Maybe a) -> ReadP a -> ReadP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just ReadP a
p ReadP (Maybe a) -> ReadP (Maybe a) -> ReadP (Maybe a)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Maybe a -> ReadP (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
uriToAuthorityString :: URI -> String
uriToAuthorityString :: URI -> String
uriToAuthorityString u :: URI
u = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" URIAuth -> String
uriAuthToString (URI -> Maybe URIAuth
uriAuthority URI
u)
uriAuthToString :: URIAuth -> String
uriAuthToString :: URIAuth -> String
uriAuthToString ua :: URIAuth
ua =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ URIAuth -> String
uriUserInfo URIAuth
ua
, URIAuth -> String
uriRegName URIAuth
ua
, URIAuth -> String
uriPort URIAuth
ua
]
uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort :: Maybe URI -> URIAuth -> Int
uriAuthPort mbURI :: Maybe URI
mbURI u :: URIAuth
u =
case URIAuth -> String
uriPort URIAuth
u of
(':':s :: String
s) -> (Int -> Int) -> Int -> String -> Int
forall a b. Read a => (a -> b) -> b -> String -> b
readsOne Int -> Int
forall a. a -> a
id (Maybe URI -> Int
default_port Maybe URI
mbURI) String
s
_ -> Maybe URI -> Int
default_port Maybe URI
mbURI
where
default_port :: Maybe URI -> Int
default_port Nothing = Int
default_http
default_port (Just url :: URI
url) =
case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
url of
"http:" -> Int
default_http
"https:" -> Int
default_https
_ -> Int
default_http
default_http :: Int
default_http = 80
default_https :: Int
default_https = 443
#if MIN_VERSION_base(4,13,0)
failHTTPS :: MonadFail m => URI -> m ()
#else
failHTTPS :: Monad m => URI -> m ()
#endif
failHTTPS :: URI -> m ()
failHTTPS uri :: URI
uri
| (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (URI -> String
uriScheme URI
uri) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "https:" = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "https not supported"
| Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reqURIAuth :: Request ty -> URIAuth
reqURIAuth :: Request ty -> URIAuth
reqURIAuth req :: Request ty
req =
case URI -> Maybe URIAuth
uriAuthority (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req) of
Just ua :: URIAuth
ua -> URIAuth
ua
_ -> case HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrHost (Request ty -> [Header]
forall a. Request a -> [Header]
rqHeaders Request ty
req) of
Nothing -> String -> URIAuth
forall a. HasCallStack => String -> a
error ("reqURIAuth: no URI authority for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Request ty -> String
forall a. Show a => a -> String
show Request ty
req)
Just h :: String
h ->
case String -> (String, String)
toHostPort String
h of
(ht :: String
ht,p :: String
p) -> URIAuth :: String -> String -> String -> URIAuth
URIAuth { uriUserInfo :: String
uriUserInfo = ""
, uriRegName :: String
uriRegName = String
ht
, uriPort :: String
uriPort = String
p
}
where
toHostPort :: String -> (String, String)
toHostPort h :: String
h = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') String
h
httpVersion :: String
httpVersion :: String
httpVersion = "HTTP/1.1"
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String
deriving(RequestMethod -> RequestMethod -> Bool
(RequestMethod -> RequestMethod -> Bool)
-> (RequestMethod -> RequestMethod -> Bool) -> Eq RequestMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestMethod -> RequestMethod -> Bool
$c/= :: RequestMethod -> RequestMethod -> Bool
== :: RequestMethod -> RequestMethod -> Bool
$c== :: RequestMethod -> RequestMethod -> Bool
Eq)
instance Show RequestMethod where
show :: RequestMethod -> String
show x :: RequestMethod
x =
case RequestMethod
x of
HEAD -> "HEAD"
PUT -> "PUT"
GET -> "GET"
POST -> "POST"
DELETE -> "DELETE"
OPTIONS -> "OPTIONS"
TRACE -> "TRACE"
CONNECT -> "CONNECT"
Custom c :: String
c -> String
c
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [("HEAD", RequestMethod
HEAD),
("PUT", RequestMethod
PUT),
("GET", RequestMethod
GET),
("POST", RequestMethod
POST),
("DELETE", RequestMethod
DELETE),
("OPTIONS", RequestMethod
OPTIONS),
("TRACE", RequestMethod
TRACE),
("CONNECT", RequestMethod
CONNECT)]
type Request_String = Request String
type Response_String = Response String
type HTTPRequest a = Request a
type HTTPResponse a = Response a
data Request a =
Request { Request a -> URI
rqURI :: URI
, Request a -> RequestMethod
rqMethod :: RequestMethod
, :: [Header]
, Request a -> a
rqBody :: a
}
instance Show (Request a) where
show :: Request a -> String
show req :: Request a
req@(Request u :: URI
u m :: RequestMethod
m h :: [Header]
h _) =
RequestMethod -> String
forall a. Show a => a -> String
show RequestMethod
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
alt_uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
forall a. Show a => a -> String
show ([Header] -> [Header]
dropHttpVersion [Header]
h)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
where
ver :: String
ver = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
httpVersion (Request a -> Maybe String
forall a. Request a -> Maybe String
getRequestVersion Request a
req)
alt_uri :: String
alt_uri = URI -> String
forall a. Show a => a -> String
show (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriPath URI
u) Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head (URI -> String
uriPath URI
u) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '/'
then URI
u { uriPath :: String
uriPath = '/' Char -> ShowS
forall a. a -> [a] -> [a]
: URI -> String
uriPath URI
u }
else URI
u
instance HasHeaders (Request a) where
getHeaders :: Request a -> [Header]
getHeaders = Request a -> [Header]
forall a. Request a -> [Header]
rqHeaders
setHeaders :: Request a -> [Header] -> Request a
setHeaders rq :: Request a
rq hdrs :: [Header]
hdrs = Request a
rq { rqHeaders :: [Header]
rqHeaders=[Header]
hdrs }
type ResponseCode = (Int,Int,Int)
type ResponseData = (ResponseCode,String,[Header])
type RequestData = (RequestMethod,URI,[Header])
data Response a =
Response { Response a -> ResponseCode
rspCode :: ResponseCode
, Response a -> String
rspReason :: String
, :: [Header]
, Response a -> a
rspBody :: a
}
instance Show (Response a) where
show :: Response a -> String
show rsp :: Response a
rsp@(Response (a :: Int
a,b :: Int
b,c :: Int
c) reason :: String
reason headers :: [Header]
headers _) =
String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
reason String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) [] ((Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
forall a. Show a => a -> String
show ([Header] -> [Header]
dropHttpVersion [Header]
headers)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
crlf
where
ver :: String
ver = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
httpVersion (Response a -> Maybe String
forall a. Response a -> Maybe String
getResponseVersion Response a
rsp)
instance HasHeaders (Response a) where
getHeaders :: Response a -> [Header]
getHeaders = Response a -> [Header]
forall a. Response a -> [Header]
rspHeaders
setHeaders :: Response a -> [Header] -> Response a
setHeaders rsp :: Response a
rsp hdrs :: [Header]
hdrs = Response a
rsp { rspHeaders :: [Header]
rspHeaders=[Header]
hdrs }
libUA :: String
libUA :: String
libUA = "hs-HTTP-4000.0.9"
{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-}
defaultUserAgent :: String
defaultUserAgent :: String
defaultUserAgent = "haskell-HTTP/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
httpPackageVersion
httpPackageVersion :: String
httpPackageVersion :: String
httpPackageVersion = Version -> String
showVersion Version
Self.version
defaultGETRequest :: URI -> Request_String
defaultGETRequest :: URI -> Request_String
defaultGETRequest uri :: URI
uri = URI -> Request_String
forall a. BufferType a => URI -> Request a
defaultGETRequest_ URI
uri
defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ :: URI -> Request a
defaultGETRequest_ uri :: URI
uri = RequestMethod -> URI -> Request a
forall ty. BufferType ty => RequestMethod -> URI -> Request ty
mkRequest RequestMethod
GET URI
uri
mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty
mkRequest :: RequestMethod -> URI -> Request ty
mkRequest meth :: RequestMethod
meth uri :: URI
uri = Request ty
req
where
req :: Request ty
req =
Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqURI :: URI
rqURI = URI
uri
, rqBody :: ty
rqBody = ty
empty
, rqHeaders :: [Header]
rqHeaders = [ HeaderName -> String -> Header
Header HeaderName
HdrContentLength "0"
, HeaderName -> String -> Header
Header HeaderName
HdrUserAgent String
defaultUserAgent
]
, rqMethod :: RequestMethod
rqMethod = RequestMethod
meth
}
empty :: ty
empty = BufferOp ty -> ty
forall a. BufferOp a -> a
buf_empty (Request ty -> BufferOp ty
forall a. BufferType a => Request a -> BufferOp a
toBufOps Request ty
req)
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody :: Request_String -> (String, String) -> Request_String
setRequestBody req :: Request_String
req (typ :: String
typ, body :: String
body) = Request_String
req' { rqBody :: String
rqBody=String
body }
where
req' :: Request_String
req' = HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentType String
typ (Request_String -> Request_String)
-> (Request_String -> Request_String)
-> Request_String
-> Request_String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
HeaderSetter Request_String
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentLength (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
body) (Request_String -> Request_String)
-> Request_String -> Request_String
forall a b. (a -> b) -> a -> b
$
Request_String
req
toBufOps :: BufferType a => Request a -> BufferOp a
toBufOps :: Request a -> BufferOp a
toBufOps _ = BufferOp a
forall bufType. BufferType bufType => BufferOp bufType
bufferOps
parseRequestHead :: [String] -> Result RequestData
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = ConnError -> Result RequestData
forall a b. a -> Either a b
Left ConnError
ErrorClosed
parseRequestHead (com :: String
com:hdrs :: [String]
hdrs) = do
(version :: [String]
version,rqm :: RequestMethod
rqm,uri :: URI
uri) <- String
-> [String] -> Either ConnError ([String], RequestMethod, URI)
requestCommand String
com (String -> [String]
words String
com)
[Header]
hdrs' <- [String] -> Result [Header]
parseHeaders [String]
hdrs
RequestData -> Result RequestData
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMethod
rqm,URI
uri,[String] -> [Header] -> [Header]
withVer [String]
version [Header]
hdrs')
where
withVer :: [String] -> [Header] -> [Header]
withVer [] hs :: [Header]
hs = [Header]
hs
withVer (h :: String
h:_) hs :: [Header]
hs = String -> [Header] -> [Header]
withVersion String
h [Header]
hs
requestCommand :: String
-> [String] -> Either ConnError ([String], RequestMethod, URI)
requestCommand l :: String
l _yes :: [String]
_yes@(rqm :: String
rqm:uri :: String
uri:version :: [String]
version) =
case (String -> Maybe URI
parseURIReference String
uri, String -> [(String, RequestMethod)] -> Maybe RequestMethod
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
rqm [(String, RequestMethod)]
rqMethodMap) of
(Just u :: URI
u, Just r :: RequestMethod
r) -> ([String], RequestMethod, URI)
-> Either ConnError ([String], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
version,RequestMethod
r,URI
u)
(Just u :: URI
u, Nothing) -> ([String], RequestMethod, URI)
-> Either ConnError ([String], RequestMethod, URI)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
version,String -> RequestMethod
Custom String
rqm,URI
u)
_ -> String -> Either ConnError ([String], RequestMethod, URI)
forall a. String -> Result a
parse_err String
l
requestCommand l :: String
l _
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l = ConnError -> Either ConnError ([String], RequestMethod, URI)
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
| Bool
otherwise = String -> Either ConnError ([String], RequestMethod, URI)
forall a. String -> Result a
parse_err String
l
parse_err :: String -> Result a
parse_err l :: String
l = String -> String -> Result a
forall a. String -> String -> Result a
responseParseError "parseRequestHead"
("Request command line parse failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l)
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = ConnError -> Result ResponseData
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
parseResponseHead (sts :: String
sts:hdrs :: [String]
hdrs) = do
(version :: String
version,code :: ResponseCode
code,reason :: String
reason) <- String
-> [String] -> Either ConnError (String, ResponseCode, String)
responseStatus String
sts (String -> [String]
words String
sts)
[Header]
hdrs' <- [String] -> Result [Header]
parseHeaders [String]
hdrs
ResponseData -> Result ResponseData
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseCode
code,String
reason, String -> [Header] -> [Header]
withVersion String
version [Header]
hdrs')
where
responseStatus :: String
-> [String] -> Either ConnError (String, ResponseCode, String)
responseStatus _l :: String
_l _yes :: [String]
_yes@(version :: String
version:code :: String
code:reason :: [String]
reason) =
(String, ResponseCode, String)
-> Either ConnError (String, ResponseCode, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
version,String -> ResponseCode
match String
code,ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> ShowS
forall a. [a] -> [a] -> [a]
++" ") [String]
reason)
responseStatus l :: String
l _no :: [String]
_no
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l = ConnError -> Either ConnError (String, ResponseCode, String)
forall a. ConnError -> Result a
failWith ConnError
ErrorClosed
| Bool
otherwise = String -> Either ConnError (String, ResponseCode, String)
forall a. String -> Result a
parse_err String
l
parse_err :: String -> Result a
parse_err l :: String
l =
String -> String -> Result a
forall a. String -> String -> Result a
responseParseError
"parseResponseHead"
("Response status line parse failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l)
match :: String -> ResponseCode
match [a :: Char
a,b :: Char
b,c :: Char
c] = (Char -> Int
digitToInt Char
a,
Char -> Int
digitToInt Char
b,
Char -> Int
digitToInt Char
c)
match _ = (-1,-1,-1)
withVersion :: String -> [Header] -> [Header]
withVersion :: String -> [Header] -> [Header]
withVersion v :: String
v hs :: [Header]
hs
| String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
httpVersion = [Header]
hs
| Bool
otherwise = (HeaderName -> String -> Header
Header (String -> HeaderName
HdrCustom "X-HTTP-Version") String
v) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
hs
getRequestVersion :: Request a -> Maybe String
getRequestVersion :: Request a -> Maybe String
getRequestVersion r :: Request a
r = Request a -> Maybe String
forall a. HasHeaders a => a -> Maybe String
getHttpVersion Request a
r
setRequestVersion :: String -> Request a -> Request a
setRequestVersion :: String -> Request a -> Request a
setRequestVersion s :: String
s r :: Request a
r = Request a -> String -> Request a
forall a. HasHeaders a => a -> String -> a
setHttpVersion Request a
r String
s
getResponseVersion :: Response a -> Maybe String
getResponseVersion :: Response a -> Maybe String
getResponseVersion r :: Response a
r = Response a -> Maybe String
forall a. HasHeaders a => a -> Maybe String
getHttpVersion Response a
r
setResponseVersion :: String -> Response a -> Response a
setResponseVersion :: String -> Response a -> Response a
setResponseVersion s :: String
s r :: Response a
r = Response a -> String -> Response a
forall a. HasHeaders a => a -> String -> a
setHttpVersion Response a
r String
s
getHttpVersion :: HasHeaders a => a -> Maybe String
getHttpVersion :: a -> Maybe String
getHttpVersion r :: a
r =
(Header -> String) -> Maybe Header -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Header -> String
toVersion (Maybe Header -> Maybe String) -> Maybe Header -> Maybe String
forall a b. (a -> b) -> a -> b
$
(Header -> Bool) -> [Header] -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Header -> Bool
isHttpVersion ([Header] -> Maybe Header) -> [Header] -> Maybe Header
forall a b. (a -> b) -> a -> b
$
a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r
where
toVersion :: Header -> String
toVersion (Header _ x :: String
x) = String
x
setHttpVersion :: HasHeaders a => a -> String -> a
setHttpVersion :: a -> String -> a
setHttpVersion r :: a
r v :: String
v =
a -> [Header] -> a
forall x. HasHeaders x => x -> [Header] -> x
setHeaders a
r ([Header] -> a) -> [Header] -> a
forall a b. (a -> b) -> a -> b
$
String -> [Header] -> [Header]
withVersion String
v ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
[Header] -> [Header]
dropHttpVersion ([Header] -> [Header]) -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$
a -> [Header]
forall x. HasHeaders x => x -> [Header]
getHeaders a
r
dropHttpVersion :: [Header] -> [Header]
dropHttpVersion :: [Header] -> [Header]
dropHttpVersion hs :: [Header]
hs = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Header -> Bool
isHttpVersion) [Header]
hs
isHttpVersion :: Header -> Bool
isHttpVersion :: Header -> Bool
isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = Bool
True
isHttpVersion _ = Bool
False
data ResponseNextStep
= Continue
| Retry
| Done
| ExpectEntity
| DieHorribly String
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse rqst :: RequestMethod
rqst rsp :: ResponseCode
rsp =
case ResponseCode
rsp of
(1,0,0) -> ResponseNextStep
Continue
(1,0,1) -> ResponseNextStep
Done
(1,_,_) -> ResponseNextStep
Continue
(2,0,4) -> ResponseNextStep
Done
(2,0,5) -> ResponseNextStep
Done
(2,_,_) -> ResponseNextStep
ans
(3,0,4) -> ResponseNextStep
Done
(3,0,5) -> ResponseNextStep
Done
(3,_,_) -> ResponseNextStep
ans
(4,1,7) -> ResponseNextStep
Retry
(4,_,_) -> ResponseNextStep
ans
(5,_,_) -> ResponseNextStep
ans
(a :: Int
a,b :: Int
b,c :: Int
c) -> String -> ResponseNextStep
DieHorribly ("Response code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
a,Int
b,Int
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ " not recognised")
where
ans :: ResponseNextStep
ans | RequestMethod
rqst RequestMethod -> RequestMethod -> Bool
forall a. Eq a => a -> a -> Bool
== RequestMethod
HEAD = ResponseNextStep
Done
| Bool
otherwise = ResponseNextStep
ExpectEntity
replacement_character :: Char
replacement_character :: Char
replacement_character = '\xfffd'
encodeChar :: Char -> [Word8]
encodeChar :: Char -> [Word8]
encodeChar = (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Word8]) -> (Char -> [Int]) -> Char -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. (Ord a, Num a, Bits a) => a -> [a]
go (Int -> [Int]) -> (Char -> Int) -> Char -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
where
go :: a -> [a]
go oc :: a
oc
| a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7f = [a
oc]
| a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7ff = [ 0xc0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 6)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f
]
| a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xffff = [ 0xe0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 12)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f
]
| Bool
otherwise = [ 0xf0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 18)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 12) a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` 6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f)
, 0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. 0x3f
]
decode :: [Word8] -> String
decode :: [Word8] -> String
decode [ ] = ""
decode (c :: Word8
c:cs :: [Word8]
cs)
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80 = Int -> Char
chr (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c) Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xc0 = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xe0 = String
multi1
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xf0 = Int -> Word8 -> Int -> String
multi_byte 2 0xf 0x800
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xf8 = Int -> Word8 -> Int -> String
multi_byte 3 0x7 0x10000
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xfc = Int -> Word8 -> Int -> String
multi_byte 4 0x3 0x200000
| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 0xfe = Int -> Word8 -> Int -> String
multi_byte 5 0x1 0x4000000
| Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
where
multi1 :: String
multi1 = case [Word8]
cs of
c1 :: Word8
c1 : ds :: [Word8]
ds | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80 ->
let d :: Int
d = ((Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x1f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3f)
in if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x000080 then Int -> Char
forall a. Enum a => Int -> a
toEnum Int
d Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
ds
else Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
ds
_ -> Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
cs
multi_byte :: Int -> Word8 -> Int -> [Char]
multi_byte :: Int -> Word8 -> Int -> String
multi_byte i :: Int
i mask :: Word8
mask overlong :: Int
overlong = Int -> [Word8] -> Int -> String
forall t. (Eq t, Num t) => t -> [Word8] -> Int -> String
aux Int
i [Word8]
cs (Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask))
where
aux :: t -> [Word8] -> Int -> String
aux 0 rs :: [Word8]
rs acc :: Int
acc
| Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc Bool -> Bool -> Bool
&& Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x10ffff Bool -> Bool -> Bool
&&
(Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0xd800 Bool -> Bool -> Bool
|| 0xdfff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc) Bool -> Bool -> Bool
&&
(Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0xfffe Bool -> Bool -> Bool
|| 0xffff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc) = Int -> Char
chr Int
acc Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
rs
| Bool
otherwise = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
rs
aux n :: t
n (r :: Word8
r:rs :: [Word8]
rs) acc :: Int
acc
| Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xc0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80 = t -> [Word8] -> Int -> String
aux (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [Word8]
rs
(Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
acc 6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8
r Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3f)
aux _ rs :: [Word8]
rs _ = Char
replacement_character Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> String
decode [Word8]
rs
urlDecode :: String -> String
urlDecode :: ShowS
urlDecode = [Word8] -> ShowS
go []
where
go :: [Word8] -> ShowS
go bs :: [Word8]
bs ('%':a :: Char
a:b :: Char
b:rest :: String
rest) = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (16 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Char -> Int
digitToInt Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
b) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) String
rest
go bs :: [Word8]
bs (h :: Char
h:t :: String
t) | Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 256 = [Word8] -> ShowS
go (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
h) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bs) String
t
go [] [] = []
go [] (h :: Char
h:t :: String
t) = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: [Word8] -> ShowS
go [] String
t
go bs :: [Word8]
bs rest :: String
rest = [Word8] -> String
decode ([Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
bs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Word8] -> ShowS
go [] String
rest
urlEncode :: String -> String
urlEncode :: ShowS
urlEncode [] = []
urlEncode (ch :: Char
ch:t :: String
t)
| (Char -> Bool
isAscii Char
ch Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
ch) Bool -> Bool -> Bool
|| Char
ch Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "-_.~" = Char
ch Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode String
t
| Bool -> Bool
not (Char -> Bool
isAscii Char
ch) = (Word8 -> ShowS) -> String -> [Word8] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> ShowS
escape (ShowS
urlEncode String
t) (Char -> [Word8]
encodeChar Char
ch)
| Bool
otherwise = Word8 -> ShowS
escape (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch)) (ShowS
urlEncode String
t)
where
escape :: Word8 -> ShowS
escape b :: Word8
b rs :: String
rs = '%'Char -> ShowS
forall a. a -> [a] -> [a]
:Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` 16) (Word8 -> ShowS
showH (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` 16) String
rs)
showH :: Word8 -> String -> String
showH :: Word8 -> ShowS
showH x :: Word8
x xs :: String
xs
| Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 9 = Word8 -> Char
to (Word8
o_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
x) Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
| Bool
otherwise = Word8 -> Char
to (Word8
o_A Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (Word8
xWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-10)) Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
where
to :: Word8 -> Char
to = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
fro :: Char -> Word8
fro = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
o_0 :: Word8
o_0 = Char -> Word8
fro Char
'0'
o_A :: Word8
o_A = Char -> Word8
fro Char
'A'
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars :: [(String, String)] -> String
urlEncodeVars ((n :: String
n,v :: String
v):t :: [(String, String)]
t) =
let (same :: [(String, String)]
same,diff :: [(String, String)]
diff) = ((String, String) -> Bool)
-> [(String, String)] -> ([(String, String)], [(String, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
t
in ShowS
urlEncode String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ '=' Char -> ShowS
forall a. a -> [a] -> [a]
: (String -> ShowS) -> String -> [String] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\x :: String
x y :: String
y -> String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ ',' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
urlEncode String
y) (ShowS
urlEncode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
v) (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> b
snd [(String, String)]
same)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
urlEncodeRest [(String, String)]
diff
where urlEncodeRest :: [(String, String)] -> String
urlEncodeRest [] = []
urlEncodeRest diff :: [(String, String)]
diff = '&' Char -> ShowS
forall a. a -> [a] -> [a]
: [(String, String)] -> String
urlEncodeVars [(String, String)]
diff
urlEncodeVars [] = []
#if MIN_VERSION_base(4,13,0)
getAuth :: MonadFail m => Request ty -> m URIAuthority
#else
getAuth :: Monad m => Request ty -> m URIAuthority
#endif
getAuth :: Request ty -> m URIAuthority
getAuth r :: Request ty
r =
case String -> Maybe URIAuthority
parseURIAuthority String
auth of
Just x :: URIAuthority
x -> URIAuthority -> m URIAuthority
forall (m :: * -> *) a. Monad m => a -> m a
return URIAuthority
x
Nothing -> String -> m URIAuthority
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URIAuthority) -> String -> m URIAuthority
forall a b. (a -> b) -> a -> b
$ "Network.HTTP.Base.getAuth: Error parsing URI authority '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
auth String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'"
where
auth :: String
auth = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (URI -> String
uriToAuthorityString URI
uri) ShowS
forall a. a -> a
id (HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
r)
uri :: URI
uri = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r
{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeRequestURI :: Bool -> String -> Request ty -> Request ty
normalizeRequestURI :: Bool -> String -> Request ty -> Request ty
normalizeRequestURI doClose :: Bool
doClose h :: String
h r :: Request ty
r =
(if Bool
doClose then HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection "close" else Request ty -> Request ty
forall a. a -> a
id) (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost String
h (Request ty -> Request ty) -> Request ty -> Request ty
forall a b. (a -> b) -> a -> b
$
Request ty
r { rqURI :: URI
rqURI = (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r){ uriScheme :: String
uriScheme = ""
, uriAuthority :: Maybe URIAuth
uriAuthority = Maybe URIAuth
forall a. Maybe a
Nothing
}}
data NormalizeRequestOptions ty
= NormalizeRequestOptions
{ NormalizeRequestOptions ty -> Bool
normDoClose :: Bool
, NormalizeRequestOptions ty -> Bool
normForProxy :: Bool
, NormalizeRequestOptions ty -> Maybe String
normUserAgent :: Maybe String
, NormalizeRequestOptions ty -> [RequestNormalizer ty]
normCustoms :: [RequestNormalizer ty]
}
type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty
defaultNormalizeRequestOptions :: NormalizeRequestOptions ty
defaultNormalizeRequestOptions :: NormalizeRequestOptions ty
defaultNormalizeRequestOptions = NormalizeRequestOptions :: forall ty.
Bool
-> Bool
-> Maybe String
-> [RequestNormalizer ty]
-> NormalizeRequestOptions ty
NormalizeRequestOptions
{ normDoClose :: Bool
normDoClose = Bool
False
, normForProxy :: Bool
normForProxy = Bool
False
, normUserAgent :: Maybe String
normUserAgent = String -> Maybe String
forall a. a -> Maybe a
Just String
defaultUserAgent
, normCustoms :: [RequestNormalizer ty]
normCustoms = []
}
normalizeRequest :: NormalizeRequestOptions ty
-> Request ty
-> Request ty
normalizeRequest :: NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest opts :: NormalizeRequestOptions ty
opts req :: Request ty
req = ((NormalizeRequestOptions ty -> Request ty -> Request ty)
-> Request ty -> Request ty)
-> Request ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> Request ty
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ f :: NormalizeRequestOptions ty -> Request ty -> Request ty
f -> NormalizeRequestOptions ty -> Request ty -> Request ty
f NormalizeRequestOptions ty
opts) Request ty
req [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers
where
normalizers :: [NormalizeRequestOptions ty -> Request ty -> Request ty]
normalizers =
( NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeHostURI
(NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeBasicAuth
(NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeConnectionClose
(NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. RequestNormalizer ty
normalizeUserAgent
(NormalizeRequestOptions ty -> Request ty -> Request ty)
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall a. a -> [a] -> [a]
: NormalizeRequestOptions ty
-> [NormalizeRequestOptions ty -> Request ty -> Request ty]
forall ty. NormalizeRequestOptions ty -> [RequestNormalizer ty]
normCustoms NormalizeRequestOptions ty
opts
)
normalizeUserAgent :: RequestNormalizer ty
normalizeUserAgent :: RequestNormalizer ty
normalizeUserAgent opts :: NormalizeRequestOptions ty
opts req :: Request ty
req =
case NormalizeRequestOptions ty -> Maybe String
forall ty. NormalizeRequestOptions ty -> Maybe String
normUserAgent NormalizeRequestOptions ty
opts of
Nothing -> Request ty
req
Just ua :: String
ua ->
case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrUserAgent Request ty
req of
Just u :: String
u | String
u String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
defaultUserAgent -> Request ty
req
_ -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrUserAgent String
ua Request ty
req
normalizeConnectionClose :: RequestNormalizer ty
normalizeConnectionClose :: RequestNormalizer ty
normalizeConnectionClose opts :: NormalizeRequestOptions ty
opts req :: Request ty
req
| NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normDoClose NormalizeRequestOptions ty
opts = HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrConnection "close" Request ty
req
| Bool
otherwise = Request ty
req
normalizeBasicAuth :: RequestNormalizer ty
normalizeBasicAuth :: RequestNormalizer ty
normalizeBasicAuth _ req :: Request ty
req =
case Request ty -> Maybe URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request ty
req of
Just uriauth :: URIAuthority
uriauth ->
case (URIAuthority -> Maybe String
user URIAuthority
uriauth, URIAuthority -> Maybe String
password URIAuthority
uriauth) of
(Just u :: String
u, Just p :: String
p) ->
HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrAuthorization String
astr Request ty
req
where
astr :: String
astr = "Basic " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
base64encode (String
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p)
base64encode :: ShowS
base64encode = [Word8] -> String
Base64.encode ([Word8] -> String) -> (String -> [Word8]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
stringToOctets :: String -> String
stringToOctets :: String -> [Word8]
stringToOctets = (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) :: String -> [Word8]
(_, _) -> Request ty
req
Nothing ->Request ty
req
normalizeHostURI :: RequestNormalizer ty
normalizeHostURI :: RequestNormalizer ty
normalizeHostURI opts :: NormalizeRequestOptions ty
opts req :: Request ty
req =
case URI -> (String, URI)
splitRequestURI URI
uri of
("",_uri_abs :: URI
_uri_abs)
| Bool
forProxy ->
case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
req of
Nothing -> Request ty
req
Just h :: String
h -> Request ty
req{rqURI :: URI
rqURI=URI
uri{ uriAuthority :: Maybe URIAuth
uriAuthority=URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just URIAuth :: String -> String -> String -> URIAuth
URIAuth{uriUserInfo :: String
uriUserInfo="", uriRegName :: String
uriRegName=String
hst, uriPort :: String
uriPort=String
pNum}
, uriScheme :: String
uriScheme=if (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriScheme URI
uri)) then "http" else URI -> String
uriScheme URI
uri
}}
where
hst :: String
hst = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='@') String
user_hst of
(as :: String
as,'@':bs :: String
bs) ->
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=':') String
as of
(_,_:_) -> String
bs
_ -> String
user_hst
_ -> String
user_hst
(user_hst :: String
user_hst, pNum :: String
pNum) =
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit (ShowS
forall a. [a] -> [a]
reverse String
h) of
(ds :: String
ds,':':bs :: String
bs) -> (ShowS
forall a. [a] -> [a]
reverse String
bs, ':'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
forall a. [a] -> [a]
reverse String
ds)
_ -> (String
h,"")
| Bool
otherwise ->
case HeaderName -> Request ty -> Maybe String
forall a. HasHeaders a => HeaderName -> a -> Maybe String
findHeader HeaderName
HdrHost Request ty
req of
Nothing -> Request ty
req
Just{} -> Request ty
req
(h :: String
h,uri_abs :: URI
uri_abs)
| Bool
forProxy -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost String
h Request ty
req
| Bool
otherwise -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrHost String
h Request ty
req{rqURI :: URI
rqURI=URI
uri_abs}
where
uri0 :: URI
uri0 = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req
uri :: URI
uri = URI
uri0{uriAuthority :: Maybe URIAuth
uriAuthority=(URIAuth -> URIAuth) -> Maybe URIAuth -> Maybe URIAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ x :: URIAuth
x -> URIAuth
x{uriUserInfo :: String
uriUserInfo=""}) (URI -> Maybe URIAuth
uriAuthority URI
uri0)}
forProxy :: Bool
forProxy = NormalizeRequestOptions ty -> Bool
forall ty. NormalizeRequestOptions ty -> Bool
normForProxy NormalizeRequestOptions ty
opts
splitRequestURI :: URI -> (String, URI)
splitRequestURI :: URI -> (String, URI)
splitRequestURI uri :: URI
uri = (URI -> String
uriToAuthorityString URI
uri, URI
uri{uriScheme :: String
uriScheme="", uriAuthority :: Maybe URIAuth
uriAuthority=Maybe URIAuth
forall a. Maybe a
Nothing})
{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-}
normalizeHostHeader :: Request ty -> Request ty
rq :: Request ty
rq =
HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeaderIfMissing HeaderName
HdrHost
(URI -> String
uriToAuthorityString (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq)
Request ty
rq
findConnClose :: [Header] -> Bool
findConnClose :: [Header] -> Bool
findConnClose hdrs :: [Header]
hdrs =
Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
(\ x :: String
x -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim String
x) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "close")
(HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrConnection [Header]
hdrs)
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer readBlk :: Int -> IO (Result a)
readBlk n :: Int
n = (a -> Result ([Header], a))
-> IO (Result a) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\str :: a
str -> ([Header], a) -> Result ([Header], a)
forall a b. b -> Either a b
Right ([],a
str)) (Int -> IO (Result a)
readBlk Int
n)
hopefulTransfer :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result ([Header],a))
hopefulTransfer :: BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer bufOps :: BufferOp a
bufOps readL :: IO (Result a)
readL strs :: [a]
strs
= IO (Result a)
readL IO (Result a)
-> (Result a -> IO (Result ([Header], a)))
-> IO (Result ([Header], a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ConnError -> IO (Result ([Header], a)))
-> (a -> IO (Result ([Header], a)))
-> Result a
-> IO (Result ([Header], a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\v :: ConnError
v -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result ([Header], a) -> IO (Result ([Header], a)))
-> Result ([Header], a) -> IO (Result ([Header], a))
forall a b. (a -> b) -> a -> b
$ ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
v)
(\more :: a
more -> if (BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
more)
then Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], a) -> Result ([Header], a)
forall a b. b -> Either a b
Right ([], BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
strs))
else BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp a
bufOps IO (Result a)
readL (a
morea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
strs))
chunkedTransfer :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer bufOps :: BufferOp a
bufOps readL :: IO (Result a)
readL readBlk :: Int -> IO (Result a)
readBlk = BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk [] 0
chunkedTransferC :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC bufOps :: BufferOp a
bufOps readL :: IO (Result a)
readL readBlk :: Int -> IO (Result a)
readBlk acc :: [a]
acc n :: Int
n = do
Result a
v <- IO (Result a)
readL
case Result a
v of
Left e :: ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
Right line :: a
line
| Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 ->
([a] -> Result ([Header], a))
-> IO (Result [a]) -> IO (Result ([Header], a))
forall a b. (a -> Result b) -> IO (Result a) -> IO (Result b)
fmapE (\ strs :: [a]
strs -> do
[Header]
ftrs <- [String] -> Result [Header]
parseHeaders ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp a
bufOps) [a]
strs)
let ftrs' :: [Header]
ftrs' = HeaderName -> String -> Header
Header HeaderName
HdrContentLength (Int -> String
forall a. Show a => a -> String
show Int
n) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
ftrs
([Header], a) -> Result ([Header], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header]
ftrs',BufferOp a -> [a] -> a
forall a. BufferOp a -> [a] -> a
buf_concat BufferOp a
bufOps ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)))
(BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [])
| Bool
otherwise -> do
Result a
some <- Int -> IO (Result a)
readBlk Int
size
case Result a
some of
Left e :: ConnError
e -> Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result ([Header], a)
forall a b. a -> Either a b
Left ConnError
e)
Right cdata :: a
cdata -> do
Result a
_ <- IO (Result a)
readL
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> [a]
-> Int
-> IO (Result ([Header], a))
chunkedTransferC BufferOp a
bufOps IO (Result a)
readL Int -> IO (Result a)
readBlk (a
cdataa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
size)
where
size :: Int
size
| BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
line = 0
| Bool
otherwise =
case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr BufferOp a
bufOps a
line) of
(hx :: Int
hx,_):_ -> Int
hx
_ -> 0
uglyDeathTransfer :: String -> IO (Result ([Header],a))
uglyDeathTransfer :: String -> IO (Result ([Header], a))
uglyDeathTransfer loc :: String
loc = Result ([Header], a) -> IO (Result ([Header], a))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> Result ([Header], a)
forall a. String -> String -> Result a
responseParseError String
loc "Unknown Transfer-Encoding")
readTillEmpty1 :: BufferOp a
-> IO (Result a)
-> IO (Result [a])
readTillEmpty1 :: BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 bufOps :: BufferOp a
bufOps readL :: IO (Result a)
readL =
IO (Result a)
readL IO (Result a) -> (Result a -> IO (Result [a])) -> IO (Result [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ConnError -> IO (Result [a]))
-> (a -> IO (Result [a])) -> Result a -> IO (Result [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [a] -> IO (Result [a]))
-> (ConnError -> Result [a]) -> ConnError -> IO (Result [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result [a]
forall a b. a -> Either a b
Left)
(\ s :: a
s ->
if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s
then BufferOp a -> IO (Result a) -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp a
bufOps IO (Result a)
readL
else BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL [a
s])
readTillEmpty2 :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result [a])
readTillEmpty2 :: BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 bufOps :: BufferOp a
bufOps readL :: IO (Result a)
readL list :: [a]
list =
IO (Result a)
readL IO (Result a) -> (Result a -> IO (Result [a])) -> IO (Result [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ConnError -> IO (Result [a]))
-> (a -> IO (Result [a])) -> Result a -> IO (Result [a])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [a] -> IO (Result [a]))
-> (ConnError -> Result [a]) -> ConnError -> IO (Result [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnError -> Result [a]
forall a b. a -> Either a b
Left)
(\ s :: a
s ->
if BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isLineTerm BufferOp a
bufOps a
s Bool -> Bool -> Bool
|| BufferOp a -> a -> Bool
forall a. BufferOp a -> a -> Bool
buf_isEmpty BufferOp a
bufOps a
s
then Result [a] -> IO (Result [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Result [a]
forall a b. b -> Either a b
Right ([a] -> Result [a]) -> [a] -> Result [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list))
else BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
forall a. BufferOp a -> IO (Result a) -> [a] -> IO (Result [a])
readTillEmpty2 BufferOp a
bufOps IO (Result a)
readL (a
sa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
list))
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a :: IO a
a h :: IOException -> IO a
h = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch IO a
a IOException -> IO a
h
catchIO_ :: IO a -> IO a -> IO a
catchIO_ :: IO a -> IO a -> IO a
catchIO_ a :: IO a
a h :: IO a
h = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch IO a
a (\(IOException
_ :: IOException) -> IO a
h)
responseParseError :: String -> String -> Result a
responseParseError :: String -> String -> Result a
responseParseError loc :: String
loc v :: String
v = ConnError -> Result a
forall a. ConnError -> Result a
failWith (String -> ConnError
ErrorParse (String
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ ' 'Char -> ShowS
forall a. a -> [a] -> [a]
:String
v))