module Network.HTTP.Base
(
httpVersion
, Request
, Response
, RequestMethod(..)
, 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_
) where
import Network.URI
( URI(uriAuthority, uriPath, uriScheme)
, URIAuth(uriUserInfo, uriRegName, uriPort)
, parseURIReference
)
import Control.Monad ( guard )
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 = HTTPRequest String
type Response = HTTPResponse String
data HTTPRequest a =
Request { rqURI :: URI
, rqMethod :: RequestMethod
, rqHeaders :: [Header]
, rqBody :: a
}
crlf, sp :: String
crlf = "\r\n"
sp = " "
instance Show (HTTPRequest 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 (HTTPRequest 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 HTTPResponse a =
Response { rspCode :: ResponseCode
, rspReason :: String
, rspHeaders :: [Header]
, rspBody :: a
}
instance Show (HTTPResponse a) where
show (Response (a,b,c) reason headers _) =
httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
++ foldr (++) [] (map show headers) ++ crlf
instance HasHeaders (HTTPResponse a) where
getHeaders = rspHeaders
setHeaders rsp hdrs = rsp { rspHeaders=hdrs }
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = Left ErrorClosed
parseRequestHead (com:hdrs) =
requestCommand com `bindE` \(_version,rqm,uri) ->
parseHeaders hdrs `bindE` \hdrs' ->
Right (rqm,uri,hdrs')
where
requestCommand line =
case words line of
_yes@(rqm:uri:version) ->
case (parseURIReference uri, lookup rqm rqMethodMap) of
(Just u, Just r) -> Right (version,r,u)
_ -> Left parse_err
_no
| null line -> Left ErrorClosed
| otherwise -> Left parse_err
where
parse_err = ErrorParse ("Request command line parse failure: " ++ line)
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = Left ErrorClosed
parseResponseHead (sts:hdrs) =
responseStatus sts `bindE` \(_version,code,reason) ->
parseHeaders hdrs `bindE` \hdrs' ->
Right (code,reason,hdrs')
where
responseStatus line =
case words line of
_yes@(version:code:reason) ->
Right (version,match code,concatMap (++" ") reason)
_no
| null line -> Left ErrorClosed
| otherwise -> Left parse_err
where
parse_err = (ErrorParse $ "Response status line parse failure: " ++ line)
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 => HTTPRequest 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 :: URIAuthority -> HTTPRequest ty -> HTTPRequest ty
normalizeRequestURI URIAuthority{host=h} r =
replaceHeader HdrConnection "close" $
insertHeaderIfMissing HdrHost h $
r { rqURI = (rqURI r){ uriScheme = ""
, uriAuthority = Nothing
}}
normalizeHostHeader :: HTTPRequest ty -> HTTPRequest 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
= do info <- readBlk n
return $ info `bindE` \str -> Right ([],str)
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 = do
v <- chunkedTransferC bufOps readL readBlk 0
return $ v `bindE` \(ftrs,count,info) ->
let myftrs = Header HdrContentLength (show count) : ftrs
in Right (myftrs,info)
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 -> do
rs <- readTillEmpty2 bufOps readL []
return $
rs `bindE` \strs ->
parseHeaders (map (buf_toStr bufOps) strs) `bindE` \ftrs ->
Right (ftrs,n,buf_empty bufOps)
| otherwise -> do
some <- readBlk size
readL
more <- chunkedTransferC bufOps readL readBlk (n+size)
return $
some `bindE` \cdata ->
more `bindE` \(ftrs,m,mdata) ->
Right (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 :: IO (Result ([Header],a))
uglyDeathTransfer
= return $ Left $ ErrorParse "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)