{- | Module: Network.Monad.HTTP Copyright: (c) 2009 Henning Thielemann License: BSD Stability: experimental Portability: non-portable (not tested) -} module Network.Monad.HTTP ( send, receive, respond, ) where import Network.URI ( URI(URI, uriAuthority) , URIAuth(uriUserInfo, uriRegName, uriPort) , parseURIReference ) import qualified Network.Monad.HTTP.Header as Header import qualified Network.Monad.Reader as StreamMonad import qualified Network.Monad.Body as Body import Network.Stream (ConnError(ErrorParse,ErrorClosed), ) import Network.HTTP.Base (Request(..), RequestData, RequestMethod(..), Response(..), ResponseData, ResponseCode, ) import Network.Monad.Reader (readLine, readBlock, writeBlock, ) import Control.Monad.Trans.Class (lift, ) import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync import qualified Network.Monad.Exception as Exc import qualified Data.Map as Map import Data.String.HT (trim, ) import Data.Maybe.HT (toMaybe, ) import Data.Char (isDigit, intToDigit, digitToInt, toLower, ) import Data.Monoid (Monoid, mappend, mempty, ) import Data.Semigroup (Semigroup, (<>), ) import Control.Monad (liftM, liftM2, mplus, ) import Numeric (readHex, ) type SynchronousExceptional body m a = Sync.ExceptionalT ConnError (StreamMonad.T body m) a type AsynchronousExceptional body m a = Async.ExceptionalT ConnError (StreamMonad.T body m) a -- * Parsing -- we could use Read class, but I consider this a hack requestMethodDict :: Map.Map String RequestMethod requestMethodDict = Map.fromList $ ("HEAD", HEAD) : ("PUT", PUT) : ("GET", GET) : ("POST", POST) : ("DELETE", DELETE) : ("OPTIONS", OPTIONS) : ("TRACE", TRACE) : [] -- Parsing a request parseRequestHead :: [String] -> Sync.Exceptional ConnError RequestData parseRequestHead [] = Sync.throw ErrorClosed parseRequestHead (com:hdrs) = requestCommand com >>= \(_version,rqm,uri) -> return (rqm, uri, Header.parseManyStraight hdrs) where requestCommand line = case words line of (rqm:uri:version) -> liftM2 (\r u -> (version,r,u)) (Sync.fromMaybe (ErrorParse $ "Unknown HTTP method: " ++ rqm) (Map.lookup rqm requestMethodDict)) (Sync.fromMaybe (ErrorParse $ "Malformed URI: " ++ uri) (parseURIReference uri)) _ -> Sync.throw $ if null line then ErrorClosed else ErrorParse $ "Request command line parse failure: " ++ line -- Parsing a response parseResponseHead :: [String] -> Sync.Exceptional ConnError ResponseData parseResponseHead [] = Sync.throw ErrorClosed parseResponseHead (sts:hdrs) = responseStatus sts >>= \(_version,code,reason) -> return (code, reason, Header.parseManyStraight hdrs) where responseStatus line = case words line of (version:code:reason) -> do digits <- mapM getDigit code case digits of [a,b,c] -> return (version, (a,b,c), concatMap (++" ") reason) _ -> Sync.throw $ ErrorParse $ "Response Code must consist of three digits: " ++ show code _ -> Sync.throw $ if null line then ErrorClosed -- an assumption else ErrorParse $ "Response status line parse failure: " ++ line getDigit d = if isDigit d then return $ digitToInt d else Sync.throw $ ErrorParse $ "Non-digit "++d:" in Response Code" -- * HTTP Send / Recv data Behaviour = Continue | Retry | Done | ExpectEntity | DieHorribly String matchResponse :: RequestMethod -> ResponseCode -> Behaviour matchResponse rqst rsp = let ans = if rqst == HEAD then Done else ExpectEntity in 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") send :: (Monad m, Body.C body) => Request body -> SynchronousExceptional body m (Async.Exceptional ConnError (Bool, Response body)) send rq = liftM (fmap (\rsp -> (findConnClose (rqHeaders rq ++ rspHeaders rsp), rsp))) $ sendMain $ fixHostHeader rq -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows -- ambiguous situations in which a client may send "Expect: 100- -- continue" without receiving either a 417 (Expectation Failed) status -- or a 100 (Continue) status. Therefore, when a client sends this -- header field to an origin server (possibly via a proxy) from which it -- has never seen a 100 (Continue) status, the client SHOULD NOT wait -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: (Monad m, Body.C body) => Request body -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body)) sendMain rqst = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader Header.HdrExpect "100-continue" rqst) writeBlock (Body.fromString $ show rqst) -- write body immediately, don't wait for 100 CONTINUE writeBlock (rqBody rqst) withResponseHead $ switchResponse True False rqst -- reads and parses headers getResponseHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError ResponseData) getResponseHead = Sync.ExceptionalT $ liftM (Async.sequence . fmap (parseResponseHead . map Body.toString)) $ Async.runExceptionalT readTillEmpty1 withResponseHead :: (Monad m, Body.C body) => (ResponseData -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))) -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body)) withResponseHead = Exc.switchM getResponseHead (\(cd,rn,hdrs) -> return $ Response cd rn hdrs mempty) -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according -- to the RFC. switchResponse :: (Monad m, Body.C body) => Bool {- allow retry? -} -> Bool {- is body sent? -} -> Request body -> ResponseData -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body)) -- switchResponse _ _ (Sync.Exception e) _ = return (Sync.Exception e) -- retry on connreset? -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. switchResponse allow_retry bdy_sent rqst (cd,rn,hdrs) = case matchResponse (rqMethod rqst) cd of Continue -> if not bdy_sent then {- Time to send the body -} writeBlock (rqBody rqst) >> (withResponseHead $ switchResponse allow_retry True rqst) else {- keep waiting -} withResponseHead $ switchResponse allow_retry bdy_sent rqst Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -} writeBlock (Body.fromString (show rqst) `mappend` rqBody rqst) >> (withResponseHead $ switchResponse False bdy_sent rqst) Done -> return $ Async.pure $ Response cd rn hdrs mempty DieHorribly str -> Sync.throwT $ ErrorParse ("Invalid response: " ++ str) ExpectEntity -> let tc = Header.lookup Header.HdrTransferEncoding hdrs cl = Header.lookup Header.HdrContentLength hdrs in lift $ Async.runExceptionalT $ assembleHeaderBody (Response cd rn) hdrs $ case tc of Nothing -> case cl of Just x -> linearTransferStrLen x Nothing -> hopefulTransfer Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer False _ -> uglyDeathTransfer -- Adds a Host header if one is NOT ALREADY PRESENT fixHostHeader :: Request body -> Request body fixHostHeader rq = let uri = rqURI rq host_ = uriToAuthorityString uri in Header.insertIfMissing Header.HdrHost host_ rq -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header.T] -> Bool findConnClose hdrs = case Header.lookup Header.HdrConnection hdrs of Nothing -> False Just x -> map toLower (trim x) == "close" -- This function duplicates old Network.URI.authority behaviour. uriToAuthorityString :: URI -> String uriToAuthorityString URI{uriAuthority=Nothing} = "" uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++ uriRegName ua ++ uriPort ua {- | Receive and parse a HTTP request from the given Stream. Should be used for server side interactions. -} receive :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError (Request body)) receive = Exc.switchM getRequestHead (\(rm,uri,hdrs) -> return $ Request uri rm hdrs mempty) (lift . Async.runExceptionalT . processRequest) -- | Reads and parses request headers. getRequestHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError RequestData) getRequestHead = Sync.ExceptionalT $ liftM (Async.sequence . fmap (parseRequestHead . map Body.toString)) $ Async.runExceptionalT readTillEmpty1 -- | Process request body (called after successful getRequestHead) processRequest :: (Monad m, Body.C body) => RequestData -> AsynchronousExceptional body m (Request body) processRequest (rm,uri,hdrs) = -- FIXME : Also handle 100-continue. let tc = Header.lookup Header.HdrTransferEncoding hdrs cl = Header.lookup Header.HdrContentLength hdrs in assembleHeaderBody (Request uri rm) hdrs $ case tc of Nothing -> case cl of Just x -> linearTransferStrLen x Nothing -> mempty -- hopefulTransfer Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer False _ -> uglyDeathTransfer {- Currently it omits the footers in order to prevent infinite loops when processing the headers of a Request or Response with infinite body. -} assembleHeaderBody :: (Monad m) => ([Header.T] -> body -> a) -> [Header.T] -> AsynchronousExceptional body m ([Header.T], body) -> AsynchronousExceptional body m a assembleHeaderBody make hdrs = Exc.map (\(_ftrs,bdy) -> make hdrs bdy) -- Exc.map (\(ftrs,bdy) -> make (hdrs++ftrs) bdy) {- | Very simple function, send a HTTP response over the given stream. This could be improved on to use different transfer types. -} respond :: (Monad m, Body.C body) => Response body -> SynchronousExceptional body m () respond rsp = do writeBlock (Body.fromString $ show rsp) -- write body immediately, don't wait for 100 CONTINUE writeBlock (rspBody rsp) -- * transfer functions -- The following functions were in the where clause of sendHTTP, they have -- been moved to global scope so other functions can access them. linearTransferStrLen :: (Monad m, Monoid body) => String -> AsynchronousExceptional body m ([Header.T],body) linearTransferStrLen ns = case reads ns of [(n,"")] -> linearTransfer n _ -> Async.throwMonoidT $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns -- | Used when we know exactly how many bytes to expect. linearTransfer :: Monad m => Int -> AsynchronousExceptional body m ([Header.T],body) linearTransfer n = Exc.map ((,) []) $ readBlock 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 :: (Monad m, Body.C body) => AsynchronousExceptional body m ([Header.T],body) hopefulTransfer = let go = readLineSwitch $ \line -> if Body.isEmpty line then mempty else Exc.map (mappend line) go in Exc.map ((,) []) go -- | in contrast to built-in @(,,)@, its mappend implementation is lazy data ChunkedResponse body = ChunkedResponse [Header.T] [Int] body deriving Show instance Semigroup body => Semigroup (ChunkedResponse body) where ChunkedResponse hx lx sx <> ChunkedResponse hy ly sy = ChunkedResponse (hx <> hy) (lx <> ly) (sx <> sy) instance Monoid body => Monoid (ChunkedResponse body) where mempty = ChunkedResponse mempty mempty mempty mappend (ChunkedResponse hx lx sx) (ChunkedResponse hy ly sy) = ChunkedResponse (mappend hx hy) (mappend lx ly) (mappend sx sy) forceCR :: ChunkedResponse body -> ChunkedResponse body forceCR ~(ChunkedResponse h l s) = (ChunkedResponse h l s) {- | A necessary feature of HTTP\/1.1 Also the only transfer variety likely to return any footers. Also the only transfer method for infinite data and the prefered one for generated data. -} chunkedTransfer :: (Monad m, Body.C body) => Bool -> AsynchronousExceptional body m ([Header.T],body) chunkedTransfer attachLength = Exc.map (\(ChunkedResponse ftrs sizes info) -> ((if attachLength then (Header.Header Header.HdrContentLength (show $ sum sizes) :) else id) ftrs, info)) $ chunkedTransferLoop {- we do not sum up the chunk size here since this would result in an inefficient summation from right to left -} chunkedTransferLoop :: (Monad m, Body.C body) => AsynchronousExceptional body m (ChunkedResponse body) chunkedTransferLoop = readLineSwitch $ \line -> case readHex $ Body.toString line of [(size,_)] -> if size == 0 then Exc.map (\strs -> ChunkedResponse (Header.parseManyStraight $ map Body.toString strs) [0] mempty) readTillEmpty2 else Exc.map (\block -> ChunkedResponse [] [0] block) (readBlock size) `mappend` Async.ExceptionalT ((liftM (\newLineE -> mplus (Async.exception newLineE) (toMaybe (not $ Body.isLineTerm $ Async.result newLineE) (ErrorParse $ "no CR+LF after chunk"))) $ Async.runExceptionalT (readBlock 2)) {- less efficient since it reads an entire line (liftM (\newLineE -> mplus (Async.exception newLineE) (let newLine = Async.result newLineE in toMaybe (not $ Body.isLineTerm newLine) -- (ErrorParse $ "junk after chunk: " ++ show newLine) (ErrorParse $ "no CR+LF after chunk") )) readLine) -} `Async.continueM` Async.runExceptionalT (Exc.map forceCR chunkedTransferLoop)) _ -> {- old implementation continued reading anyway in this case as if the Chunk length was 0 -} Async.throwMonoidT (ErrorParse $ "Chunk-Length is not a number: " ++ show (Body.toString line)) -- | Maybe in the future we will have a sensible thing -- to do here, at that time we might want to change -- the name. uglyDeathTransfer :: (Monad m, Monoid body) => AsynchronousExceptional body m ([Header.T],body) uglyDeathTransfer = Async.throwMonoidT $ ErrorParse "Unknown Transfer-Encoding" -- * helpers for parsing header -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: (Monad m, Body.C body) => AsynchronousExceptional body m [body] readTillEmpty1 = readLineSwitch $ \s -> if Body.isLineTerm s then readTillEmpty1 else Exc.map (s:) readTillEmpty2 -- | 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 :: (Monad m, Body.C body) => AsynchronousExceptional body m [body] readTillEmpty2 = readLineSwitch $ \s -> if Body.isLineTerm s || Body.isEmpty s then mempty else Exc.map (s:) readTillEmpty2 {- | Read the next line and feed it to an action. If the read line ends with an exception, the subsequent action is not executed. Thus readLine is handled strictly. -} readLineSwitch :: (Monad m, Monoid a) => (body -> AsynchronousExceptional body m a) -> AsynchronousExceptional body m a readLineSwitch next = Async.bindT readLine next {- strict variant do lineE <- readLine maybe (next (Async.result lineE)) (return . Async.throwMonoid) (Async.exception lineE) -} {- lazy variant do lineE <- readLine cont <- next (Async.result lineE) return (Async.continue (Async.exception lineE) cont) -}