http-monad-0.1: src/Network/Monad/HTTP.hs
{- |
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 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 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)
-}