module Network.HTTP.Base
(
httpVersion
, Request(..)
, Response(..)
, RequestMethod(..)
, Request_String
, Response_String
, HTTPRequest
, HTTPResponse
, urlEncode
, urlDecode
, urlEncodeVars
, URIAuthority(..)
, parseURIAuthority
, crlf
, sp
, uriToAuthorityString
, uriAuthToString
, parseResponseHead
, parseRequestHead
, ResponseNextStep(..)
, matchResponse
, ResponseData
, ResponseCode
, RequestData
, getAuth
, normalizeRequestURI
, normalizeHostHeader
, findConnClose
, linearTransfer
, hopefulTransfer
, chunkedTransfer
, uglyDeathTransfer
, readTillEmpty1
, readTillEmpty2
, catchIO
, catchIO_
, responseParseError
) where
import Network.URI
( URI(uriAuthority, uriPath, uriScheme)
, URIAuth(uriUserInfo, uriRegName, uriPort)
, parseURIReference
)
import Control.Monad ( guard )
import Control.Monad.Error
import Data.Char ( ord, digitToInt, intToDigit, toLower )
import Data.List ( partition )
import Data.Maybe ( listToMaybe )
import Numeric ( showHex, readHex )
import Network.Stream
import Network.BufferType ( BufferOp(..) )
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim )
import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
( ReadP, readP_to_S, char, (<++), look, munch )
import Control.Exception as Exception (IOException)
data URIAuthority = URIAuthority { user :: Maybe String,
password :: Maybe String,
host :: String,
port :: Maybe Int
} deriving (Eq,Show)
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
(u,pw) <- (pUserInfo `before` char '@')
<++ return (Nothing, Nothing)
h <- munch (/=':')
p <- orNothing (char ':' >> readDecP)
look >>= guard . null
return URIAuthority{ user=u, password=pw, host=h, port=p }
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
u <- orNothing (munch (`notElem` ":@"))
p <- orNothing (char ':' >> munch (/='@'))
return (u,p)
before :: Monad m => m a -> m b -> m a
before a b = a >>= \x -> b >> return x
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing p = fmap Just p <++ return Nothing
uriToAuthorityString :: URI -> String
uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)
uriAuthToString :: URIAuth -> String
uriAuthToString ua =
concat [ uriUserInfo ua
, uriRegName ua
, uriPort ua
]
httpVersion :: String
httpVersion = "HTTP/1.1"
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE
deriving(Show,Eq)
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [("HEAD", HEAD),
("PUT", PUT),
("GET", GET),
("POST", POST),
("DELETE", DELETE),
("OPTIONS", OPTIONS),
("TRACE", TRACE)]
type Request_String = Request String
type Response_String = Response String
type HTTPRequest a = Request a
type HTTPResponse a = Response a
data Request a =
Request { rqURI :: URI
, rqMethod :: RequestMethod
, rqHeaders :: [Header]
, rqBody :: a
}
crlf, sp :: String
crlf = "\r\n"
sp = " "
instance Show (Request a) where
show (Request u m h _) =
show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf
++ foldr (++) [] (map show h) ++ crlf
where
alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'
then u { uriPath = '/' : uriPath u }
else u
instance HasHeaders (Request a) where
getHeaders = rqHeaders
setHeaders rq hdrs = rq { rqHeaders=hdrs }
type ResponseCode = (Int,Int,Int)
type ResponseData = (ResponseCode,String,[Header])
type RequestData = (RequestMethod,URI,[Header])
data Response a =
Response { rspCode :: ResponseCode
, rspReason :: String
, rspHeaders :: [Header]
, rspBody :: a
}
instance Show (Response a) where
show (Response (a,b,c) reason headers _) =
httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
++ foldr (++) [] (map show headers) ++ crlf
instance HasHeaders (Response a) where
getHeaders = rspHeaders
setHeaders rsp hdrs = rsp { rspHeaders=hdrs }
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = Left ErrorClosed
parseRequestHead (com:hdrs) = do
(_version,rqm,uri) <- requestCommand com (words com)
hdrs' <- parseHeaders hdrs
return (rqm,uri,hdrs')
where
requestCommand l _yes@(rqm:uri:version) =
case (parseURIReference uri, lookup rqm rqMethodMap) of
(Just u, Just r) -> return (version,r,u)
_ -> parse_err l
requestCommand l _
| null l = failWith ErrorClosed
| otherwise = parse_err l
parse_err l = responseParseError "parseRequestHead"
("Request command line parse failure: " ++ l)
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = failWith ErrorClosed
parseResponseHead (sts:hdrs) = do
(_version,code,reason) <- responseStatus sts (words sts)
hdrs' <- parseHeaders hdrs
return (code,reason,hdrs')
where
responseStatus _l _yes@(version:code:reason) =
return (version,match code,concatMap (++" ") reason)
responseStatus l _no
| null l = failWith ErrorClosed
| otherwise = parse_err l
parse_err l =
responseParseError
"parseResponseHead"
("Response status line parse failure: " ++ l)
match [a,b,c] = (digitToInt a,
digitToInt b,
digitToInt c)
match _ = (1,1,1)
data ResponseNextStep
= Continue
| Retry
| Done
| ExpectEntity
| DieHorribly String
matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse rqst rsp =
case rsp of
(1,0,0) -> Continue
(1,0,1) -> Done
(1,_,_) -> Continue
(2,0,4) -> Done
(2,0,5) -> Done
(2,_,_) -> ans
(3,0,4) -> Done
(3,0,5) -> Done
(3,_,_) -> ans
(4,1,7) -> Retry
(4,_,_) -> ans
(5,_,_) -> ans
(a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")
where
ans | rqst == HEAD = Done
| otherwise = ExpectEntity
urlEncode, urlDecode :: String -> String
urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b)
: urlDecode rest
urlDecode (h:t) = h : urlDecode t
urlDecode [] = []
urlEncode (h:t) =
let str = if reserved (ord h) then escape h else [h]
in str ++ urlEncode t
where
reserved x
| x >= ord 'a' && x <= ord 'z' = False
| x >= ord 'A' && x <= ord 'Z' = False
| x >= ord '0' && x <= ord '9' = False
| x <= 0x20 || x >= 0x7F = True
| otherwise = x `elem` map ord [';','/','?',':','@','&'
,'=','+',',','$','{','}'
,'|','\\','^','[',']','`'
,'<','>','#','%','"']
escape x = '%':showHex (ord x) ""
urlEncode [] = []
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars ((n,v):t) =
let (same,diff) = partition ((==n) . fst) t
in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
++ urlEncodeRest diff
where urlEncodeRest [] = []
urlEncodeRest diff = '&' : urlEncodeVars diff
urlEncodeVars [] = []
getAuth :: Monad m => Request ty -> m URIAuthority
getAuth r =
case parseURIAuthority auth of
Just x -> return x
Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"
where
auth =
case findHeader HdrHost r of
Just h -> h
Nothing -> uriToAuthorityString (rqURI r)
normalizeRequestURI :: Bool -> String -> Request ty -> Request ty
normalizeRequestURI doClose h r =
(if doClose then replaceHeader HdrConnection "close" else id) $
insertHeaderIfMissing HdrHost h $
r { rqURI = (rqURI r){ uriScheme = ""
, uriAuthority = Nothing
}}
normalizeHostHeader :: Request ty -> Request ty
normalizeHostHeader rq =
insertHeaderIfMissing HdrHost
(uriToAuthorityString $ rqURI rq)
rq
findConnClose :: [Header] -> Bool
findConnClose hdrs =
maybe False
(\ x -> map toLower (trim x) == "close")
(lookupHeader HdrConnection hdrs)
linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n)
hopefulTransfer :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result ([Header],a))
hopefulTransfer bufOps readL strs
= readL >>=
either (\v -> return $ Left v)
(\more -> if (buf_isEmpty bufOps more)
then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs))
else hopefulTransfer bufOps readL (more:strs))
chunkedTransfer :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer bufOps readL readBlk =
fmapE (\ (ftrs,count,info) ->
let myftrs = Header HdrContentLength (show count) : ftrs
in Right (myftrs,info))
(chunkedTransferC bufOps readL readBlk 0)
chunkedTransferC :: BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> Int
-> IO (Result ([Header],Int,a))
chunkedTransferC bufOps readL readBlk n = do
v <- readL
case v of
Left e -> return (Left e)
Right line
| size == 0 ->
fmapE (\ strs -> do
ftrs <- parseHeaders (map (buf_toStr bufOps) strs)
return (ftrs,n,buf_empty bufOps))
(readTillEmpty2 bufOps readL [])
| otherwise -> do
some <- readBlk size
readL
more <- chunkedTransferC bufOps readL readBlk (n+size)
return $ do
cdata <- some
(ftrs,m,mdata) <- more
return (ftrs,m,buf_append bufOps cdata mdata)
where
size
| buf_isEmpty bufOps line = 0
| otherwise =
case readHex (buf_toStr bufOps line) of
(hx,_):_ -> hx
_ -> 0
uglyDeathTransfer :: String -> IO (Result ([Header],a))
uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding")
readTillEmpty1 :: BufferOp a
-> IO (Result a)
-> IO (Result [a])
readTillEmpty1 bufOps readL =
readL >>=
either (return . Left)
(\ s ->
if buf_isLineTerm bufOps s
then readTillEmpty1 bufOps readL
else readTillEmpty2 bufOps readL [s])
readTillEmpty2 :: BufferOp a
-> IO (Result a)
-> [a]
-> IO (Result [a])
readTillEmpty2 bufOps readL list =
readL >>=
either (return . Left)
(\ s ->
if buf_isLineTerm bufOps s || buf_isEmpty bufOps s
then return (Right $ reverse (s:list))
else readTillEmpty2 bufOps readL (s:list))
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO a h = Prelude.catch a h
catchIO_ :: IO a -> IO a -> IO a
catchIO_ a h = Prelude.catch a (const h)
responseParseError :: String -> String -> Result a
responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))