http-monad (empty) → 0.0.1
raw patch · 14 files changed
+1296/−0 lines, 14 filesdep +HTTPdep +basedep +bytestringsetup-changed
Dependencies added: HTTP, base, bytestring, containers, explicit-exception, httpd-shed, lazyio, network, parsec, transformers, utility-ht
Files
- LICENSE +31/−0
- Setup.lhs +8/−0
- http-monad.cabal +79/−0
- src/Network/Monad/Body.hs +49/−0
- src/Network/Monad/Exception.hs +65/−0
- src/Network/Monad/HTTP.hs +474/−0
- src/Network/Monad/HTTP/Header.hs +235/−0
- src/Network/Monad/Reader.hs +42/−0
- src/Network/Monad/Transfer.hs +54/−0
- src/Network/Monad/Transfer/ChunkyLazyIO.hs +82/−0
- src/Network/Monad/Transfer/IO.hs +24/−0
- src/Network/Monad/Transfer/Offline.hs +96/−0
- src/Network/Monad/Utility.hs +7/−0
- test/Infinity.hs +50/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ http-monad.cabal view
@@ -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 <http@henning-thielemann.de>+Maintainer: Henning Thielemann <http@henning-thielemann.de>+-- 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
+ src/Network/Monad/Body.hs view
@@ -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
+ src/Network/Monad/Exception.hs view
@@ -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
+ src/Network/Monad/HTTP.hs view
@@ -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)+-}
+ src/Network/Monad/HTTP/Header.hs view
@@ -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))+ []
+ src/Network/Monad/Reader.hs view
@@ -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
+ src/Network/Monad/Transfer.hs view
@@ -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
+ src/Network/Monad/Transfer/ChunkyLazyIO.hs view
@@ -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
+ src/Network/Monad/Transfer/IO.hs view
@@ -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
+ src/Network/Monad/Transfer/Offline.hs view
@@ -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)
+ src/Network/Monad/Utility.hs view
@@ -0,0 +1,7 @@+module Network.Monad.Utility where++-- * texts++crlf, sp :: String+crlf = "\r\n"+sp = " "
+ test/Infinity.hs view
@@ -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 $+ "<html>" :+ "<body>" :+ "<ul>" :+ map (\s -> "<li> "++s++" </li>") (items r) +++ "</ul>" :+ "</body>" :+ "</html>" :+ []++{-# 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 ()