HTTP 4000.0.3 → 4000.0.4
raw patch · 8 files changed
+954/−833 lines, 8 filesdep +old-timePVP ok
version bump matches the API change (PVP)
Dependencies added: old-time
API changes (from Hackage documentation)
+ Network.Browser: BrowserEvent :: ClockTime -> RequestID -> String -> BrowserEventType ty -> BrowserEvent ty
+ Network.Browser: OpenConnection :: BrowserEventType ty
+ Network.Browser: RequestSent :: BrowserEventType ty
+ Network.Browser: ResponseEnd :: ResponseData -> BrowserEventType ty
+ Network.Browser: ResponseFinish :: BrowserEventType ty
+ Network.Browser: ReuseConnection :: BrowserEventType ty
+ Network.Browser: browserEventType :: BrowserEvent ty -> BrowserEventType ty
+ Network.Browser: browserRequestID :: BrowserEvent ty -> RequestID
+ Network.Browser: browserRequestURI :: BrowserEvent ty -> String
+ Network.Browser: browserTimestamp :: BrowserEvent ty -> ClockTime
+ Network.Browser: data BrowserEvent ty
+ Network.Browser: data BrowserEventType ty
+ Network.Browser: setEventHandler :: (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty ()
+ Network.Browser: type RequestID = Int
+ Network.HTTP.HandleStream: sendHTTP_notify :: (HStream ty) => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
+ Network.HTTP.Stream: sendHTTP_notify :: (Stream s) => s -> Request_String -> IO () -> IO (Result Response_String)
Files
- HTTP.cabal +4/−4
- Network/Browser.hs +94/−8
- Network/BufferType.hs +132/−132
- Network/HTTP.hs +6/−5
- Network/HTTP/Base.hs +565/−565
- Network/HTTP/HandleStream.hs +28/−7
- Network/HTTP/Stream.hs +58/−45
- Network/HTTP/Utils.hs +67/−67
HTTP.cabal view
@@ -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 <warrick.gray@hotmail.com> Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>-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 <http://code.galois.com/HTTPbis.git>+ Git repository available at <git://code.galois.com/HTTPbis.git> Flag old-base description: Old, monolithic base@@ -60,4 +60,4 @@ else Build-depends: base >= 3 - Build-depends: array+ Build-depends: array, old-time
Network/Browser.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Warrick Gray 2002 -- License : BSD -- --- Maintainer : bjorn@bringert.net+-- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com> -- 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
Network/BufferType.hs view
@@ -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 <sigbjorn.finne@gmail.com> --- 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 <sigbjorn.finne@gmail.com>+-- 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"
Network/HTTP.hs view
@@ -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
Network/HTTP/Base.hs view
@@ -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 <sigbjorn.finne@gmail.com> --- 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: --- > --- > //<user>:<password>@<host>:<port>/<url-path> --- > Some or all of the parts "<user>:<password>@", ":<password>", --- > ":<port>", and "/<url-path>" 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: <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) = 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 <sigbjorn.finne@gmail.com>+-- 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:+-- >+-- > //<user>:<password>@<host>:<port>/<url-path>+-- > Some or all of the parts "<user>:<password>@", ":<password>",+-- > ":<port>", and "/<url-path>" 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: <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) = 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))
Network/HTTP/HandleStream.hs view
@@ -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
Network/HTTP/Stream.hs view
@@ -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 ->
Network/HTTP/Utils.hs view
@@ -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 <sigbjorn.finne@gmail.com> --- 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 <sigbjorn.finne@gmail.com>+-- 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+