diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.0.2 +Version: 7.0.3 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 @@ -7,7 +7,7 @@ Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com -Category: Web, Distributed Computing +Category: Web, Happstack Build-Type: Simple Cabal-Version: >= 1.6 @@ -69,9 +69,6 @@ Exposed-modules: Happstack.Server.Tests Other-modules: - Happstack.Server.HTTPClient.HTTP - Happstack.Server.HTTPClient.Stream - Happstack.Server.HTTPClient.TCP Happstack.Server.Internal.Clock Happstack.Server.Internal.LazyLiner Happstack.Server.Internal.LogFormat diff --git a/src/Happstack/Server/HTTPClient/HTTP.hs b/src/Happstack/Server/HTTPClient/HTTP.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/HTTP.hs +++ /dev/null @@ -1,1018 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Happstack.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 Happstack.Server.HTTPClient.HTTP ( - module Happstack.Server.HTTPClient.Stream, - module Happstack.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, - -) where - - - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Control.Exception.Extensible as Exception - --- Networking -import Network.URI -import Happstack.Server.HTTPClient.Stream -import Happstack.Server.HTTPClient.TCP -import Happstack.Server.Internal.Types (readDec') - - --- Util -import Data.Bits ((.&.)) -import Data.Char -import Data.List (foldl', elemIndex, intersperse, partition) -import Control.Monad (when,forM) -import Numeric (readHex) -import Text.ParserCombinators.ReadP - - - --- 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 :: String -crlf = "\r\n" -sp :: String -sp = " " - ------------------------------------------------------------------ ------------------- 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 : [ h | h@(Header n _) <- 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 = lookupHeader n . getHeaders - --- An anomally really: -lookupHeader :: HeaderName -> [Header] -> Maybe String -lookupHeader v (Header n s:t) | v == n = Just s - | otherwise = lookupHeader v t -lookupHeader _ _ = Nothing - - - ------------------------------------------------------------------ ------------------- 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 :: [(String, RequestMethod)] -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 - ++ concatMap 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 - ++ concatMap 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 (uriRegName auth) (port auth) - simpleHTTP_ c r - where - port auth = if null (uriPort auth) - then 80 - else readDec' $ uriPort auth - - --- | 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 :: URIAuth -> Request -> Request - fixReq URIAuth{uriRegName=h} req = - insertHeaderIfMissing HdrConnection "close" $ - insertHeaderIfMissing HdrHost h $ - req { rqURI = (rqURI req){ uriScheme = "", - uriAuthority = Nothing } } - --- | this is not the most graceful of implementations. --- The problem is that Network.URI.authority is --- deprecated. And we want to use Network.URI.URIAuth. --- --- So this method use to parse a "host" field as a URI --- auth, which is not stictly correct. We still --- fake that behavior here. -getAuth :: Monad m => Request -> m URIAuth -getAuth r = case auth of - Just x -> return x - Nothing -> fail $ "Error parsing URI authority '" - ++ show (rqURI r) ++ "'" - where - auth = case findHeader HdrHost r of - Just h -> Just $ fakeAuth h - Nothing -> uriAuthority (rqURI r) - fakeAuth h = fst . head $ (flip readP_to_S) h $ do - host<-many1 $ satisfy (\c -> c /= ':') - port<-option "" $ char ':' >> many1 get - return URIAuth{uriRegName=host, uriPort=port, uriUserInfo=""} - - -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) - (_,_) -> error "Case not supported in sendHTTP" - -sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError) -sendHTTPPipelined conn rqs = - do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs)) - (\(e::SomeException) -> do { close conn; throw e }) - ; let fn list = when (any 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 <- forM 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:_) = (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 (readDec' 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 - h = fmap uriRegName $ uriAuthority uri - in case h of - Just x -> insertHeaderIfMissing HdrHost x rq - _ -> 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 (readDec' 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,c,info) -> - let myftrs = Header HdrContentLength (show c) : 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 _ - = 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 [] = [] diff --git a/src/Happstack/Server/HTTPClient/Stream.hs b/src/Happstack/Server/HTTPClient/Stream.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/Stream.hs +++ /dev/null @@ -1,173 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTPClient.Stream --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 --- License : BSD --- --- Maintainer : bjorn@bringert.net --- Stability : experimental --- Portability : non-portable (not tested) --- --- An library for creating abstract streams. Originally part of Gray's\/Bringert's --- HTTP module. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTPClient.Stream ( - -- ** Streams - Debug, - Stream(..), - debugStream, - - -- ** Errors - ConnError(..), - Result, - handleSocketError, - bindE, - myrecv - -) where - -import Control.Monad (liftM) -import Control.Exception.Extensible as Exception -import Network.Socket (ShutdownCmd(..), Socket, SocketOption(SoError), getSocketOption, recv, send, sClose, shutdown) -import Prelude hiding (catch) -import System.IO (Handle, IOMode(..), hClose, hFlush, hPutStrLn, openFile) -import System.IO.Error (isEOFError) - -data ConnError = ErrorReset - | ErrorClosed - | ErrorParse String - | ErrorMisc String - deriving(Show,Eq) - --- error propagating: --- we could've used a monad, but that would lead us --- into using the "-fglasgow-exts" compile flag. -bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b -bindE (Left e) _ = Left e -bindE (Right v) f = f v - --- | This is the type returned by many exported network functions. -type Result a = Either ConnError {- error -} - a {- result -} - ------------------------------------------------------------------ ------------------- Gentle Art of Socket Sucking ----------------- ------------------------------------------------------------------ - --- | Streams should make layering of TLS protocol easier in future, --- they allow reading/writing to files etc for debugging, --- they allow use of protocols other than TCP/IP --- and they allow customisation. --- --- Instances of this class should not trim --- the input in any way, e.g. leave LF on line --- endings etc. Unless that is exactly the behaviour --- you want from your twisted instances ;) -class Stream x where - readLine :: x -> IO (Result String) - readBlock :: x -> Int -> IO (Result String) - writeBlock :: x -> String -> IO (Result ()) - close :: x -> IO () - - - - - --- Exception handler for socket operations -handleSocketError :: Socket -> Exception.SomeException -> IO (Result a) -handleSocketError sk e = - do { se <- getSocketOption sk SoError - ; if se == 0 - then throw e - else return $ if se == 10054 -- reset - then Left ErrorReset - else Left $ ErrorMisc $ show se - } - - - - -instance Stream Socket where - readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk) - where - fn x = do { str <- myrecv sk x - ; let len = length str - ; if len < x && len /= 0 - then ( fn (x-len) >>= \more -> return (str++more) ) - else return str - } - - -- Use of the following function is discouraged. - -- The function reads in one character at a time, - -- which causes many calls to the kernel recv() - -- hence causes many context switches. - readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk) - where - fn str = - do { c <- myrecv sk 1 -- like eating through a straw. - ; if null c || c == "\n" - then return (reverse str++c) - else fn (head c:str) - } - - writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk) - where - fn [] = return () - fn x = send sk x >>= \i -> fn (drop i x) - - -- This slams closed the connection (which is considered rude for TCP\/IP) - close sk = shutdown sk ShutdownBoth >> sClose sk - -myrecv :: Socket -> Int -> IO String -myrecv sock len = - recv sock len `catch` - (\e -> - if isEOFError e - then return [] - else ioError e) - --- | Allows stream logging. --- Refer to 'debugStream' below. -data Debug x = Dbg Handle x - -instance (Stream x) => Stream (Debug x) where - readBlock (Dbg h c) n = - do { val <- readBlock c n - ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val) - ; hFlush h - ; return val - } - - readLine (Dbg h c) = - do { val <- readLine c - ; hPutStrLn h ("readLine " ++ show val) - ; return val - } - - writeBlock (Dbg h c) str = - do { val <- writeBlock c str - ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str) - ; return val - } - - close (Dbg h c) = - do { hPutStrLn h "closing..." - ; hFlush h - ; close c - ; hPutStrLn h "...closed" - ; hClose h - } - - --- | Wraps a stream with logging I\/O, the first --- argument is a filename which is opened in AppendMode. -debugStream :: (Stream a) => String -> a -> IO (Debug a) -debugStream file stm = - do { h <- openFile file AppendMode - ; hPutStrLn h "File opened for appending." - ; return (Dbg h stm) - } diff --git a/src/Happstack/Server/HTTPClient/TCP.hs b/src/Happstack/Server/HTTPClient/TCP.hs deleted file mode 100644 --- a/src/Happstack/Server/HTTPClient/TCP.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Happstack.Server.HTTPClient.TCP --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 --- License : BSD --- --- Maintainer : bjorn@bringert.net --- Stability : experimental --- Portability : non-portable (not tested) --- --- An easy access TCP library. Makes the use of TCP in Haskell much easier. --- This was originally part of Gray's\/Bringert's HTTP module. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- ------------------------------------------------------------------------------ -module Happstack.Server.HTTPClient.TCP ( - -- ** Connections - Conn(..), - Connection(..), - openTCP, - openTCPPort, - isConnectedTo -) where - -import Control.Exception.Extensible as Exception - --- Networking -import Network.BSD -import Network.Socket -import Happstack.Server.HTTPClient.Stream - -import Data.List (elemIndex) -import Data.Char -import Data.IORef - ------------------------------------------------------------------ ------------------- TCP Connections ------------------------------ ------------------------------------------------------------------ - --- | The 'Connection' newtype is a wrapper that allows us to make --- connections an instance of the StreamIn\/Out classes, without ghc extensions. --- While this looks sort of like a generic reference to the transport --- layer it is actually TCP specific, which can be seen in the --- implementation of the 'Stream Connection' instance. -newtype Connection = ConnRef {getRef :: IORef Conn} - - --- | The 'Conn' object allows input buffering, and maintenance of --- some admin-type data. -data Conn = MkConn { connSock :: ! Socket - , connAddr :: ! SockAddr - , connBffr :: ! String - , connHost :: String - } - | ConnClosed - deriving(Eq) - - --- | Open a connection to port 80 on a remote host. -openTCP :: String -> IO Connection -openTCP host = openTCPPort host 80 - - --- | This function establishes a connection to a remote --- host, it uses "getHostByName" which interrogates the --- DNS system, hence may trigger a network connection. --- --- Add a "persistant" option? Current persistant is default. --- Use "Result" type for synchronous exception reporting? -openTCPPort :: String -> Int -> IO Connection -openTCPPort uri port = - do { s <- socket AF_INET Stream 6 - ; setSocketOption s KeepAlive 1 - ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers - (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME - case hostAddresses host of - [] -> return (error "no addresses in host entry") - (h:_) -> return h) - ; let a = SockAddrInet (toEnum port) host - ; Exception.catch (connect s a) (\(e::SomeException) -> sClose s >> throw e) - ; v <- newIORef (MkConn s a [] uri) - ; return (ConnRef v) - } - -instance Stream Connection where - readBlock ref n = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk _addr bfr _hst) - | length bfr >= n -> - do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) }) - ; return (Right $ take n bfr) - } - | otherwise -> - do { modifyIORef (getRef ref) (\c -> c { connBffr=[] }) - ; more <- readBlock sk (n - length bfr) - ; return $ case more of - Left _ -> more - Right s -> (Right $ bfr ++ s) - } - - -- This function uses a buffer, at this time the buffer is just 1000 characters. - -- (however many bytes this is is left to the user to decypher) - readLine ref = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk _addr bfr _) - | null bfr -> {- read in buffer -} - do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !! - -- ... since that call will loop. - ; let len = length str - ; if len == 0 {- indicates a closed connection -} - then return (Right "") - else modifyIORef (getRef ref) (\c -> c { connBffr=str }) - >> readLine ref -- recursion - } - | otherwise -> - case elemIndex '\n' bfr of - Nothing -> {- need recursion to finish line -} - do { modifyIORef (getRef ref) (\c -> c { connBffr=[] }) - ; more <- readLine ref -- contains extra recursion - ; return $ more `bindE` \str -> Right (bfr++str) - } - Just i -> {- end of line found -} - let (bgn,end) = splitAt i bfr in - do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) }) - ; return (Right (bgn++['\n'])) - } - - - - -- The 'Connection' object allows no outward buffering, - -- since in general messages are serialised in their entirety. - writeBlock ref str = - readIORef (getRef ref) >>= \conn -> case conn of - ConnClosed -> return (Left ErrorClosed) - (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk) - where - fn sk addr s - | null s = return (Right ()) -- done - | otherwise = - getSocketOption sk SoError >>= \se -> - if se == 0 - then sendTo sk s addr >>= \i -> fn sk addr (drop i s) - else writeIORef (getRef ref) ConnClosed >> - if se == 10054 - then return (Left ErrorReset) - else return (Left $ ErrorMisc $ show se) - - - -- Closes a Connection. Connection will no longer - -- allow any of the other Stream functions. Notice that a Connection may close - -- at any time before a call to this function. This function is idempotent. - -- (I think the behaviour here is TCP specific) - close ref = - do { c <- readIORef (getRef ref) - ; closeConn c `Exception.catch` (\(_::SomeException) -> return ()) -- FIXME see above - ; writeIORef (getRef ref) ConnClosed - } - where - -- Be kind to peer & close gracefully. - closeConn (ConnClosed) = return () - closeConn (MkConn sk _addr [] _) = - do { shutdown sk ShutdownSend - ; suck ref - ; shutdown sk ShutdownReceive - ; sClose sk - } - closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported" - - suck :: Connection -> IO () - suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore - (\x -> if null x then return () else suck cn) - --- | Checks both that the underlying Socket is connected --- and that the connection peer matches the given --- host name (which is recorded locally). -isConnectedTo :: Connection -> String -> IO Bool -isConnectedTo conn name = - do { v <- readIORef (getRef conn) - ; case v of - ConnClosed -> return False - (MkConn sk _ _ h) -> - if (map toLower h == map toLower name) - then sIsConnected sk - else return False - } - diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -488,6 +488,12 @@ -- -- (3) The content-type supplied by the browser -- +-- If the user does not supply a file in the html form input field, +-- the behaviour will depend upon the browser. Most browsers will send +-- a 0-length file with an empty file name, so checking that (2) is +-- not empty is usually sufficient to ensure the field has been +-- filled. +-- -- NOTE: You must move the file from the temporary location before the -- 'Response' is sent. The temporary files are automatically removed -- after the 'Response' is sent.