happstack-server 7.0.2 → 7.0.3
raw patch · 5 files changed
+8/−1388 lines, 5 files
Files
- happstack-server.cabal +2/−5
- src/Happstack/Server/HTTPClient/HTTP.hs +0/−1018
- src/Happstack/Server/HTTPClient/Stream.hs +0/−173
- src/Happstack/Server/HTTPClient/TCP.hs +0/−192
- src/Happstack/Server/RqData.hs +6/−0
happstack-server.cabal view
@@ -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 <http://happstack.com/docs/crashcourse/index.html> License: BSD3@@ -7,7 +7,7 @@ Author: Happstack team, HAppS LLC Maintainer: Happstack team <happs@googlegroups.com> 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
− src/Happstack/Server/HTTPClient/HTTP.hs
@@ -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: <US-ASCII coded characters 00-1F and 7F hexadecimal>- <US-ASCII coded character 20 hexadecimal>- 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 [] = []
− src/Happstack/Server/HTTPClient/Stream.hs
@@ -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)- }
− src/Happstack/Server/HTTPClient/TCP.hs
@@ -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- }-
src/Happstack/Server/RqData.hs view
@@ -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.