diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/http-monad.cabal b/http-monad.cabal new file mode 100644 --- /dev/null +++ b/http-monad.cabal @@ -0,0 +1,79 @@ +Name: http-monad +Version: 0.0.1 +Cabal-Version: >= 1.6 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Category: Network +Copyright: (c) 2009, Henning Thielemann +Author: Henning Thielemann +Maintainer: Henning Thielemann +-- Homepage: http://www.haskell.org/http/ +Synopsis: Monad abstraction for HTTP communication allowing lazy transfer and non-I/O simulation +Description: + This library implements a monad class with various interesting instances: + . + * Lazy I/O allows for fetching documents via HTTP on demand + . + * Non-I/O allows for testing HTTP communication without any IO action + . + By using this monad you can implement HTTP communication in a very general way. + You may add further functionality by adding custom sub-classes. + . + We inherit all content data types from the HTTP-4000 package, + such as String as well as strict and lazy ByteString. + +Source-Repository head + type: darcs + location: http://code.haskell.org/~thielema/http-monad/ + +Source-Repository this + type: darcs + location: http://code.haskell.org/~thielema/http-monad/ + tag: 0.0.1 + +Flag splitBase + description: Old, monolithic base + default: False + +Flag buildTestServer + description: build a small server for testing lazy download + default: False + +Library + Exposed-modules: + Network.Monad.Transfer + Network.Monad.Transfer.IO + Network.Monad.Transfer.Offline + Network.Monad.Transfer.ChunkyLazyIO + Network.Monad.Body + Network.Monad.Reader + Network.Monad.HTTP + Network.Monad.HTTP.Header + Other-modules: + Network.Monad.Exception + Network.Monad.Utility + Hs-Source-Dirs: src + GHC-options: -Wall +-- Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving + Build-depends: HTTP >=4000 && <4001 + Build-depends: network >=2.1 && <3, parsec >=2.1 && <3 + Build-depends: bytestring >=0.9 && <0.10 + Build-depends: transformers >=0.0.1 && <0.2 + Build-depends: explicit-exception >=0.1 && <0.2 + Build-depends: utility-ht >=0.0.4 && <0.1 + Build-depends: lazyio >=0.0.2 && <0.1 + + If flag(splitBase) + Build-depends: base < 3 + Else + Build-depends: base >= 3 && < 5, containers >= 0.1 && <0.3 + + +Executable infinite-httpd + If flag(buildTestServer) + Build-depends: httpd-shed >=0.3 && <0.4 + Else + Buildable: False + Main-is: Infinity.hs + Hs-Source-Dirs: src, test diff --git a/src/Network/Monad/Body.hs b/src/Network/Monad/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Body.hs @@ -0,0 +1,49 @@ +{- | +Module: Network.Monad.Body +Copyright: (c) 2009 Henning Thielemann +License: BSD + +Stability: experimental +Portability: non-portable (not tested) +-} +module Network.Monad.Body (C(..), CharType(..) {- for Transfer.Offline -}) where + +import qualified Network.BufferType as BT + +import Data.Monoid (Monoid, ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Network.Monad.Utility (crlf, ) + + +class Monoid body => C body where + fromString :: String -> body + toString :: body -> String + isLineTerm :: body -> Bool + isEmpty :: body -> Bool + +class CharType char where + fromChar :: Char -> char + toChar :: char -> Char + +instance CharType Char where + fromChar = id + toChar = id + +instance CharType char => C [char] where + fromString = map fromChar + toString = map toChar + isLineTerm = (crlf==) . toString + isEmpty = null + +instance C BS.ByteString where + fromString = BT.buf_fromStr BT.strictBufferOp + toString = BT.buf_toStr BT.strictBufferOp + isLineTerm = BT.buf_isLineTerm BT.strictBufferOp + isEmpty = BT.buf_isEmpty BT.strictBufferOp + +instance C BL.ByteString where + fromString = BT.buf_fromStr BT.lazyBufferOp + toString = BT.buf_toStr BT.lazyBufferOp + isLineTerm = BT.buf_isLineTerm BT.lazyBufferOp + isEmpty = BT.buf_isEmpty BT.lazyBufferOp diff --git a/src/Network/Monad/Exception.hs b/src/Network/Monad/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Exception.hs @@ -0,0 +1,65 @@ +{- | +Module: Network.Monad.Exception +Copyright: (c) 2009 Henning Thielemann +License: BSD + +Stability: experimental +Portability: non-portable (not tested) + + +Functions that might be moved to explicit-exception package +when they prove to be universally useful. +-} +module Network.Monad.Exception where + +import qualified Control.Monad.Exception.Asynchronous as Async +import qualified Control.Monad.Exception.Synchronous as Sync + +import Control.Monad (liftM, ) +import Data.Monoid (Monoid, mappend, ) + + +type AsyncExceptionalT e m a = m (Async.Exceptional e a) + +infixr 1 `bind`, `append`, `continue` + +bind :: (Monad m, Monoid b) => + Sync.ExceptionalT e m a -> (a -> AsyncExceptionalT e m b) -> AsyncExceptionalT e m b +bind x y = + Sync.tryT x >>= \result -> + liftM Async.force + (case result of + Sync.Exception e -> return $ Async.throwMonoid e + Sync.Success s -> y s) + +append :: (Monad m, Monoid a) => Sync.ExceptionalT e m a -> AsyncExceptionalT e m a -> AsyncExceptionalT e m a +append x y = + bind x (\s -> liftM (fmap (mappend s)) y) +{- + liftM2 + (\x0 y0 -> Async.fromSynchronousMonoid x0 `Async.append` y0) + (Sync.tryT x) y +-} + +continue :: (Monad m, Monoid a) => Sync.ExceptionalT e m () -> AsyncExceptionalT e m a -> AsyncExceptionalT e m a +continue x y = + bind x (\_s -> y) +{- + liftM2 + (\x0 y0 -> Sync.getExceptionNull x0 `Async.continue` y0) + (Sync.tryT x) y +-} + + +switch :: Async.Exceptional e a -> (a -> b) -> (a -> Async.Exceptional e b) -> Async.Exceptional e b +switch ea@(Async.Exceptional mea a) exception success = + case mea of + Just _ -> fmap exception ea + Nothing -> success a + +switchM :: (Monad m) => m (Async.Exceptional e a) -> (a -> m b) -> (a -> m (Async.Exceptional e b)) -> m (Async.Exceptional e b) +switchM actA exception success = + do ea@(Async.Exceptional mea a) <- actA + case mea of + Just _ -> Async.mapM exception ea + Nothing -> success a diff --git a/src/Network/Monad/HTTP.hs b/src/Network/Monad/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/HTTP.hs @@ -0,0 +1,474 @@ +{- | +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 (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 = + (StreamMonad.T body m) (Async.Exceptional ConnError 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)) 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 $ 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 . 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)) 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 -> return $ Async.pure ([], 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 = + liftM (fmap (\(_ftrs,bdy) -> make hdrs bdy)) +-- liftM (fmap (\(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 + _ -> return $ Async.throwMonoid $ 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 = + liftM (fmap ((,) [])) $ 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 return $ Async.pure mempty + else liftM (fmap (mappend line)) go + in liftM (fmap ((,) [])) 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 = + liftM (fmap (\(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 + liftM + (fmap (\strs -> ChunkedResponse (Header.parseManyStraight $ map Body.toString strs) [0] mempty)) + readTillEmpty2 + else + liftM (fmap (\block -> ChunkedResponse [] [0] block)) (readBlock size) + `Async.appendM` + (liftM + (\newLineE -> + mplus + (Async.exception newLineE) + (toMaybe + (not $ Body.isLineTerm $ Async.result newLineE) + (ErrorParse $ "no CR+LF after chunk"))) $ + 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` + liftM (fmap forceCR) chunkedTransferLoop + _ -> + {- old implementation continued reading anyway in this case + as if the Chunk length was 0 -} + return $ Async.throwMonoid + (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 = + return $ + Async.throwMonoid $ + 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 liftM (fmap (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 return $ Async.pure [] + else liftM (fmap (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 = + Exc.bind (Sync.ExceptionalT $ liftM Async.toSynchronous 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) +-} diff --git a/src/Network/Monad/HTTP/Header.hs b/src/Network/Monad/HTTP/Header.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/HTTP/Header.hs @@ -0,0 +1,235 @@ +{- | +Module: Network.Monad.HTTP.Header +Copyright: (c) 2009 Henning Thielemann +License: BSD + +Stability: experimental +Portability: non-portable (not tested) + +Provide the functionality of "Network.HTTP.Headers" +with qualified identifier style. +-} +module Network.Monad.HTTP.Header ( + Hdrs.HasHeaders(..), + T, Hdrs.Header(..), cons, + Name, Hdrs.HeaderName(..), consName, + getName, getValue, + setMany, getMany, modifyMany, + insert, insertMany, + insertIfMissing, + retrieveMany, + replace, + find, findMany, lookup, + parse, + parseManyWarn, + parseManyStraight, + dictionary, + matchName, + ) where + +import qualified Network.HTTP.Headers as Hdrs +import Network.HTTP.Headers (HasHeaders(..), ) +import Data.String.HT (trim, ) + +import qualified Control.Monad.Exception.Synchronous as Sync + +import qualified Data.Map as Map + +import Data.Char (toLower, ) +import Data.Tuple.HT (mapFst, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (mapMaybe, listToMaybe, ) + +import Prelude hiding (lookup, ) + + +type T = Hdrs.Header +type Name = Hdrs.HeaderName + + +{- +class IsHeader h where + toHeader :: h -> Hdrs.Header + fromHeader :: Hdrs.Header -> h + +instance IsHeader Hdrs.Header where + toHeader = id + fromHeader = id + +instance IsHeader h => HasHeaders [h] where + setHeaders _ = map fromHeader + getHeaders = map toHeader +-} + + +cons :: Name -> String -> T +cons = Hdrs.Header + +-- an Accessor would be even nicer +getName :: T -> Name +getName (Hdrs.Header name _value) = name + +getValue :: T -> String +getValue (Hdrs.Header _name value) = value + + +dictionary :: Map.Map String Name +dictionary = + Map.fromList $ + map (mapFst (map toLower)) $ + ("Cache-Control" , Hdrs.HdrCacheControl ) : + ("Connection" , Hdrs.HdrConnection ) : + ("Date" , Hdrs.HdrDate ) : + ("Pragma" , Hdrs.HdrPragma ) : + ("Transfer-Encoding" , Hdrs.HdrTransferEncoding ) : + ("Upgrade" , Hdrs.HdrUpgrade ) : + ("Via" , Hdrs.HdrVia ) : + ("Accept" , Hdrs.HdrAccept ) : + ("Accept-Charset" , Hdrs.HdrAcceptCharset ) : + ("Accept-Encoding" , Hdrs.HdrAcceptEncoding ) : + ("Accept-Language" , Hdrs.HdrAcceptLanguage ) : + ("Authorization" , Hdrs.HdrAuthorization ) : + ("From" , Hdrs.HdrFrom ) : + ("Host" , Hdrs.HdrHost ) : + ("If-Modified-Since" , Hdrs.HdrIfModifiedSince ) : + ("If-Match" , Hdrs.HdrIfMatch ) : + ("If-None-Match" , Hdrs.HdrIfNoneMatch ) : + ("If-Range" , Hdrs.HdrIfRange ) : + ("If-Unmodified-Since" , Hdrs.HdrIfUnmodifiedSince ) : + ("Max-Forwards" , Hdrs.HdrMaxForwards ) : + ("Proxy-Authorization" , Hdrs.HdrProxyAuthorization) : + ("Range" , Hdrs.HdrRange ) : + ("Referer" , Hdrs.HdrReferer ) : + ("User-Agent" , Hdrs.HdrUserAgent ) : + ("Age" , Hdrs.HdrAge ) : + ("Location" , Hdrs.HdrLocation ) : + ("Proxy-Authenticate" , Hdrs.HdrProxyAuthenticate ) : + ("Public" , Hdrs.HdrPublic ) : + ("Retry-After" , Hdrs.HdrRetryAfter ) : + ("Server" , Hdrs.HdrServer ) : + ("Vary" , Hdrs.HdrVary ) : + ("Warning" , Hdrs.HdrWarning ) : + ("WWW-Authenticate" , Hdrs.HdrWWWAuthenticate ) : + ("Allow" , Hdrs.HdrAllow ) : + ("Content-Base" , Hdrs.HdrContentBase ) : + ("Content-Encoding" , Hdrs.HdrContentEncoding ) : + ("Content-Language" , Hdrs.HdrContentLanguage ) : + ("Content-Length" , Hdrs.HdrContentLength ) : + ("Content-Location" , Hdrs.HdrContentLocation ) : + ("Content-MD5" , Hdrs.HdrContentMD5 ) : + ("Content-Range" , Hdrs.HdrContentRange ) : + ("Content-Type" , Hdrs.HdrContentType ) : + ("ETag" , Hdrs.HdrETag ) : + ("Expires" , Hdrs.HdrExpires ) : + ("Last-Modified" , Hdrs.HdrLastModified ) : + ("Set-Cookie" , Hdrs.HdrSetCookie ) : + ("Cookie" , Hdrs.HdrCookie ) : + ("Expect" , Hdrs.HdrExpect ) : + [] + + + +setMany :: (HasHeaders x) => x -> [T] -> x +setMany = Hdrs.setHeaders + +getMany :: (HasHeaders x) => x -> [T] +getMany = Hdrs.getHeaders + +modifyMany :: (HasHeaders x) => ([T] -> [T]) -> x -> x +modifyMany f x = + setMany x $ f $ getMany x + + +consName :: String -> Name +consName k = + Map.findWithDefault (Hdrs.HdrCustom k) (map toLower k) dictionary + + +-- Header manipulation functions +insert, replace, insertIfMissing :: HasHeaders a => + Name -> String -> a -> a + + +-- | Inserts a header with the given name and value. +-- Allows duplicate header names. +insert name value = modifyMany (cons name value :) + +-- | Adds the new header only if no previous header shares +-- the same name. +insertIfMissing name value = + let newHeaders list@(h : rest) = + if matchName name h + then list + else h : newHeaders rest + newHeaders [] = [cons name value] + in modifyMany newHeaders + +-- | Removes old headers with duplicate name. +replace name value = + modifyMany $ + (cons name value :) . + filter (not . matchName name) + +-- | Inserts multiple headers. +insertMany :: HasHeaders a => [T] -> a -> a +insertMany hdrs = modifyMany (++ hdrs) + +-- | Gets a list of headers with a particular 'Name'. +retrieveMany :: HasHeaders a => Name -> a -> [T] +retrieveMany name = filter (matchName name) . getMany + +matchName :: Name -> T -> Bool +matchName name h = name == getName h + + +-- | Lookup presence of specific Name in a list of Headers +-- Returns the value from the first matching header. +find :: HasHeaders a => Name -> a -> Maybe String +find n = listToMaybe . findMany n + +findMany :: HasHeaders a => Name -> a -> [String] +findMany n = + mapMaybe (\h -> toMaybe (matchName n h) (getValue h)) . + getMany + +{-# DEPRECATED lookup "Call 'find' using the [Header] instance of HasHeaders" #-} +lookup :: Name -> [T] -> Maybe String +lookup n = + listToMaybe . + mapMaybe (\h -> toMaybe (matchName n h) (getValue h)) + + +parse :: String -> Sync.Exceptional String T +parse str = + case break (':'==) str of + (k,':':v) -> Sync.Success $ cons (consName k) (trim v) + _ -> Sync.Exception $ "Unable to parse header: " ++ str + + +parseManyWarn :: [String] -> [Sync.Exceptional String T] +parseManyWarn = + let clean = map (\h -> if h `elem` "\t\r\n" then ' ' else h) + in map (parse . clean) . joinExtended + +parseManyStraight :: [String] -> [T] +parseManyStraight = + {- mapM (strict on errors) vs. catMaybes (tolerant of errors)? + Should parse errors here be reported or ignored? + Currently ignored. -} + mapMaybe (either (const Nothing) Just . Sync.toEither) . + parseManyWarn + +-- | Joins consecutive lines where the second line +-- begins with ' ' or '\t'. +joinExtended :: [String] -> [String] +joinExtended = + foldr + (\h0 next -> + uncurry (:) $ + mapFst (h0++) $ + let join line rest = (' ' : line, rest) + in case next of + ((' ' :line):rest) -> join line rest + (('\t':line):rest) -> join line rest + _ -> ("", next)) + [] diff --git a/src/Network/Monad/Reader.hs b/src/Network/Monad/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Reader.hs @@ -0,0 +1,42 @@ +{- | +Provide the explicit class dictionary as context via a Reader monad. +-} +module Network.Monad.Reader where + +import qualified Network.Monad.Transfer as Transfer + +import qualified Network.Stream as Stream +import Control.Monad.Trans.Reader (ReaderT, asks, ) +import Control.Monad.Trans (lift, ) + +import qualified Control.Monad.Exception.Asynchronous as Async +import qualified Control.Monad.Exception.Synchronous as Sync + + + +type T body m = ReaderT (Transfer.T m body) m + +type SyncExceptional body m a = + Sync.ExceptionalT Stream.ConnError (T body m) a + +type AsyncExceptional body m a = + (T body m) (Async.Exceptional Stream.ConnError a) + + +{-# INLINE readLine #-} +readLine :: (Monad m) => AsyncExceptional body m body +readLine = + do action <- asks Transfer.readLine + lift action + +{-# INLINE readBlock #-} +readBlock :: (Monad m) => Int -> AsyncExceptional body m body +readBlock n = + do action <- asks Transfer.readBlock + lift $ action n + +{-# INLINE writeBlock #-} +writeBlock :: (Monad m) => body -> SyncExceptional body m () +writeBlock body = + do action <- lift $ asks Transfer.writeBlock + Sync.mapExceptionalT lift $ action body diff --git a/src/Network/Monad/Transfer.hs b/src/Network/Monad/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Transfer.hs @@ -0,0 +1,54 @@ +{- | +Module : Network.Monad.Class +Copyright : (c) Henning Thielemann, 2009 +License : BSD + +Maintainer : http@henning-thielemann.de +Stability : experimental +Portability : non-portable (not tested) + + +With this monad we abstract from the IO monad, +which also allows us to process data lazily or offline. +-} + +{- How to use ByteString: +http://nominolo.blogspot.com/2007/05/networkhttp-bytestrings.html +-} +module Network.Monad.Transfer where + +import qualified Network.Stream as Stream +import Control.Monad.Trans (MonadIO(liftIO), ) +import Control.Monad (liftM, ) + +import qualified Control.Monad.Exception.Asynchronous as Async +import qualified Control.Monad.Exception.Synchronous as Sync + +import Data.Monoid (Monoid) + + + +type SyncExceptional m = + Sync.ExceptionalT Stream.ConnError m + +type AsyncExceptional m a = + m (Async.Exceptional Stream.ConnError a) + +data T m body = + Cons { + readLine :: AsyncExceptional m body, + readBlock :: Int -> AsyncExceptional m body, + writeBlock :: body -> SyncExceptional m () + } + + +liftIOSync :: MonadIO io => + IO (Stream.Result a) -> SyncExceptional io a +liftIOSync m = + Sync.fromEitherT $ liftIO m + +liftIOAsync :: (MonadIO io, Monoid a) => + IO (Stream.Result a) -> AsyncExceptional io a +liftIOAsync m = + liftM (Async.fromSynchronousMonoid . Sync.fromEither) $ + liftIO m diff --git a/src/Network/Monad/Transfer/ChunkyLazyIO.hs b/src/Network/Monad/Transfer/ChunkyLazyIO.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Transfer/ChunkyLazyIO.hs @@ -0,0 +1,82 @@ +module Network.Monad.Transfer.ChunkyLazyIO ( + Body(length), + transfer, + run, + ) where + +import qualified Network.Monad.Transfer as Transfer +import qualified Network.Monad.Reader as Reader +import qualified Network.Monad.Body as Body + +import qualified Network.TCP as TCP +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ) +import Control.Monad (liftM, ) + +import qualified Control.Monad.Exception.Asynchronous as Async + +import qualified System.IO.Lazy as LazyIO +import Data.Monoid (Monoid, mempty, mappend, ) + +import qualified Data.List as List + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +import Prelude hiding (length, ) + + + +class Body.C body => Body body where + length :: body -> Int + +instance Body.CharType char => Body [char] where + length = List.length + +instance Body BS.ByteString where + length = BS.length + +{- +@fromIntegral@ converts from Int64 to Int which is dangerous in general +but in our case, +since we only use it to check the length of actually read data +that is never more than 2^31 because that's the maximum possible chunk size. +-} +instance Body BL.ByteString where + length = fromIntegral . BL.length + + + +transfer :: (TCP.HStream body, Body body) => + Int {-^ chunk size, only relevant for 'Transfer.readBlock'. -} -> + TCP.HandleStream body -> + Transfer.T LazyIO.T body +transfer chunkSize h = + Transfer.Cons { + Transfer.readLine = Transfer.liftIOAsync $ TCP.readLine h, + Transfer.readBlock = \n -> readBlockChunky chunkSize h n, + Transfer.writeBlock = \str -> Transfer.liftIOSync $ TCP.writeBlock h str + } + +run :: (TCP.HStream body, Body body) => + Reader.T body LazyIO.T a + {-^ dictionary for read and write methods -} -> + Int {-^ chunk size -} -> + TCP.HandleStream body -> + IO a +run m chunkSize h = LazyIO.run $ runReaderT m $ transfer chunkSize h + + +readBlockChunky :: (TCP.HStream body, Body body) => + Int -> TCP.HandleStream body -> Int -> Transfer.AsyncExceptional LazyIO.T body +readBlockChunky chunkSize h n = + let go todo = + if todo>0 + then -- we cannot use Async.appendM because 'length str' is needed + do ~(Async.Exceptional e str) <- + Transfer.liftIOAsync $ + TCP.readBlock h (min chunkSize todo) + liftM (fmap (mappend str)) $ + maybe (go (max 0 (todo - length str))) + (return . Async.throwMonoid) e + else return $ Async.pure mempty + in go n diff --git a/src/Network/Monad/Transfer/IO.hs b/src/Network/Monad/Transfer/IO.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Transfer/IO.hs @@ -0,0 +1,24 @@ +module Network.Monad.Transfer.IO where + +import qualified Network.Monad.Transfer as Transfer +import qualified Network.Monad.Reader as Reader + +import qualified Network.TCP as TCP +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ) +import Control.Monad.Trans (MonadIO, ) + +import Data.Monoid (Monoid, ) + + +transfer :: (TCP.HStream body, Monoid body, MonadIO io) => + TCP.HandleStream body -> Transfer.T io body +transfer h = + Transfer.Cons { + Transfer.readLine = Transfer.liftIOAsync $ TCP.readLine h, + Transfer.readBlock = \n -> Transfer.liftIOAsync $ TCP.readBlock h n, + Transfer.writeBlock = \str -> Transfer.liftIOSync $ TCP.writeBlock h str + } + +run :: (TCP.HStream body, Monoid body, MonadIO io) => + Reader.T body io a -> TCP.HandleStream body -> io a +run m h = runReaderT m $ transfer h diff --git a/src/Network/Monad/Transfer/Offline.hs b/src/Network/Monad/Transfer/Offline.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Transfer/Offline.hs @@ -0,0 +1,96 @@ +{- | +Transfer type without IO interaction. +Optimal for testing. +-} +module Network.Monad.Transfer.Offline where + +import qualified Network.Monad.Transfer as Transfer +import qualified Network.Monad.Reader as Reader +import qualified Network.Monad.Body as Body + +import qualified Network.Stream as Stream +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ) +import Control.Monad.Trans.RWS (RWS, runRWS, tell, ) +import Control.Monad.Trans (lift, ) + +import qualified Control.Monad.Trans.RWS as RWS + +import qualified Control.Monad.Exception.Asynchronous as Async +-- import qualified Control.Monad.Exception.Synchronous as Sync + +import Data.Char (chr, ) + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import Data.Maybe.HT (toMaybe, ) +import Data.Tuple.HT (forcePair, mapFst, ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +import Prelude hiding (splitAt, ) + + + +type T body = RWS Stream.ConnError [body] body + + +class Body.C body => Body body where + splitAt :: Int -> body -> (body, body) + breakAfter :: (Char -> Bool) -> body -> (body, body) + +instance Body.CharType char => Body [char] where + splitAt = List.splitAt + breakAfter p = ListHT.breakAfter (p . Body.toChar) + +instance Body BS.ByteString where + splitAt = BS.splitAt + breakAfter p s = + forcePair $ + maybe (s,BS.empty) + (\i -> splitAt (i+1) s) + (BS.findIndex (p . chr . fromIntegral) s) + +instance Body BL.ByteString where + splitAt = BL.splitAt . fromIntegral + breakAfter p s = + let (prefix,suffix) = + BL.break (p . chr . fromIntegral) s + in forcePair $ + maybe + (prefix,suffix) + (mapFst (BL.snoc prefix)) + (BL.uncons suffix) + + +withBuffer :: (Body.C body) => + (body -> (a, body)) -> + Transfer.AsyncExceptional (T body) a +withBuffer f = + {- + It is important to run all monadic actions + independent from the exceptional case of an empty buffer, + because only this way it is clear to the run-time system, + that there is no write action. + This in turn is important for a maximum of laziness. + -} + do buf <- RWS.get + let (block,rest) = f buf + RWS.put rest + closeReason <- RWS.ask + return $ + Async.Exceptional (toMaybe (Body.isEmpty rest) closeReason) block + + +transfer :: (Body body) => + Transfer.T (T body) body +transfer = + Transfer.Cons { + Transfer.readBlock = \n -> withBuffer $ splitAt n, + Transfer.readLine = withBuffer $ breakAfter ('\n'==), + Transfer.writeBlock = \str -> lift $ tell [str] + } + +run :: (Body body) => + Reader.T body (T body) a -> Stream.ConnError -> body -> (a, body, [body]) +run m = runRWS (runReaderT m $ transfer) diff --git a/src/Network/Monad/Utility.hs b/src/Network/Monad/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monad/Utility.hs @@ -0,0 +1,7 @@ +module Network.Monad.Utility where + +-- * texts + +crlf, sp :: String +crlf = "\r\n" +sp = " " diff --git a/test/Infinity.hs b/test/Infinity.hs new file mode 100644 --- /dev/null +++ b/test/Infinity.hs @@ -0,0 +1,50 @@ +{- | +It's important that the content is generated by functions (with dummy arguments) +which are also inlined. +Otherwise GHC buffers their content and runs into heap exhaustion. +-} +module Main where + +import qualified Network.Shed.Httpd as HTTP + + +{-# INLINE items #-} +items :: HTTP.Request -> [String] +items (HTTP.Request{}) = + map show $ iterate ((1::Integer)+) 0 + +{-# INLINE text #-} +text :: HTTP.Request -> String +text r = + concat $ + "" : + "" : + "" : + "" : + "" : + [] + +{-# INLINE response #-} +response :: HTTP.Request -> HTTP.Response +response r = + HTTP.Response 200 + (("Content-Type", "text/html") : + []) + (text r) + + +mainText :: IO () +mainText = + HTTP.initServerLazy 1000 8080 + (const (return (HTTP.Response 200 + (("Content-Type", "text/plain") : + []) + (cycle "bla")))) + >> return () + +main :: IO () +main = + HTTP.initServerLazy 1000 8080 (return . response) + >> return ()