diff --git a/http-monad.cabal b/http-monad.cabal --- a/http-monad.cabal +++ b/http-monad.cabal @@ -1,5 +1,5 @@ Name: http-monad -Version: 0.0.1 +Version: 0.1 Cabal-Version: >= 1.6 Build-type: Simple License: BSD3 @@ -9,7 +9,7 @@ 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 +Synopsis: Monad abstraction for HTTP allowing lazy transfer and non-I/O simulation Description: This library implements a monad class with various interesting instances: . @@ -30,7 +30,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/http-monad/ - tag: 0.0.1 + tag: 0.0.2 Flag splitBase description: Old, monolithic base @@ -59,8 +59,8 @@ 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: transformers >=0.2 && <0.3 + Build-depends: explicit-exception >=0.1.4 && <0.2 Build-depends: utility-ht >=0.0.4 && <0.1 Build-depends: lazyio >=0.0.2 && <0.1 diff --git a/src/Network/Monad/Exception.hs b/src/Network/Monad/Exception.hs --- a/src/Network/Monad/Exception.hs +++ b/src/Network/Monad/Exception.hs @@ -14,12 +14,25 @@ import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync +import Control.Applicative (WrappedMonad(WrapMonad), unwrapMonad, ) import Control.Monad (liftM, ) import Data.Monoid (Monoid, mappend, ) +import Prelude hiding (map, ) + type AsyncExceptionalT e m a = m (Async.Exceptional e a) + +-- in contrast to 'fmap' it does require Monad instance, not Functor +map :: + (Monad m) => + (a -> b) -> + Async.ExceptionalT body m a -> Async.ExceptionalT body m b +map f = + Async.mapExceptionalT unwrapMonad . + fmap f . + Async.mapExceptionalT WrapMonad infixr 1 `bind`, `append`, `continue` diff --git a/src/Network/Monad/HTTP.hs b/src/Network/Monad/HTTP.hs --- a/src/Network/Monad/HTTP.hs +++ b/src/Network/Monad/HTTP.hs @@ -27,7 +27,7 @@ Response(..), ResponseData, ResponseCode, ) import Network.Monad.Reader (readLine, readBlock, writeBlock, ) -import Control.Monad.Trans (lift, ) +import Control.Monad.Trans.Class (lift, ) import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync @@ -47,7 +47,7 @@ Sync.ExceptionalT ConnError (StreamMonad.T body m) a type AsynchronousExceptional body m a = - (StreamMonad.T body m) (Async.Exceptional ConnError a) + Async.ExceptionalT ConnError (StreamMonad.T body m) a @@ -178,7 +178,8 @@ 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 + 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 = @@ -226,7 +227,8 @@ ExpectEntity -> let tc = Header.lookup Header.HdrTransferEncoding hdrs cl = Header.lookup Header.HdrContentLength hdrs - in lift $ assembleHeaderBody (Response cd rn) hdrs $ + in lift $ Async.runExceptionalT $ + assembleHeaderBody (Response cd rn) hdrs $ case tc of Nothing -> case cl of @@ -268,13 +270,14 @@ receive = Exc.switchM getRequestHead (\(rm,uri,hdrs) -> return $ Request uri rm hdrs mempty) - (lift . processRequest) + (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)) readTillEmpty1 + 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) @@ -287,7 +290,7 @@ Nothing -> case cl of Just x -> linearTransferStrLen x - Nothing -> return $ Async.pure ([], mempty) + Nothing -> mempty -- hopefulTransfer Just x -> case map toLower (trim x) of @@ -301,8 +304,8 @@ -} 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)) + 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. @@ -324,12 +327,12 @@ linearTransferStrLen ns = case reads ns of [(n,"")] -> linearTransfer n - _ -> return $ Async.throwMonoid $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns + _ -> 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 = - liftM (fmap ((,) [])) $ readBlock n + Exc.map ((,) []) $ readBlock n -- | Used when nothing about data is known, -- Unfortunately waiting for a socket closure @@ -340,9 +343,9 @@ let go = readLineSwitch $ \line -> if Body.isEmpty line - then return $ Async.pure mempty - else liftM (fmap (mappend line)) go - in liftM (fmap ((,) [])) go + then mempty + else Exc.map (mappend line) go + in Exc.map ((,) []) go -- | in contrast to built-in @(,,)@, its mappend implementation is lazy @@ -366,11 +369,11 @@ -} chunkedTransfer :: (Monad m, Body.C body) => Bool -> AsynchronousExceptional body m ([Header.T],body) chunkedTransfer attachLength = - liftM (fmap (\(ChunkedResponse ftrs sizes info) -> + Exc.map (\(ChunkedResponse ftrs sizes info) -> ((if attachLength then (Header.Header Header.HdrContentLength (show $ sum sizes) :) else id) ftrs, - info))) $ + info)) $ chunkedTransferLoop {- we do not sum up the chunk size here @@ -382,20 +385,20 @@ [(size,_)] -> if size == 0 then - liftM - (fmap (\strs -> ChunkedResponse (Header.parseManyStraight $ map Body.toString strs) [0] mempty)) + Exc.map (\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) + 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 -> @@ -408,12 +411,12 @@ )) readLine) -} - `Async.continueM` - liftM (fmap forceCR) chunkedTransferLoop + `Async.continueM` + Async.runExceptionalT (Exc.map forceCR chunkedTransferLoop)) _ -> {- old implementation continued reading anyway in this case as if the Chunk length was 0 -} - return $ Async.throwMonoid + Async.throwMonoidT (ErrorParse $ "Chunk-Length is not a number: " ++ show (Body.toString line)) @@ -422,8 +425,7 @@ -- the name. uglyDeathTransfer :: (Monad m, Monoid body) => AsynchronousExceptional body m ([Header.T],body) uglyDeathTransfer = - return $ - Async.throwMonoid $ + Async.throwMonoidT $ ErrorParse "Unknown Transfer-Encoding" @@ -436,7 +438,7 @@ readLineSwitch $ \s -> if Body.isLineTerm s then readTillEmpty1 - else liftM (fmap (s:)) readTillEmpty2 + else Exc.map (s:) readTillEmpty2 -- | Read lines until an empty line (CRLF), -- also accepts a connection close as end of @@ -447,8 +449,8 @@ readTillEmpty2 = readLineSwitch $ \s -> if Body.isLineTerm s || Body.isEmpty s - then return $ Async.pure [] - else liftM (fmap (s:)) readTillEmpty2 + then mempty + else Exc.map (s:) readTillEmpty2 {- | @@ -459,7 +461,7 @@ -} 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 + Async.bindT readLine next {- strict variant do lineE <- readLine maybe diff --git a/src/Network/Monad/Reader.hs b/src/Network/Monad/Reader.hs --- a/src/Network/Monad/Reader.hs +++ b/src/Network/Monad/Reader.hs @@ -7,7 +7,7 @@ import qualified Network.Stream as Stream import Control.Monad.Trans.Reader (ReaderT, asks, ) -import Control.Monad.Trans (lift, ) +import Control.Monad.Trans.Class (lift, ) import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync @@ -16,24 +16,26 @@ type T body m = ReaderT (Transfer.T m body) m -type SyncExceptional body m a = - Sync.ExceptionalT Stream.ConnError (T body m) a +type SyncExceptional body m = + Sync.ExceptionalT Stream.ConnError (T body m) -type AsyncExceptional body m a = - (T body m) (Async.Exceptional Stream.ConnError a) +type AsyncExceptional body m = + Async.ExceptionalT Stream.ConnError (T body m) {-# INLINE readLine #-} readLine :: (Monad m) => AsyncExceptional body m body readLine = + Async.ExceptionalT $ do action <- asks Transfer.readLine - lift action + lift $ Async.runExceptionalT action {-# INLINE readBlock #-} readBlock :: (Monad m) => Int -> AsyncExceptional body m body readBlock n = + Async.ExceptionalT $ do action <- asks Transfer.readBlock - lift $ action n + lift $ Async.runExceptionalT $ action n {-# INLINE writeBlock #-} writeBlock :: (Monad m) => body -> SyncExceptional body m () diff --git a/src/Network/Monad/Transfer.hs b/src/Network/Monad/Transfer.hs --- a/src/Network/Monad/Transfer.hs +++ b/src/Network/Monad/Transfer.hs @@ -18,21 +18,21 @@ module Network.Monad.Transfer where import qualified Network.Stream as Stream -import Control.Monad.Trans (MonadIO(liftIO), ) -import Control.Monad (liftM, ) +import Control.Monad.IO.Class (MonadIO(liftIO), ) import qualified Control.Monad.Exception.Asynchronous as Async import qualified Control.Monad.Exception.Synchronous as Sync +import Control.Applicative (WrappedMonad(WrapMonad), unwrapMonad, ) -import Data.Monoid (Monoid) +import Data.Monoid (Monoid, ) type SyncExceptional m = Sync.ExceptionalT Stream.ConnError m -type AsyncExceptional m a = - m (Async.Exceptional Stream.ConnError a) +type AsyncExceptional m = + Async.ExceptionalT Stream.ConnError m data T m body = Cons { @@ -49,6 +49,16 @@ liftIOAsync :: (MonadIO io, Monoid a) => IO (Stream.Result a) -> AsyncExceptional io a -liftIOAsync m = - liftM (Async.fromSynchronousMonoid . Sync.fromEither) $ - liftIO m +liftIOAsync = + Async.mapExceptionalT unwrapMonad . + Async.fromSynchronousMonoidT . + Sync.mapExceptionalT WrapMonad . + liftIOSync +{- +liftIOAsync = + Async.ExceptionalT . + liftM (Async.fromSynchronous mempty) . + Sync.runExceptionalT . + liftIOSync +-} +-- Async.fromSynchronousMonoidT . liftIOSync diff --git a/src/Network/Monad/Transfer/ChunkyLazyIO.hs b/src/Network/Monad/Transfer/ChunkyLazyIO.hs --- a/src/Network/Monad/Transfer/ChunkyLazyIO.hs +++ b/src/Network/Monad/Transfer/ChunkyLazyIO.hs @@ -10,7 +10,6 @@ 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 @@ -68,15 +67,14 @@ readBlockChunky :: (TCP.HStream body, Body body) => Int -> TCP.HandleStream body -> Int -> Transfer.AsyncExceptional LazyIO.T body -readBlockChunky chunkSize h n = +readBlockChunky chunkSize h = 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 + then -- we cannot use 'mappend' because 'length str' is needed + do (Transfer.liftIOAsync $ + TCP.readBlock h (min chunkSize todo)) + `Async.bindT` + (\str -> + fmap (mappend str) $ go (max 0 (todo - length str))) + else mempty + in go diff --git a/src/Network/Monad/Transfer/IO.hs b/src/Network/Monad/Transfer/IO.hs --- a/src/Network/Monad/Transfer/IO.hs +++ b/src/Network/Monad/Transfer/IO.hs @@ -5,7 +5,7 @@ import qualified Network.TCP as TCP import Control.Monad.Trans.Reader (ReaderT, runReaderT, ) -import Control.Monad.Trans (MonadIO, ) +import Control.Monad.IO.Class (MonadIO, ) import Data.Monoid (Monoid, ) diff --git a/src/Network/Monad/Transfer/Offline.hs b/src/Network/Monad/Transfer/Offline.hs --- a/src/Network/Monad/Transfer/Offline.hs +++ b/src/Network/Monad/Transfer/Offline.hs @@ -11,7 +11,7 @@ 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 Control.Monad.Trans.Class (lift, ) import qualified Control.Monad.Trans.RWS as RWS @@ -67,6 +67,7 @@ (body -> (a, body)) -> Transfer.AsyncExceptional (T body) a withBuffer f = + Async.ExceptionalT $ {- It is important to run all monadic actions independent from the exceptional case of an empty buffer,