module Network.HTTP (
module Network.Stream,
module Network.TCP,
httpVersion,
Request(..),
RequestData,
Response(..),
RequestMethod(..),
ResponseCode,
simpleHTTP, simpleHTTP_,
sendHTTP,
receiveHTTP,
processRequest,
getRequestHead,
respondHTTP,
module Network.HTTP.Headers,
urlEncode,
urlDecode,
urlEncodeVars,
URIAuthority(..),
getAuth,
parseURIAuthority
) where
import Network.URI
( URI(URI, uriScheme, uriAuthority, uriPath)
, URIAuth(uriUserInfo, uriRegName, uriPort)
, parseURIReference
, unEscapeString, escapeURIString, isUnescapedInURI
)
import Network.HTTP.Headers
import Network.Stream
import Network.StreamDebugger (debugStream)
import Network.TCP (openTCPPort)
import Control.Exception as Exception (catch, throw)
import Data.Bits ((.&.))
import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)
import Data.List (partition, intersperse)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad (when, guard)
import Numeric (readHex)
import Text.Read.Lex (readDecP)
import Text.ParserCombinators.ReadP
( ReadP, readP_to_S, char, (<++), look, munch )
import Data.Typeable
debug :: Bool
debug = False
httpLogFile :: String
httpLogFile = "http-debug.log"
trim :: String -> String
trim = let dropspace = dropWhile isSpace in
reverse . dropspace . reverse . dropspace
crlf, sp :: String
crlf = "\r\n"
sp = " "
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
httpVersion :: String
httpVersion = "HTTP/1.1"
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | Custom String
deriving(Show,Eq)
rqMethodMap :: [(String, RequestMethod)]
rqMethodMap = [("HEAD", HEAD),
("PUT", PUT),
("GET", GET),
("POST", POST),
("DELETE", DELETE),
("OPTIONS", OPTIONS),
("TRACE", TRACE)]
data Request =
Request { rqURI :: URI
, rqMethod :: RequestMethod
, rqHeaders :: [Header]
, rqBody :: String
} deriving (Typeable)
instance Show Request 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 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 =
Response { rspCode :: ResponseCode
, rspReason :: String
, rspHeaders :: [Header]
, rspBody :: String
} deriving (Typeable)
instance Show Response where
show (Response (a,b,c) reason headers _) =
httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
++ foldr (++) [] (map show headers) ++ crlf
instance HasHeaders Response 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 (ErrorParse $ "Request command line parse failure: " ++ line)
no -> if null line
then Left ErrorClosed
else Left (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 -> if null line
then Left ErrorClosed
else Left (ErrorParse $ "Response status line parse failure: " ++ line)
match [a,b,c] = (digitToInt a,
digitToInt b,
digitToInt c)
match _ = (1,1,1)
data Behaviour = Continue
| Retry
| Done
| ExpectEntity
| DieHorribly String
matchResponse :: RequestMethod -> ResponseCode -> Behaviour
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
simpleHTTP :: Request -> IO (Result Response)
simpleHTTP r =
do
auth <- getAuth r
c <- openTCPPort (host auth) (fromMaybe 80 (port auth))
simpleHTTP_ c r
simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)
simpleHTTP_ s r =
do
auth <- getAuth r
let r' = fixReq auth r
rsp <- if debug then do
s' <- debugStream httpLogFile s
sendHTTP s' r'
else
sendHTTP s r'
return rsp
where
fixReq :: URIAuthority -> Request -> Request
fixReq URIAuthority{host=h,port=p} r =
let h' = h ++ maybe "" ((':':) . show) p in
replaceHeader HdrConnection "close" $
insertHeaderIfMissing HdrHost h' $
r { rqURI = (rqURI r){ uriScheme = "",
uriAuthority = Nothing } }
getAuth :: Monad m => Request -> m URIAuthority
getAuth r = case parseURIAuthority auth of
Just x -> return x
Nothing -> fail $ "Error parsing URI authority '"
++ auth ++ "'"
where auth = case findHeader HdrHost r of
Just h -> h
Nothing -> uriToAuthorityString (rqURI r)
sendHTTP :: Stream s => s -> Request -> IO (Result Response)
sendHTTP conn rq =
do { let a_rq = fixHostHeader rq
; rsp <- Exception.catch (main a_rq)
(\e -> do { close conn; throw e })
; let fn list = when (or $ map findConnClose list)
(close conn)
; either (\_ -> fn [rqHeaders rq])
(\r -> fn [rqHeaders rq,rspHeaders r])
rsp
; return rsp
}
where
main :: Request -> IO (Result Response)
main rqst =
do
writeBlock conn (show rqst)
writeBlock conn (rqBody rqst)
rsp <- getResponseHead
switchResponse True False rsp rqst
getResponseHead :: IO (Result ResponseData)
getResponseHead =
do { lor <- readTillEmpty1 conn
; return $ lor `bindE` parseResponseHead
}
switchResponse :: Bool
-> Bool
-> Result ResponseData
-> Request
-> IO (Result Response)
switchResponse _ _ (Left e) _ = return (Left e)
switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =
case matchResponse (rqMethod rqst) cd of
Continue
| not bdy_sent ->
do { val <- writeBlock conn (rqBody rqst)
; case val of
Left e -> return (Left e)
Right _ ->
do { rsp <- getResponseHead
; switchResponse allow_retry True rsp rqst
}
}
| otherwise ->
do { rsp <- getResponseHead
; switchResponse allow_retry bdy_sent rsp rqst
}
Retry ->
do { writeBlock conn (show rqst ++ rqBody rqst)
; rsp <- getResponseHead
; switchResponse False bdy_sent rsp rqst
}
Done ->
return (Right $ Response cd rn hdrs "")
DieHorribly str ->
return $ Left $ ErrorParse ("Invalid response: " ++ str)
ExpectEntity ->
let tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
in
do { rslt <- case tc of
Nothing ->
case cl of
Just x -> linearTransferStrLen conn x
Nothing -> hopefulTransfer conn ""
Just x ->
case map toLower (trim x) of
"chunked" -> chunkedTransfer conn
_ -> uglyDeathTransfer conn
; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)
}
fixHostHeader :: Request -> Request
fixHostHeader rq =
let uri = rqURI rq
host = uriToAuthorityString uri
in insertHeaderIfMissing HdrHost host rq
findConnClose :: [Header] -> Bool
findConnClose hdrs =
case lookupHeader HdrConnection hdrs of
Nothing -> False
Just x -> map toLower (trim x) == "close"
uriToAuthorityString :: URI -> String
uriToAuthorityString URI{uriAuthority=Nothing} = ""
uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++
uriRegName ua ++
uriPort ua
receiveHTTP :: Stream s => s -> IO (Result Request)
receiveHTTP conn = do rq <- getRequestHead conn
case rq of
Left e -> return (Left e)
Right r -> processRequest conn r
getRequestHead :: Stream s => s -> IO (Result RequestData)
getRequestHead conn =
do { lor <- readTillEmpty1 conn
; return $ lor `bindE` parseRequestHead
}
processRequest :: Stream s => s -> RequestData -> IO (Result Request)
processRequest conn (rm,uri,hdrs) =
do
let tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
rslt <- case tc of
Nothing ->
case cl of
Just x -> linearTransferStrLen conn x
Nothing -> return (Right ([], ""))
Just x ->
case map toLower (trim x) of
"chunked" -> chunkedTransfer conn
_ -> uglyDeathTransfer conn
return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)
respondHTTP :: Stream s => s -> Response -> IO ()
respondHTTP conn rsp = do writeBlock conn (show rsp)
writeBlock conn (rspBody rsp)
return ()
linearTransferStrLen :: Stream s => s -> String -> IO (Result ([Header],String))
linearTransferStrLen conn ns =
case reads ns of
[(n,"")] -> linearTransfer conn n
_ -> return $ Left $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns
linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))
linearTransfer conn n
= do info <- readBlock conn n
return $ info `bindE` \str -> Right ([],str)
hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))
hopefulTransfer conn str
= readLine conn >>=
either (\v -> return $ Left v)
(\more -> if null more
then return (Right ([],str))
else hopefulTransfer conn (str++more))
chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))
chunkedTransfer conn
= chunkedTransferC conn 0 >>= \v ->
return $ v `bindE` \(ftrs,count,info) ->
let myftrs = Header HdrContentLength (show count) : ftrs
in Right (myftrs,info)
chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))
chunkedTransferC conn n
= readLine conn >>= \v -> case v of
Left e -> return (Left e)
Right line ->
let size = ( if null line
then 0
else case readHex line of
(n,_):_ -> n
_ -> 0
)
in if size == 0
then do { rs <- readTillEmpty2 conn []
; return $
rs `bindE` \strs ->
parseHeaders strs `bindE` \ftrs ->
Right (ftrs,n,"")
}
else do { some <- readBlock conn size
; readLine conn
; more <- chunkedTransferC conn (n+size)
; return $
some `bindE` \cdata ->
more `bindE` \(ftrs,m,mdata) ->
Right (ftrs,m,cdata++mdata)
}
uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))
uglyDeathTransfer conn
= return $ Left $ ErrorParse "Unknown Transfer-Encoding"
readTillEmpty1 :: Stream s => s -> IO (Result [String])
readTillEmpty1 conn =
do { line <- readLine conn
; case line of
Left e -> return $ Left e
Right s ->
if s == crlf
then readTillEmpty1 conn
else readTillEmpty2 conn [s]
}
readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])
readTillEmpty2 conn list =
do { line <- readLine conn
; case line of
Left e -> return $ Left e
Right s ->
if s == crlf || null s
then return (Right $ reverse (s:list))
else readTillEmpty2 conn (s:list)
}
urlEncodeVars :: [(String,String)] -> String
urlEncodeVars xs =
concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]
urlEncode :: String -> String
urlEncode = replace ' ' '+' . escapeURIString okChar
where okChar c = c == ' ' ||
(isUnescapedInURI c && c `notElem` "&=+")
urlDecode :: String -> String
urlDecode = unEscapeString . replace '+' ' '
replace :: Eq a =>
a
-> a
-> [a]
-> [a]
replace x y = map (\z -> if z == x then y else z)