----------------------------------------------------------------------------- -- | -- Module : HAppS.Server.HTTPClient.HTTP -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005 -- License : BSD -- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (not tested) -- -- An easy HTTP interface enjoy. -- -- * Changes by Simon Foster: -- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules -- - Created functions receiveHTTP and responseHTTP to allow server side interactions -- (although 100-continue is unsupported and I haven't checked for standard compliancy). -- - Pulled the transfer functions from sendHTTP to global scope to allow access by -- above functions. -- -- * Changes by Graham Klyne: -- - export httpVersion -- - use new URI module (similar to old, but uses revised URI datatype) -- -- * Changes by Bjorn Bringert: -- -- - handle URIs with a port number -- - added debugging toggle -- - disabled 100-continue transfers to get HTTP\/1.0 compatibility -- - change 'ioError' to 'throw' -- - Added simpleHTTP_, which takes a stream argument. -- -- * Changes from 0.1 -- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class. -- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses. -- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic -- and the addition of a debugging stream. -- - simplified error handling. -- -- * TODO -- - request pipelining -- - https upgrade (includes full TLS, i.e. SSL, implementation) -- - use of Stream classes will pay off -- - consider C implementation of encryption\/decryption -- - comm timeouts -- - MIME & entity stuff (happening in separate module) -- - support \"*\" uri-request-string for OPTIONS request method -- -- -- * Header notes: -- -- [@Host@] -- Required by HTTP\/1.1, if not supplied as part -- of a request a default Host value is extracted -- from the request-uri. -- -- [@Connection@] -- If this header is present in any request or -- response, and it's value is "close", then -- the current request\/response is the last -- to be allowed on that connection. -- -- [@Expect@] -- Should a request contain a body, an Expect -- header will be added to the request. The added -- header has the value \"100-continue\". After -- a 417 \"Expectation Failed\" response the request -- is attempted again without this added Expect -- header. -- -- [@TransferEncoding,ContentLength,...@] -- if request is inconsistent with any of these -- header values then you may not receive any response -- or will generate an error response (probably 4xx). -- -- -- * Response code notes -- Some response codes induce special behaviour: -- -- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. -- \"101 Upgrade\" will be returned. -- Other 1xx responses are ignored. -- -- [@417@] The reason for this code is \"Expectation failed\", indicating -- that the server did not like the Expect \"100-continue\" header -- added to a request. Receipt of 417 will induce another -- request attempt (without Expect header), unless no Expect header -- had been added (in which case 417 response is returned). -- ----------------------------------------------------------------------------- module HAppS.Server.HTTPClient.HTTP ( module HAppS.Server.HTTPClient.Stream, module HAppS.Server.HTTPClient.TCP, -- ** Constants httpVersion, -- ** HTTP Request(..), Response(..), RequestMethod(..), simpleHTTP, simpleHTTP_, sendHTTP, sendHTTPPipelined, receiveHTTP, respondHTTP, -- ** Header Functions HasHeaders, Header(..), HeaderName(..), insertHeader, insertHeaderIfMissing, insertHeaders, retrieveHeaders, replaceHeader, findHeader, -- ** URL Encoding urlEncode, urlDecode, urlEncodeVars, -- ** URI authority parsing URIAuthority(..), parseURIAuthority ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- import Control.Exception as Exception -- Networking import Network.URI import HAppS.Server.HTTPClient.Stream import HAppS.Server.HTTPClient.TCP -- Util import Data.Bits ((.&.)) import Data.Char import Data.List (partition,elemIndex,intersperse) import Data.Maybe import Control.Monad (when,guard) import Numeric (readHex) import Text.ParserCombinators.ReadP import Text.Read.Lex import System.IO -- Turn on to enable HTTP traffic logging debug :: Bool debug = True -- False -- File that HTTP traffic logs go to httpLogFile :: String httpLogFile = "http-debug.log" ----------------------------------------------------------------- ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- -- remove leading and trailing whitespace. trim :: String -> String trim = let dropspace = dropWhile isSpace in reverse . dropspace . reverse . dropspace -- Split a list into two parts, the delimiter occurs -- at the head of the second list. Nothing is returned -- when no occurance of the delimiter is found. split :: Eq a => a -> [a] -> Maybe ([a],[a]) split delim list = case delim `elemIndex` list of Nothing -> Nothing Just x -> Just $ splitAt x list crlf = "\r\n" sp = " " ----------------------------------------------------------------- ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- data URIAuthority = URIAuthority { user :: Maybe String, password :: Maybe String, host :: String, port :: Maybe Int } deriving (Eq,Show) -- | Parse the authority part of a URL. -- -- > RFC 1732, section 3.1: -- > -- > //:@:/ -- > Some or all of the parts ":@", ":", -- > ":", and "/" may be excluded. 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 ----------------------------------------------------------------- ------------------ Header Data ---------------------------------- ----------------------------------------------------------------- -- | The Header data type pairs header names & values. data Header = Header HeaderName String instance Show Header where show (Header key value) = show key ++ ": " ++ value ++ crlf -- | HTTP Header Name type: -- Why include this at all? I have some reasons -- 1) prevent spelling errors of header names, -- 2) remind everyone of what headers are available, -- 3) might speed up searches for specific headers. -- -- Arguments against: -- 1) makes customising header names laborious -- 2) increases code volume. -- data HeaderName = -- Generic Headers -- HdrCacheControl | HdrConnection | HdrDate | HdrPragma | HdrTransferEncoding | HdrUpgrade | HdrVia -- Request Headers -- | HdrAccept | HdrAcceptCharset | HdrAcceptEncoding | HdrAcceptLanguage | HdrAuthorization | HdrCookie | HdrExpect | HdrFrom | HdrHost | HdrIfModifiedSince | HdrIfMatch | HdrIfNoneMatch | HdrIfRange | HdrIfUnmodifiedSince | HdrMaxForwards | HdrProxyAuthorization | HdrRange | HdrReferer | HdrUserAgent -- Response Headers | HdrAge | HdrLocation | HdrProxyAuthenticate | HdrPublic | HdrRetryAfter | HdrServer | HdrSetCookie | HdrVary | HdrWarning | HdrWWWAuthenticate -- Entity Headers | HdrAllow | HdrContentBase | HdrContentEncoding | HdrContentLanguage | HdrContentLength | HdrContentLocation | HdrContentMD5 | HdrContentRange | HdrContentType | HdrETag | HdrExpires | HdrLastModified -- Mime entity headers (for sub-parts) | HdrContentTransferEncoding -- | Allows for unrecognised or experimental headers. | HdrCustom String -- not in header map below. deriving(Eq) -- Translation between header names and values, -- good candidate for improvement. headerMap :: [ (String,HeaderName) ] headerMap = [ ("Cache-Control" ,HdrCacheControl ) , ("Connection" ,HdrConnection ) , ("Date" ,HdrDate ) , ("Pragma" ,HdrPragma ) , ("Transfer-Encoding" ,HdrTransferEncoding ) , ("Upgrade" ,HdrUpgrade ) , ("Via" ,HdrVia ) , ("Accept" ,HdrAccept ) , ("Accept-Charset" ,HdrAcceptCharset ) , ("Accept-Encoding" ,HdrAcceptEncoding ) , ("Accept-Language" ,HdrAcceptLanguage ) , ("Authorization" ,HdrAuthorization ) , ("From" ,HdrFrom ) , ("Host" ,HdrHost ) , ("If-Modified-Since" ,HdrIfModifiedSince ) , ("If-Match" ,HdrIfMatch ) , ("If-None-Match" ,HdrIfNoneMatch ) , ("If-Range" ,HdrIfRange ) , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince ) , ("Max-Forwards" ,HdrMaxForwards ) , ("Proxy-Authorization" ,HdrProxyAuthorization) , ("Range" ,HdrRange ) , ("Referer" ,HdrReferer ) , ("User-Agent" ,HdrUserAgent ) , ("Age" ,HdrAge ) , ("Location" ,HdrLocation ) , ("Proxy-Authenticate" ,HdrProxyAuthenticate ) , ("Public" ,HdrPublic ) , ("Retry-After" ,HdrRetryAfter ) , ("Server" ,HdrServer ) , ("Vary" ,HdrVary ) , ("Warning" ,HdrWarning ) , ("WWW-Authenticate" ,HdrWWWAuthenticate ) , ("Allow" ,HdrAllow ) , ("Content-Base" ,HdrContentBase ) , ("Content-Encoding" ,HdrContentEncoding ) , ("Content-Language" ,HdrContentLanguage ) , ("Content-Length" ,HdrContentLength ) , ("Content-Location" ,HdrContentLocation ) , ("Content-MD5" ,HdrContentMD5 ) , ("Content-Range" ,HdrContentRange ) , ("Content-Type" ,HdrContentType ) , ("ETag" ,HdrETag ) , ("Expires" ,HdrExpires ) , ("Last-Modified" ,HdrLastModified ) , ("Set-Cookie" ,HdrSetCookie ) , ("Cookie" ,HdrCookie ) , ("Expect" ,HdrExpect ) ] instance Show HeaderName where show (HdrCustom s) = s show x = case filter ((==x).snd) headerMap of [] -> error "headerMap incomplete" (h:_) -> fst h -- | This class allows us to write generic header manipulation functions -- for both 'Request' and 'Response' data types. class HasHeaders x where getHeaders :: x -> [Header] setHeaders :: x -> [Header] -> x -- Header manipulation functions insertHeader, replaceHeader, insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a -- | Inserts a header with the given name and value. -- Allows duplicate header names. insertHeader name value x = setHeaders x newHeaders where newHeaders = (Header name value) : getHeaders x -- | Adds the new header only if no previous header shares -- the same name. insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) where newHeaders list@(h@(Header n _): rest) | n == name = list | otherwise = h : newHeaders rest newHeaders [] = [Header name value] -- | Removes old headers with duplicate name. replaceHeader name value x = setHeaders x newHeaders where newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ] -- | Inserts multiple headers. insertHeaders :: HasHeaders a => [Header] -> a -> a insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) -- | Gets a list of headers with a particular 'HeaderName'. retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where matchname (Header n _) | n == name = True matchname _ = False -- | Lookup presence of specific HeaderName in a list of Headers -- Returns the value from the first matching header. findHeader :: HasHeaders a => HeaderName -> a -> Maybe String findHeader n x = lookupHeader n (getHeaders x) -- An anomally really: lookupHeader :: HeaderName -> [Header] -> Maybe String lookupHeader v (Header n s:t) | v == n = Just s | otherwise = lookupHeader v t lookupHeader _ _ = Nothing {- instance HasHeaders [Header] ...requires -fglasgow-exts, and is not really necessary anyway... -} ----------------------------------------------------------------- ------------------ HTTP Messages -------------------------------- ----------------------------------------------------------------- -- Protocol version httpVersion :: String httpVersion = "HTTP/1.1" -- | The HTTP request method, to be used in the 'Request' object. -- We are missing a few of the stranger methods, but these are -- not really necessary until we add full TLS. data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE | DELETE deriving(Show,Eq) rqMethodMap = [("HEAD", HEAD), ("PUT", PUT), ("GET", GET), ("POST", POST), ("OPTIONS", OPTIONS), ("TRACE", TRACE), ("DELETE", DELETE)] -- | An HTTP Request. -- The 'Show' instance of this type is used for message serialisation, -- which means no body data is output. data Request = Request { rqURI :: URI -- ^ might need changing in future -- 1) to support '*' uri in OPTIONS request -- 2) transparent support for both relative -- & absolute uris, although this should -- already work (leave scheme & host parts empty). , rqMethod :: RequestMethod , rqHeaders :: [Header] , rqBody :: String } -- Notice that request body is not included, -- this show function is used to serialise -- a request for the transport link, we send -- the body separately where possible. 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]) -- | An HTTP Response. -- The 'Show' instance of this type is used for message serialisation, -- which means no body data is output, additionally the output will -- show an HTTP version of 1.1 instead of the actual version returned -- by a server. data Response = Response { rspCode :: ResponseCode , rspReason :: String , rspHeaders :: [Header] , rspBody :: String } -- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 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 } ----------------------------------------------------------------- ------------------ Parsing -------------------------------------- ----------------------------------------------------------------- parseHeader :: String -> Result Header parseHeader str = case split ':' str of Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str) Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v) where fn k = case map snd $ filter (match k . fst) headerMap of [] -> (HdrCustom k) (h:_) -> h match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2 parseHeaders :: [String] -> Result [Header] parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old (h : t) | not (null h) && (head h == ' ' || head h == '\t') = joinExtended (old ++ ' ' : tail h) t | otherwise = old : joinExtended h t joinExtended old [] = [old] clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t | otherwise = h : clean t -- tollerant of errors? should parse -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a] catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t catRslts list [] = Right $ reverse list -- Parsing a request 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) -- Parsing a response 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 -- an assumption else Left (ErrorParse $ "Response status line parse failure: " ++ line) match [a,b,c] = (digitToInt a, digitToInt b, digitToInt c) match _ = (-1,-1,-1) -- will create appropriate behaviour ----------------------------------------------------------------- ------------------ HTTP Send / Recv ---------------------------------- ----------------------------------------------------------------- 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 -- upgrade to TLS (1,_,_) -> Continue -- default (2,0,4) -> Done (2,0,5) -> Done (2,_,_) -> ans (3,0,4) -> Done (3,0,5) -> Done (3,_,_) -> ans (4,1,7) -> Retry -- Expectation failed (4,_,_) -> ans (5,_,_) -> ans (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") where ans | rqst == HEAD = Done | otherwise = ExpectEntity -- | Simple way to get a resource across a non-persistant connection. -- Headers that may be altered: -- Host Altered only if no Host header is supplied, HTTP\/1.1 -- requires a Host header. -- Connection Where no allowance is made for persistant connections -- the Connection header will be set to "close" simpleHTTP :: Request -> IO (Result Response) simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. 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' -- already done by sendHTTP because of "Connection: close" header --; close s return rsp where {- RFC 2616, section 5.1.2: "The most common form of Request-URI is that used to identify a resource on an origin server or gateway. In this case the absolute path of the URI MUST be transmitted (see section 3.2.1, abs_path) as the Request-URI, and the network location of the URI (authority) MUST be transmitted in a Host header field." -} -- we assume that this is the case, so we take the host name from -- the Host header if there is one, otherwise from the request-URI. -- Then we make the request-URI an abs_path and make sure that there -- is a Host header. fixReq :: URIAuthority -> Request -> Request fixReq URIAuthority{host=h} r = insertHeaderIfMissing 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 -> authority (rqURI r) sendHTTP :: Stream s => s -> Request -> IO (Result Response) sendHTTP conn rq = do rst <- sendHTTPPipelined conn [rq] case rst of ([response],_) -> return (Right response) (_,Just err) -> return (Left err) sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError) sendHTTPPipelined conn rqs = do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs)) (\e -> do { close conn; throw e }) ; let fn list = when (or $ map findConnClose list) (close conn) ; fn (map rqHeaders rqs ++ map rspHeaders ok) ; return (ok,rsp) } where -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows -- ambiguous situations in which a client may send "Expect: 100- -- continue" without receiving either a 417 (Expectation Failed) status -- or a 100 (Continue) status. Therefore, when a client sends this -- header field to an origin server (possibly via a proxy) from which it -- has never seen a 100 (Continue) status, the client SHOULD NOT wait -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now. main :: [Request] -> IO ([Response], Maybe ConnError) main rqsts = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn $ concat $ intersperse "\r\n" [ show rqst ++ rqBody rqst | rqst <- rqsts ] rets <- flip mapM rqsts $ \rqst -> do rsp <- getResponseHead switchResponse True True rsp rqst return (sequenceResponses rets) sequenceResponses :: [Result Response] -> ([Response], Maybe ConnError) sequenceResponses = worker [] where worker acc [] = (reverse acc, Nothing) worker acc (Right x:xs) = worker (x:acc) xs worker acc (Left x:xs) = (reverse acc,Just x) -- reads and parses headers getResponseHead :: IO (Result ResponseData) getResponseHead = do { lor <- readTillEmpty1 conn ; return $ lor `bindE` parseResponseHead } -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according -- to the RFC. switchResponse :: Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request -> IO (Result Response) switchResponse _ _ (Left e) _ = return (Left e) -- retry on connreset? -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> {- Time to send the body -} 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 -> {- keep waiting -} do { rsp <- getResponseHead ; switchResponse allow_retry bdy_sent rsp rqst } Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -} 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 -> linearTransfer conn (read x :: Int) 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) } -- Adds a Host header if one is NOT ALREADY PRESENT fixHostHeader :: Request -> Request fixHostHeader rq = let uri = rqURI rq host = authority uri in insertHeaderIfMissing HdrHost host rq -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool findConnClose hdrs = case lookupHeader HdrConnection hdrs of Nothing -> False Just x -> map toLower (trim x) == "close" -- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: Stream s => s -> IO (Result Request) receiveHTTP conn = do rq <- getRequestHead processRequest rq where -- reads and parses headers getRequestHead :: IO (Result RequestData) getRequestHead = do { lor <- readTillEmpty1 conn ; return $ lor `bindE` parseRequestHead } processRequest (Left e) = return $ Left e processRequest (Right (rm,uri,hdrs)) = do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer conn (read x :: Int) Nothing -> return (Right ([], "")) -- hopefulTransfer "" 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) -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response -> IO () respondHTTP conn rsp = do writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rspBody rsp) return () -- The following functions were in the where clause of sendHTTP, they have -- been moved to global scope so other functions can access them. -- | Used when we know exactly how many bytes to expect. linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String)) linearTransfer conn n = do info <- readBlock conn n return $ info `bindE` \str -> Right ([],str) -- | Used when nothing about data is known, -- Unfortunately waiting for a socket closure -- causes bad behaviour. Here we just -- take data once and give up the rest. 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)) -- | A necessary feature of HTTP\/1.1 -- Also the only transfer variety likely to -- return any footers. 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 || (head line) == '0' 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) } -- | Maybe in the future we will have a sensible thing -- to do here, at that time we might want to change -- the name. uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String)) uglyDeathTransfer conn = return $ Left $ ErrorParse "Unknown Transfer-Encoding" -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) 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] } -- | Read lines until an empty line (CRLF), -- also accepts a connection close as end of -- input, which is not an HTTP\/1.1 compliant -- thing to do - so probably indicates an -- error condition. 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) } ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- ----------------------------------------------------------------- {- I had a quick look around but couldn't find any RFC about the encoding of data on the query string. I did find an IETF memo, however, so this is how I justify the urlEncode and urlDecode methods. Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" URI delims: "<" | ">" | "#" | "%" | <"> Unallowed ASCII: Also unallowed: any non-us-ascii character Escape method: char -> '%' a b where a, b :: Hex digits -} urlEncode, urlDecode :: String -> String urlDecode ('%':a:b:rest) = chr (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 [';','/','?',':','@','&' ,'=','+',',','$','{','}' ,'|','\\','^','[',']','`' ,'<','>','#','%','"'] -- wouldn't it be nice if the compiler -- optimised the above for us? escape x = let y = ord x in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ] urlEncode [] = [] -- Encode form variables, useable in either the -- query part of a URI, or the body of a POST request. -- I have no source for this information except experience, -- this sort of encoding worked fine in CGI programming. 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 [] = []