diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.0.3 +Version: 4000.0.4 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 @@ -15,7 +15,7 @@ Copyright 2008-2009 Sigbjorn Finne Author: Warrick Gray Maintainer: Sigbjorn Finne -Homepage: http://www.haskell.org/http/ +Homepage: http://projects.haskell.org/http/ Category: Network Synopsis: A library for client-side HTTP Description: @@ -28,7 +28,7 @@ Inspired in part by Jonas Aadahl et al's work on ByteString'ifying HTTP a couple of years ago. . - Git repository available at + Git repository available at Flag old-base description: Old, monolithic base @@ -60,4 +60,4 @@ else Build-depends: base >= 3 - Build-depends: array + Build-depends: array, old-time diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Warrick Gray 2002 -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -60,8 +60,14 @@ setCookies, addCookie, - setErrHandler, - setOutHandler, + setErrHandler, -- :: (String -> IO ()) -> BrowserAction t () + setOutHandler, -- :: (String -> IO ()) -> BrowserAction t () + + setEventHandler, -- :: (BrowserEvent t -> BrowserAction t ()) -> BrowserAction t () + + BrowserEvent(..), + BrowserEventType(..), + RequestID, setProxy, @@ -104,6 +110,8 @@ ( hSetBuffering, hPutStr, stdout, stdin, hGetChar , BufferMode(NoBuffering, LineBuffering) ) +import System.Time ( ClockTime, getClockTime ) + import Data.Word (Word8) type Octet = Word8 @@ -114,7 +122,7 @@ word, quotedstring :: Parser String quotedstring = - do { char '"' + do { char '"' -- " ; str <- many (satisfy $ not . (=='"')) ; char '"' ; return str @@ -606,6 +614,8 @@ , bsConnectionPool :: [connection] , bsProxy :: Proxy , bsDebug :: Maybe String + , bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ()) + , bsRequestID :: RequestID } instance Show (BrowserState t) where @@ -647,6 +657,8 @@ , bsConnectionPool = [] , bsProxy = NoProxy , bsDebug = Nothing + , bsEvent = Nothing + , bsRequestID = 0 } -- | Alter browser state @@ -662,6 +674,16 @@ withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a withBrowserState bs act = BA $ \ _ -> lift act bs +newRequest :: BrowserAction t a -> BrowserAction t a +newRequest act = do + let updReqID st = + let + rid = 1 + bsRequestID st + in + rid `seq` st{bsRequestID=rid} + alterBS updReqID + act + -- | Do an io action ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v)) @@ -705,6 +727,8 @@ , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response } +type RequestID = Int -- yeah, it will wrap around. + nullRequestState :: RequestState nullRequestState = RequestState { reqDenies = 0 @@ -713,6 +737,53 @@ , reqStopOnDeny = True } +-- | 'BrowserEvent' is the event record type that a user-defined handler, set +-- via 'setEventHandler', will be passed. It indicates various state changes +-- in the processing of a given Request ID. +data BrowserEvent ty + = BrowserEvent + { browserTimestamp :: ClockTime + , browserRequestID :: RequestID + , browserRequestURI :: {-URI-}String + , browserEventType :: BrowserEventType ty + } + +-- | 'BrowserEventType' is the enumerated list of events that the browser +-- internals will report to a user-defined event handler. +data BrowserEventType ty + = OpenConnection + | ReuseConnection + | RequestSent +{- not yet, you will have to determine these via the ResponseEnd event. + | Redirect + | AuthChallenge + | AuthResponse +-} + | ResponseEnd ResponseData + | ResponseFinish + +setEventHandler :: (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty () +setEventHandler h = alterBS (\b -> b { bsEvent=Just h}) + +buildBrowserEvent :: BrowserEventType t -> {-URI-}String -> RequestID -> IO (BrowserEvent t) +buildBrowserEvent bt uri reqID = do + ct <- getClockTime + return BrowserEvent + { browserTimestamp = ct + , browserRequestID = reqID + , browserRequestURI = uri + , browserEventType = bt + } + +reportEvent :: BrowserEventType t -> {-URI-}String -> BrowserAction t () +reportEvent bt uri = do + st <- getBrowserState + case bsEvent st of + Nothing -> return () + Just evH -> do + evt <- ioAction $ buildBrowserEvent bt uri (bsRequestID st) + evH evt -- if it fails, we fail. + -- limits we are willing to not go beyond for method retries and number of auth deny responses. maxRetries :: Int maxRetries = 4 @@ -724,7 +795,10 @@ request :: HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI,Response ty) -request req = request' nullVal initialState req +request req = newRequest $ do + res <- request' nullVal initialState req + reportEvent ResponseFinish (show (rqURI req)) + return res where initialState = nullRequestState nullVal = buf_empty bufferOps @@ -940,6 +1014,7 @@ (':':s) -> case reads s of { ((v,_):_) -> v ; _ -> 80} _ -> 80 + ; reportEvent OpenConnection (show (rqURI rqst)) ; c <- ioAction $ openStream (uriRegName hst) aport ; let len_pool = length pool ; when (len_pool > 5) @@ -952,21 +1027,32 @@ } (c:_) -> do { out ("Recovering connection to " ++ uriAuthToString hst) + ; reportEvent ReuseConnection (show (rqURI rqst)) ; dorequest2 c rqst } ; + ; case rsp of { Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return ()} ; return rsp } where dorequest2 c r = do dbg <- getBS bsDebug + st <- getBrowserState + onSendComplete <- + case bsEvent st of + Nothing -> return (return ()) + Just evh -> return $ do + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + (lift (evh x)) st + return () ioAction $ case dbg of - Nothing -> sendHTTP c r + Nothing -> sendHTTP_notify c r onSendComplete Just f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c - sendHTTP c' r - + sendHTTP_notify c' r onSendComplete + + reqURIAuth :: Request ty -> URIAuth reqURIAuth req = case uriAuthority (rqURI req) of diff --git a/Network/BufferType.hs b/Network/BufferType.hs --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -1,132 +1,132 @@ -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Network.BufferType --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne --- License : BSD --- --- Maintainer : Sigbjorn Finne --- Stability : experimental --- Portability : non-portable (not tested) --- --- Operations over wire-transmitted values. --- ------------------------------------------------------------------------------ -module Network.BufferType - ( - BufferType(..) - - , BufferOp(..) - , strictBufferOp - , lazyBufferOp - , stringBufferOp - ) where - - -import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) -import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) -import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) -import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) -import System.IO ( Handle ) -import Data.Word ( Word8 ) - --- | The @BufferType@ class encodes, in a mixed-mode way, the interface --- that the library requires to operate over data embedded in HTTP --- requests and responses. That is, we use explicit dictionaries --- for the operations, but overload the name of these dicts. --- -class BufferType bufType where - bufferOps :: BufferOp bufType - -instance BufferType Lazy.ByteString where - bufferOps = lazyBufferOp - -instance BufferType Strict.ByteString where - bufferOps = strictBufferOp - -instance BufferType String where - bufferOps = stringBufferOp - --- Encode the I/O operations of the underlying buffer over a Handle --- in an (explicit) dictionary type. May not be needed, but gives --- us flexibility in explicit overriding and wrapping up of these methods. -data BufferOp a - = BufferOp - { buf_hGet :: Handle -> Int -> IO a - , buf_hGetContents :: Handle -> IO a - , buf_hPut :: Handle -> a -> IO () - , buf_hGetLine :: Handle -> IO a - , buf_empty :: a - , buf_append :: a -> a -> a - , buf_fromStr :: String -> a - , buf_toStr :: a -> String - , buf_snoc :: a -> Word8 -> a - , buf_splitAt :: Int -> a -> (a,a) - , buf_span :: (Char -> Bool) -> a -> (a,a) - , buf_isLineTerm :: a -> Bool - , buf_isEmpty :: a -> Bool - } - -instance Eq (BufferOp a) where - _ == _ = False - -strictBufferOp :: BufferOp Strict.ByteString -strictBufferOp = - BufferOp - { buf_hGet = Strict.hGet - , buf_hGetContents = Strict.hGetContents - , buf_hPut = Strict.hPut - , buf_hGetLine = Strict.hGetLine - , buf_append = Strict.append - , buf_fromStr = Strict.pack - , buf_toStr = Strict.unpack - , buf_snoc = Strict.snoc - , buf_splitAt = Strict.splitAt - , buf_span = Strict.span - , buf_empty = Strict.empty - , buf_isLineTerm = \ b -> Strict.length b == 2 && crlf == b - , buf_isEmpty = Strict.null - } - where - crlf = Strict.pack "\r\n" - -lazyBufferOp :: BufferOp Lazy.ByteString -lazyBufferOp = - BufferOp - { buf_hGet = Lazy.hGet - , buf_hGetContents = Lazy.hGetContents - , buf_hPut = Lazy.hPut - , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) - , buf_append = Lazy.append - , buf_fromStr = Lazy.pack - , buf_toStr = Lazy.unpack - , buf_snoc = Lazy.snoc - , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x - , buf_span = Lazy.span - , buf_empty = Lazy.empty - , buf_isLineTerm = \ b -> Lazy.length b == 2 && crlf == b - , buf_isEmpty = Lazy.null - } - where - crlf = Lazy.pack "\r\n" - -stringBufferOp :: BufferOp String -stringBufferOp =BufferOp - { buf_hGet = \ h n -> Strict.hGet h n >>= return . Strict.unpack - , buf_hGetContents = \ h -> Strict.hGetContents h >>= return . Strict.unpack - , buf_hPut = \ h s -> Strict.hPut h (Strict.pack s) - , buf_hGetLine = \ h -> Strict.hGetLine h >>= return . Strict.unpack - , buf_append = (++) - , buf_fromStr = id - , buf_toStr = id - , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] - , buf_splitAt = splitAt - , buf_span = \ p a -> - case Strict.span p (Strict.pack a) of - (x,y) -> (Strict.unpack x, Strict.unpack y) - , buf_empty = [] - , buf_isLineTerm = \ b -> b == crlf - , buf_isEmpty = null - } - where - crlf = "\r\n" +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Operations over wire-transmitted values. +-- +----------------------------------------------------------------------------- +module Network.BufferType + ( + BufferType(..) + + , BufferOp(..) + , strictBufferOp + , lazyBufferOp + , stringBufferOp + ) where + + +import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) +import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) +import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) +import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) +import System.IO ( Handle ) +import Data.Word ( Word8 ) + +-- | The @BufferType@ class encodes, in a mixed-mode way, the interface +-- that the library requires to operate over data embedded in HTTP +-- requests and responses. That is, we use explicit dictionaries +-- for the operations, but overload the name of these dicts. +-- +class BufferType bufType where + bufferOps :: BufferOp bufType + +instance BufferType Lazy.ByteString where + bufferOps = lazyBufferOp + +instance BufferType Strict.ByteString where + bufferOps = strictBufferOp + +instance BufferType String where + bufferOps = stringBufferOp + +-- Encode the I/O operations of the underlying buffer over a Handle +-- in an (explicit) dictionary type. May not be needed, but gives +-- us flexibility in explicit overriding and wrapping up of these methods. +data BufferOp a + = BufferOp + { buf_hGet :: Handle -> Int -> IO a + , buf_hGetContents :: Handle -> IO a + , buf_hPut :: Handle -> a -> IO () + , buf_hGetLine :: Handle -> IO a + , buf_empty :: a + , buf_append :: a -> a -> a + , buf_fromStr :: String -> a + , buf_toStr :: a -> String + , buf_snoc :: a -> Word8 -> a + , buf_splitAt :: Int -> a -> (a,a) + , buf_span :: (Char -> Bool) -> a -> (a,a) + , buf_isLineTerm :: a -> Bool + , buf_isEmpty :: a -> Bool + } + +instance Eq (BufferOp a) where + _ == _ = False + +strictBufferOp :: BufferOp Strict.ByteString +strictBufferOp = + BufferOp + { buf_hGet = Strict.hGet + , buf_hGetContents = Strict.hGetContents + , buf_hPut = Strict.hPut + , buf_hGetLine = Strict.hGetLine + , buf_append = Strict.append + , buf_fromStr = Strict.pack + , buf_toStr = Strict.unpack + , buf_snoc = Strict.snoc + , buf_splitAt = Strict.splitAt + , buf_span = Strict.span + , buf_empty = Strict.empty + , buf_isLineTerm = \ b -> Strict.length b == 2 && crlf == b + , buf_isEmpty = Strict.null + } + where + crlf = Strict.pack "\r\n" + +lazyBufferOp :: BufferOp Lazy.ByteString +lazyBufferOp = + BufferOp + { buf_hGet = Lazy.hGet + , buf_hGetContents = Lazy.hGetContents + , buf_hPut = Lazy.hPut + , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) + , buf_append = Lazy.append + , buf_fromStr = Lazy.pack + , buf_toStr = Lazy.unpack + , buf_snoc = Lazy.snoc + , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x + , buf_span = Lazy.span + , buf_empty = Lazy.empty + , buf_isLineTerm = \ b -> Lazy.length b == 2 && crlf == b + , buf_isEmpty = Lazy.null + } + where + crlf = Lazy.pack "\r\n" + +stringBufferOp :: BufferOp String +stringBufferOp =BufferOp + { buf_hGet = \ h n -> Strict.hGet h n >>= return . Strict.unpack + , buf_hGetContents = \ h -> Strict.hGetContents h >>= return . Strict.unpack + , buf_hPut = \ h s -> Strict.hPut h (Strict.pack s) + , buf_hGetLine = \ h -> Strict.hGetLine h >>= return . Strict.unpack + , buf_append = (++) + , buf_fromStr = id + , buf_toStr = id + , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] + , buf_splitAt = splitAt + , buf_span = \ p a -> + case Strict.span p (Strict.pack a) of + (x,y) -> (Strict.unpack x, Strict.unpack y) + , buf_empty = [] + , buf_isLineTerm = \ b -> b == crlf + , buf_isEmpty = null + } + where + crlf = "\r\n" diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -79,11 +79,12 @@ {- the functionality that Network.HTTP.HandleStream and Network.HTTP.Stream exposes: - , simpleHTTP -- :: Request -> IO (Result Response) - , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) - , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) - , receiveHTTP -- :: Stream s => s -> IO (Result Request) - , respondHTTP -- :: Stream s => s -> Response -> IO () + , simpleHTTP -- :: Request -> IO (Result Response) + , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> IO () -} , module Network.TCP ) where diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -1,565 +1,565 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Base --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne --- License : BSD --- --- Maintainer : Sigbjorn Finne --- Stability : experimental --- Portability : non-portable (not tested) --- --- An easy HTTP interface; base types. --- ------------------------------------------------------------------------------ -module Network.HTTP.Base - ( - -- ** Constants - httpVersion - - -- ** HTTP - , Request(..) - , Response(..) - , RequestMethod(..) - - , Request_String - , Response_String - , HTTPRequest - , HTTPResponse - - -- ** URL Encoding - , urlEncode - , urlDecode - , urlEncodeVars - - -- ** URI authority parsing - , URIAuthority(..) - , parseURIAuthority - - -- internal - , crlf - , sp - , uriToAuthorityString -- :: URI -> String - , uriAuthToString -- :: URIAuth -> String - , parseResponseHead - , parseRequestHead - , ResponseNextStep(..) - , matchResponse - , ResponseData - , ResponseCode - , RequestData - - , getAuth - , normalizeRequestURI - , normalizeHostHeader - , findConnClose - - -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) - , linearTransfer - , hopefulTransfer - , chunkedTransfer - , uglyDeathTransfer - , readTillEmpty1 - , readTillEmpty2 - - , catchIO - , catchIO_ - , responseParseError - ) where - -import Network.URI - ( URI(uriAuthority, uriPath, uriScheme) - , URIAuth(uriUserInfo, uriRegName, uriPort) - , parseURIReference - ) - -import Control.Monad ( guard ) -import Control.Monad.Error -import Data.Char ( ord, digitToInt, intToDigit, toLower ) -import Data.List ( partition ) -import Data.Maybe ( listToMaybe ) -import Numeric ( showHex, readHex ) - -import Network.Stream -import Network.BufferType ( BufferOp(..) ) -import Network.HTTP.Headers -import Network.HTTP.Utils ( trim ) - -import Text.Read.Lex (readDecP) -import Text.ParserCombinators.ReadP - ( ReadP, readP_to_S, char, (<++), look, munch ) - -import Control.Exception as Exception (IOException) - ------------------------------------------------------------------ ------------------- 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 - --- This function duplicates old Network.URI.authority behaviour. -uriToAuthorityString :: URI -> String -uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) - -uriAuthToString :: URIAuth -> String -uriAuthToString ua = - concat [ uriUserInfo ua - , uriRegName ua - , uriPort ua - ] - ------------------------------------------------------------------ ------------------- 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 | DELETE | OPTIONS | TRACE - deriving(Show,Eq) - -rqMethodMap :: [(String, RequestMethod)] -rqMethodMap = [("HEAD", HEAD), - ("PUT", PUT), - ("GET", GET), - ("POST", POST), - ("DELETE", DELETE), - ("OPTIONS", OPTIONS), - ("TRACE", TRACE)] - --- --- for backwards-ish compatibility; suggest --- migrating to new Req/Resp by adding type param. --- -type Request_String = Request String -type Response_String = Response String - --- Hmm..I really want to use these for the record --- type, but it will upset codebases wanting to --- migrate (and live with using pre-HTTPbis versions.) -type HTTPRequest a = Request a -type HTTPResponse a = Response a - --- | An HTTP Request. --- The 'Show' instance of this type is used for message serialisation, --- which means no body data is output. -data Request a = - 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 :: a - } - - - -crlf, sp :: String -crlf = "\r\n" -sp = " " - --- 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 a) where - show (Request u m h _) = - show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf - ++ foldr (++) [] (map show h) ++ crlf - where - alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } - else u - -instance HasHeaders (Request a) where - getHeaders = rqHeaders - setHeaders rq hdrs = rq { rqHeaders=hdrs } - --- | For easy pattern matching, HTTP response codes @xyz@ are --- represented as @(x,y,z)@. -type ResponseCode = (Int,Int,Int) - --- | @ResponseData@ contains the head of a response payload; --- HTTP response code, accompanying text description + header --- fields. -type ResponseData = (ResponseCode,String,[Header]) - --- | @RequestData@ contains the head of a HTTP request; method, --- its URL along with the auxillary/supporting header data. -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 a = - Response { rspCode :: ResponseCode - , rspReason :: String - , rspHeaders :: [Header] - , rspBody :: a - } - --- 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 a) where - show (Response (a,b,c) reason headers _) = - httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf - ++ foldr (++) [] (map show headers) ++ crlf - -instance HasHeaders (Response a) where - getHeaders = rspHeaders - setHeaders rsp hdrs = rsp { rspHeaders=hdrs } - ------------------------------------------------------------------ ------------------- Parsing -------------------------------------- ------------------------------------------------------------------ - --- Parsing a request -parseRequestHead :: [String] -> Result RequestData -parseRequestHead [] = Left ErrorClosed -parseRequestHead (com:hdrs) = do - (_version,rqm,uri) <- requestCommand com (words com) - hdrs' <- parseHeaders hdrs - return (rqm,uri,hdrs') - where - requestCommand l _yes@(rqm:uri:version) = - case (parseURIReference uri, lookup rqm rqMethodMap) of - (Just u, Just r) -> return (version,r,u) - _ -> parse_err l - requestCommand l _ - | null l = failWith ErrorClosed - | otherwise = parse_err l - - parse_err l = responseParseError "parseRequestHead" - ("Request command line parse failure: " ++ l) - --- Parsing a response -parseResponseHead :: [String] -> Result ResponseData -parseResponseHead [] = failWith ErrorClosed -parseResponseHead (sts:hdrs) = do - (_version,code,reason) <- responseStatus sts (words sts) - hdrs' <- parseHeaders hdrs - return (code,reason,hdrs') - where - responseStatus _l _yes@(version:code:reason) = - return (version,match code,concatMap (++" ") reason) - responseStatus l _no - | null l = failWith ErrorClosed -- an assumption - | otherwise = parse_err l - - parse_err l = - responseParseError - "parseResponseHead" - ("Response status line parse failure: " ++ l) - - match [a,b,c] = (digitToInt a, - digitToInt b, - digitToInt c) - match _ = (-1,-1,-1) -- will create appropriate behaviour - - - - ------------------------------------------------------------------ ------------------- HTTP Send / Recv ---------------------------------- ------------------------------------------------------------------ - -data ResponseNextStep - = Continue - | Retry - | Done - | ExpectEntity - | DieHorribly String - -matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep -matchResponse rqst rsp = - case rsp of - (1,0,0) -> Continue - (1,0,1) -> Done -- 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 - - - ------------------------------------------------------------------ ------------------- 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) = toEnum (16 * digitToInt a + digitToInt b) - : urlDecode rest -urlDecode (h:t) = h : urlDecode t -urlDecode [] = [] - -urlEncode (h:t) = - let str = if reserved (ord h) then escape h else [h] - in str ++ urlEncode t - where - reserved x - | x >= ord 'a' && x <= ord 'z' = False - | x >= ord 'A' && x <= ord 'Z' = False - | x >= ord '0' && x <= ord '9' = False - | x <= 0x20 || x >= 0x7F = True - | otherwise = x `elem` map ord [';','/','?',':','@','&' - ,'=','+',',','$','{','}' - ,'|','\\','^','[',']','`' - ,'<','>','#','%','"'] - -- wouldn't it be nice if the compiler - -- optimised the above for us? - - escape x = '%':showHex (ord x) "" - -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 [] = [] - --- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ --- header. -getAuth :: Monad m => Request ty -> m URIAuthority -getAuth r = - -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) - case parseURIAuthority auth of - Just x -> return x - Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" - where - auth = - case findHeader HdrHost r of - Just h -> h - Nothing -> uriToAuthorityString (rqURI r) - - {- 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. -normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty -normalizeRequestURI doClose h r = - (if doClose then replaceHeader HdrConnection "close" else id) $ - insertHeaderIfMissing HdrHost h $ - r { rqURI = (rqURI r){ uriScheme = "" - , uriAuthority = Nothing - }} - --- Adds a Host header if one is NOT ALREADY PRESENT -normalizeHostHeader :: Request ty -> Request ty -normalizeHostHeader rq = - insertHeaderIfMissing HdrHost - (uriToAuthorityString $ rqURI rq) - rq - --- Looks for a "Connection" header with the value "close". --- Returns True when this is found. -findConnClose :: [Header] -> Bool -findConnClose hdrs = - maybe False - (\ x -> map toLower (trim x) == "close") - (lookupHeader HdrConnection hdrs) - - --- | Used when we know exactly how many bytes to expect. -linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) -linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) - --- | 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 :: BufferOp a - -> IO (Result a) - -> [a] - -> IO (Result ([Header],a)) -hopefulTransfer bufOps readL strs - = readL >>= - either (\v -> return $ Left v) - (\more -> if (buf_isEmpty bufOps more) - then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs)) - else hopefulTransfer bufOps readL (more:strs)) - --- | A necessary feature of HTTP\/1.1 --- Also the only transfer variety likely to --- return any footers. -chunkedTransfer :: BufferOp a - -> IO (Result a) - -> (Int -> IO (Result a)) - -> IO (Result ([Header], a)) -chunkedTransfer bufOps readL readBlk = - fmapE (\ (ftrs,count,info) -> - let myftrs = Header HdrContentLength (show count) : ftrs - in Right (myftrs,info)) - (chunkedTransferC bufOps readL readBlk 0) - -chunkedTransferC :: BufferOp a - -> IO (Result a) - -> (Int -> IO (Result a)) - -> Int - -> IO (Result ([Header],Int,a)) -chunkedTransferC bufOps readL readBlk n = do - v <- readL - case v of - Left e -> return (Left e) - Right line - | size == 0 -> - fmapE (\ strs -> do - ftrs <- parseHeaders (map (buf_toStr bufOps) strs) - return (ftrs,n,buf_empty bufOps)) - (readTillEmpty2 bufOps readL []) - - | otherwise -> do - some <- readBlk size - readL - more <- chunkedTransferC bufOps readL readBlk (n+size) - return $ do - cdata <- some - (ftrs,m,mdata) <- more - return (ftrs,m,buf_append bufOps cdata mdata) - where - size - | buf_isEmpty bufOps line = 0 - | otherwise = - case readHex (buf_toStr bufOps line) of - (hx,_):_ -> hx - _ -> 0 - --- | Maybe in the future we will have a sensible thing --- to do here, at that time we might want to change --- the name. -uglyDeathTransfer :: String -> IO (Result ([Header],a)) -uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") - --- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) -readTillEmpty1 :: BufferOp a - -> IO (Result a) - -> IO (Result [a]) -readTillEmpty1 bufOps readL = - readL >>= - either (return . Left) - (\ s -> - if buf_isLineTerm bufOps s - then readTillEmpty1 bufOps readL - else readTillEmpty2 bufOps readL [s]) - --- | 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 :: BufferOp a - -> IO (Result a) - -> [a] - -> IO (Result [a]) -readTillEmpty2 bufOps readL list = - readL >>= - either (return . Left) - (\ s -> - if buf_isLineTerm bufOps s || buf_isEmpty bufOps s - then return (Right $ reverse (s:list)) - else readTillEmpty2 bufOps readL (s:list)) - --- --- Misc --- - --- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific --- tweaks better go here. -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO a h = Prelude.catch a h - -catchIO_ :: IO a -> IO a -> IO a -catchIO_ a h = Prelude.catch a (const h) - -responseParseError :: String -> String -> Result a -responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An easy HTTP interface; base types. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion + + -- ** HTTP + , Request(..) + , Response(..) + , RequestMethod(..) + + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , crlf + , sp + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , parseResponseHead + , parseRequestHead + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , uglyDeathTransfer + , readTillEmpty1 + , readTillEmpty2 + + , catchIO + , catchIO_ + , responseParseError + ) where + +import Network.URI + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +import Control.Monad ( guard ) +import Control.Monad.Error +import Data.Char ( ord, digitToInt, intToDigit, toLower ) +import Data.List ( partition ) +import Data.Maybe ( listToMaybe ) +import Numeric ( showHex, readHex ) + +import Network.Stream +import Network.BufferType ( BufferOp(..) ) +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Text.Read.Lex (readDecP) +import Text.ParserCombinators.ReadP + ( ReadP, readP_to_S, char, (<++), look, munch ) + +import Control.Exception as Exception (IOException) + +----------------------------------------------------------------- +------------------ 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 + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + +uriAuthToString :: URIAuth -> String +uriAuthToString ua = + concat [ uriUserInfo ua + , uriRegName ua + , uriPort ua + ] + +----------------------------------------------------------------- +------------------ 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 | DELETE | OPTIONS | TRACE + deriving(Show,Eq) + +rqMethodMap :: [(String, RequestMethod)] +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("DELETE", DELETE), + ("OPTIONS", OPTIONS), + ("TRACE", TRACE)] + +-- +-- for backwards-ish compatibility; suggest +-- migrating to new Req/Resp by adding type param. +-- +type Request_String = Request String +type Response_String = Response String + +-- Hmm..I really want to use these for the record +-- type, but it will upset codebases wanting to +-- migrate (and live with using pre-HTTPbis versions.) +type HTTPRequest a = Request a +type HTTPResponse a = Response a + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data Request a = + 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 :: a + } + + + +crlf, sp :: String +crlf = "\r\n" +sp = " " + +-- 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 a) where + show (Request u m h _) = + show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf + ++ foldr (++) [] (map show h) ++ crlf + where + alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u + +instance HasHeaders (Request a) where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + +-- | For easy pattern matching, HTTP response codes @xyz@ are +-- represented as @(x,y,z)@. +type ResponseCode = (Int,Int,Int) + +-- | @ResponseData@ contains the head of a response payload; +-- HTTP response code, accompanying text description + header +-- fields. +type ResponseData = (ResponseCode,String,[Header]) + +-- | @RequestData@ contains the head of a HTTP request; method, +-- its URL along with the auxillary/supporting header data. +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 a = + Response { rspCode :: ResponseCode + , rspReason :: String + , rspHeaders :: [Header] + , rspBody :: a + } + +-- 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 a) where + show (Response (a,b,c) reason headers _) = + httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show headers) ++ crlf + +instance HasHeaders (Response a) where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +-- Parsing a request +parseRequestHead :: [String] -> Result RequestData +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = do + (_version,rqm,uri) <- requestCommand com (words com) + hdrs' <- parseHeaders hdrs + return (rqm,uri,hdrs') + where + requestCommand l _yes@(rqm:uri:version) = + case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> return (version,r,u) + _ -> parse_err l + requestCommand l _ + | null l = failWith ErrorClosed + | otherwise = parse_err l + + parse_err l = responseParseError "parseRequestHead" + ("Request command line parse failure: " ++ l) + +-- Parsing a response +parseResponseHead :: [String] -> Result ResponseData +parseResponseHead [] = failWith ErrorClosed +parseResponseHead (sts:hdrs) = do + (_version,code,reason) <- responseStatus sts (words sts) + hdrs' <- parseHeaders hdrs + return (code,reason,hdrs') + where + responseStatus _l _yes@(version:code:reason) = + return (version,match code,concatMap (++" ") reason) + responseStatus l _no + | null l = failWith ErrorClosed -- an assumption + | otherwise = parse_err l + + parse_err l = + responseParseError + "parseResponseHead" + ("Response status line parse failure: " ++ l) + + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + + + + +----------------------------------------------------------------- +------------------ HTTP Send / Recv ---------------------------------- +----------------------------------------------------------------- + +data ResponseNextStep + = Continue + | Retry + | Done + | ExpectEntity + | DieHorribly String + +matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep +matchResponse rqst rsp = + case rsp of + (1,0,0) -> Continue + (1,0,1) -> Done -- 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 + + + +----------------------------------------------------------------- +------------------ 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) = toEnum (16 * digitToInt a + digitToInt b) + : urlDecode rest +urlDecode (h:t) = h : urlDecode t +urlDecode [] = [] + +urlEncode (h:t) = + let str = if reserved (ord h) then escape h else [h] + in str ++ urlEncode t + where + reserved x + | x >= ord 'a' && x <= ord 'z' = False + | x >= ord 'A' && x <= ord 'Z' = False + | x >= ord '0' && x <= ord '9' = False + | x <= 0x20 || x >= 0x7F = True + | otherwise = x `elem` map ord [';','/','?',':','@','&' + ,'=','+',',','$','{','}' + ,'|','\\','^','[',']','`' + ,'<','>','#','%','"'] + -- wouldn't it be nice if the compiler + -- optimised the above for us? + + escape x = '%':showHex (ord x) "" + +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 [] = [] + +-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ +-- header. +getAuth :: Monad m => Request ty -> m URIAuthority +getAuth r = + -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) + case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" + where + auth = + case findHeader HdrHost r of + Just h -> h + Nothing -> uriToAuthorityString (rqURI r) + + {- 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. +normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty +normalizeRequestURI doClose h r = + (if doClose then replaceHeader HdrConnection "close" else id) $ + insertHeaderIfMissing HdrHost h $ + r { rqURI = (rqURI r){ uriScheme = "" + , uriAuthority = Nothing + }} + +-- Adds a Host header if one is NOT ALREADY PRESENT +normalizeHostHeader :: Request ty -> Request ty +normalizeHostHeader rq = + insertHeaderIfMissing HdrHost + (uriToAuthorityString $ rqURI rq) + rq + +-- Looks for a "Connection" header with the value "close". +-- Returns True when this is found. +findConnClose :: [Header] -> Bool +findConnClose hdrs = + maybe False + (\ x -> map toLower (trim x) == "close") + (lookupHeader HdrConnection hdrs) + + +-- | Used when we know exactly how many bytes to expect. +linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) +linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) + +-- | 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 :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result ([Header],a)) +hopefulTransfer bufOps readL strs + = readL >>= + either (\v -> return $ Left v) + (\more -> if (buf_isEmpty bufOps more) + then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs)) + else hopefulTransfer bufOps readL (more:strs)) + +-- | A necessary feature of HTTP\/1.1 +-- Also the only transfer variety likely to +-- return any footers. +chunkedTransfer :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> IO (Result ([Header], a)) +chunkedTransfer bufOps readL readBlk = + fmapE (\ (ftrs,count,info) -> + let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info)) + (chunkedTransferC bufOps readL readBlk 0) + +chunkedTransferC :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> Int + -> IO (Result ([Header],Int,a)) +chunkedTransferC bufOps readL readBlk n = do + v <- readL + case v of + Left e -> return (Left e) + Right line + | size == 0 -> + fmapE (\ strs -> do + ftrs <- parseHeaders (map (buf_toStr bufOps) strs) + return (ftrs,n,buf_empty bufOps)) + (readTillEmpty2 bufOps readL []) + + | otherwise -> do + some <- readBlk size + readL + more <- chunkedTransferC bufOps readL readBlk (n+size) + return $ do + cdata <- some + (ftrs,m,mdata) <- more + return (ftrs,m,buf_append bufOps cdata mdata) + where + size + | buf_isEmpty bufOps line = 0 + | otherwise = + case readHex (buf_toStr bufOps line) of + (hx,_):_ -> hx + _ -> 0 + +-- | Maybe in the future we will have a sensible thing +-- to do here, at that time we might want to change +-- the name. +uglyDeathTransfer :: String -> IO (Result ([Header],a)) +uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") + +-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) +readTillEmpty1 :: BufferOp a + -> IO (Result a) + -> IO (Result [a]) +readTillEmpty1 bufOps readL = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s + then readTillEmpty1 bufOps readL + else readTillEmpty2 bufOps readL [s]) + +-- | 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 :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result [a]) +readTillEmpty2 bufOps readL list = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s || buf_isEmpty bufOps s + then return (Right $ reverse (s:list)) + else readTillEmpty2 bufOps readL (s:list)) + +-- +-- Misc +-- + +-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific +-- tweaks better go here. +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO a h = Prelude.catch a h + +catchIO_ :: IO a -> IO a -> IO a +catchIO_ a h = Prelude.catch a (const h) + +responseParseError :: String -> String -> Result a +responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -12,11 +12,12 @@ -- ----------------------------------------------------------------------------- module Network.HTTP.HandleStream - ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) - , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) - , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) - , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) - , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () + ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) + , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) + , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) + , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where @@ -72,7 +73,7 @@ sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do let a_rq = normalizeHostHeader rq - rsp <- catchIO (sendMain conn a_rq) + rsp <- catchIO (sendMain conn a_rq (return ())) (\e -> do { close conn; ioError e }) let fn list = when (or $ map findConnClose list) (close conn) @@ -81,6 +82,24 @@ rsp return rsp +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + let a_rq = normalizeHostHeader rq + rsp <- catchIO (sendMain conn a_rq onSendComplete) + (\e -> do { close conn; ioError e }) + let fn list = when (or $ map findConnClose list) + (close conn) + either (\_ -> fn [rqHeaders rq]) + (\r -> fn [rqHeaders rq,rspHeaders r]) + rsp + return rsp + + + -- 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- @@ -94,14 +113,16 @@ sendMain :: HStream ty => HandleStream ty -> Request ty + -> (IO ()) -> IO (Result (Response ty)) -sendMain conn rqst = do +sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rqBody rqst) + onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -96,11 +96,12 @@ module Network.HTTP.Stream ( module Network.Stream - , simpleHTTP -- :: Request_String -> IO (Result Response_String) - , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) - , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) - , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) - , respondHTTP -- :: Stream s => s -> Response_String -> IO () + , simpleHTTP -- :: Request_String -> IO (Result Response_String) + , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) + , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) + , respondHTTP -- :: Stream s => s -> Response_String -> IO () ) where @@ -166,7 +167,7 @@ sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) sendHTTP conn rq = do { let a_rq = normalizeHostHeader rq - ; rsp <- catchIO (main a_rq) + ; rsp <- catchIO (sendMain conn a_rq (return ())) (\e -> do { close conn; ioError e }) ; let fn list = when (or $ map findConnClose list) (close conn) @@ -175,7 +176,20 @@ rsp ; return rsp } - where + +sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendHTTP_notify conn rq onSendComplete = + do { let a_rq = normalizeHostHeader rq + ; rsp <- catchIO (sendMain conn a_rq onSendComplete) + (\e -> do { close conn; ioError e }) + ; let fn list = when (or $ map findConnClose list) + (close conn) + ; either (\_ -> fn [rqHeaders rq]) + (\r -> fn [rqHeaders rq,rspHeaders r]) + rsp + ; return rsp + } + -- 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- @@ -186,40 +200,39 @@ -- 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_String -> IO (Result Response_String) - main rqst = - do - --let str = if null (rqBody rqst) - -- then show rqst - -- else show (insertHeader HdrExpect "100-continue" rqst) - writeBlock conn (show rqst) - -- write body immediately, don't wait for 100 CONTINUE - writeBlock conn (rqBody rqst) - rsp <- getResponseHead - switchResponse True False rsp rqst +sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst - -- reads and parses headers - getResponseHead :: IO (Result ResponseData) - getResponseHead = - do { lor <- readTillEmpty1 stringBufferOp (readLine conn) - ; return $ lor >>= 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_String - -> IO (Result Response_String) - - 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. +-- reads and parses headers +getResponseHead :: Stream s => s -> IO (Result ResponseData) +getResponseHead conn = do + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead - switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +-- Hmmm, this could go bad if we keep getting "100 Continue" +-- responses... Except this should never happen according +-- to the RFC. +switchResponse :: Stream s + => s + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request_String + -> IO (Result Response_String) +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 conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> {- Time to send the body -} @@ -227,21 +240,21 @@ ; case val of Left e -> return (Left e) Right _ -> - do { rsp <- getResponseHead - ; switchResponse allow_retry True rsp rqst + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry True rsp rqst } } | otherwise -> {- keep waiting -} - do { rsp <- getResponseHead - ; switchResponse allow_retry bdy_sent rsp rqst + do { rsp <- getResponseHead conn + ; switchResponse conn 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 + ; rsp <- getResponseHead conn + ; switchResponse conn False bdy_sent rsp rqst } Done -> diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -1,67 +1,67 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Utils --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne --- License : BSD --- --- Maintainer : Sigbjorn Finne --- Stability : experimental --- Portability : non-portable (not tested) --- --- Set of utility functions and definitions used by package modules. --- -module Network.HTTP.Utils - ( trim -- :: String -> String - , trimL -- :: String -> String - , trimR -- :: String -> String - - , crlf -- :: String - - , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) - , splitBy -- :: Eq a => a -> [a] -> [[a]] - - ) where - -import Data.Char -import Data.List ( elemIndex ) -import Data.Maybe ( fromMaybe ) - --- | @crlf@ is our beloved two-char line terminator. -crlf :: String -crlf = "\r\n" - --- | @split delim ls@ splits a list into two parts, the @delim@ occurring --- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is --- returned. -split :: Eq a => a -> [a] -> Maybe ([a],[a]) -split delim list = case delim `elemIndex` list of - Nothing -> Nothing - Just x -> Just $ splitAt x list - --- | @trim str@ removes leading and trailing whitespace from @str@. -trim :: String -> String -trim xs = trimR (trimL xs) - --- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') --- from @str@. -trimL :: String -> String -trimL xs = dropWhile isSpace xs - --- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') --- from @str@. -trimR :: String -> String -trimR str = fromMaybe "" $ foldr trimIt Nothing str - where - trimIt x (Just xs) = Just (x:xs) - trimIt x Nothing - | isSpace x = Nothing - | otherwise = Just [x] - --- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. -splitBy :: Eq a => a -> [a] -> [[a]] -splitBy _ [] = [] -splitBy c xs = - case break (==c) xs of - (_,[]) -> [xs] - (as,_:bs) -> as : splitBy c bs - +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Set of utility functions and definitions used by package modules. +-- +module Network.HTTP.Utils + ( trim -- :: String -> String + , trimL -- :: String -> String + , trimR -- :: String -> String + + , crlf -- :: String + + , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) + , splitBy -- :: Eq a => a -> [a] -> [[a]] + + ) where + +import Data.Char +import Data.List ( elemIndex ) +import Data.Maybe ( fromMaybe ) + +-- | @crlf@ is our beloved two-char line terminator. +crlf :: String +crlf = "\r\n" + +-- | @split delim ls@ splits a list into two parts, the @delim@ occurring +-- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is +-- returned. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + +-- | @trim str@ removes leading and trailing whitespace from @str@. +trim :: String -> String +trim xs = trimR (trimL xs) + +-- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimL :: String -> String +trimL xs = dropWhile isSpace xs + +-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimR :: String -> String +trimR str = fromMaybe "" $ foldr trimIt Nothing str + where + trimIt x (Just xs) = Just (x:xs) + trimIt x Nothing + | isSpace x = Nothing + | otherwise = Just [x] + +-- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. +splitBy :: Eq a => a -> [a] -> [[a]] +splitBy _ [] = [] +splitBy c xs = + case break (==c) xs of + (_,[]) -> [xs] + (as,_:bs) -> as : splitBy c bs +