Browse files

Needs cleanup, but compiles now with builder definition

  • Loading branch information...
1 parent 7f65679 commit 1e1a266af4518f71e883ea3162d59142deecc2bc @gregorycollins gregorycollins committed Dec 22, 2010
View
27 src/Snap/Internal/Http/Types.hs
@@ -57,7 +57,7 @@ import Foreign.C.String
------------------------------------------------------------------------------
import Data.CIByteString
-import Snap.Iteratee (Enumerator)
+import Snap.Iteratee (Enumerator, ($$), (>>==))
import qualified Snap.Iteratee as I
@@ -174,7 +174,7 @@ type Params = Map ByteString [ByteString]
-- request type
------------------------------------------------------------------------------
--- | An existential wrapper for the 'Enumerator' type
+-- | An existential wrapper for the 'Enumerator ByteString IO a' type
data SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a)
@@ -351,8 +351,8 @@ instance HasHeaders Headers where
-- response type
------------------------------------------------------------------------------
-data ResponseBody = Enum (forall a . Enumerator ByteString IO a)
- -- ^ output body is enumerator
+data ResponseBody = Enum (forall a . Enumerator Builder IO a)
+ -- ^ output body is a 'Builder' enumerator
| SendFile FilePath (Maybe (Int64,Int64))
-- ^ output body is sendfile(), optional second argument
@@ -361,17 +361,19 @@ data ResponseBody = Enum (forall a . Enumerator ByteString IO a)
------------------------------------------------------------------------------
rspBodyMap :: (forall a .
- Enumerator ByteString IO a -> Enumerator ByteString IO a)
+ Enumerator Builder IO a -> Enumerator Builder IO a)
-> ResponseBody
-> ResponseBody
rspBodyMap f b = Enum $ f $ rspBodyToEnum b
+
------------------------------------------------------------------------------
-rspBodyToEnum :: ResponseBody -> Enumerator ByteString IO a
+rspBodyToEnum :: ResponseBody -> Enumerator Builder IO a
rspBodyToEnum (Enum e) = e
-rspBodyToEnum (SendFile fp Nothing) = I.enumFile fp
-rspBodyToEnum (SendFile fp (Just s)) = I.enumFilePartial fp s
+rspBodyToEnum (SendFile fp Nothing) = I.mapEnum fromByteString $ I.enumFile fp
+rspBodyToEnum (SendFile fp (Just s)) = I.mapEnum fromByteString $
+ I.enumFilePartial fp s
------------------------------------------------------------------------------
@@ -466,13 +468,14 @@ rqSetParam k v = rqModifyParams $ Map.insert k v
-- | An empty 'Response'.
emptyResponse :: Response
-emptyResponse = Response Map.empty Map.empty (1,1) Nothing (Enum (I.enumBS ""))
+emptyResponse = Response Map.empty Map.empty (1,1) Nothing
+ (Enum (I.enumBuilder mempty))
200 "OK" False
------------------------------------------------------------------------------
-- | Sets an HTTP response body to the given 'Enumerator' value.
-setResponseBody :: (forall a . Enumerator ByteString IO a)
+setResponseBody :: (forall a . Enumerator Builder IO a)
-- ^ new response body enumerator
-> Response -- ^ response to modify
-> Response
@@ -505,8 +508,8 @@ setResponseCode s r = setResponseStatus s reason r
------------------------------------------------------------------------------
-- | Modifies a response body.
-modifyResponseBody :: (forall a . Enumerator ByteString IO a
- -> Enumerator ByteString IO a)
+modifyResponseBody :: (forall a . Enumerator Builder IO a
+ -> Enumerator Builder IO a)
-> Response
-> Response
modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }
View
53 src/Snap/Internal/Iteratee/Debug.hs
@@ -11,21 +11,29 @@
module Snap.Internal.Iteratee.Debug
( debugIteratee
, iterateeDebugWrapper
+ , iterateeDebugWrapperWith
+ , showBuilder
) where
------------------------------------------------------------------------------
-import Control.Monad.Trans
-import Data.ByteString (ByteString)
-import System.IO
+import Blaze.ByteString.Builder
+import Control.Monad.Trans
+import Data.ByteString (ByteString)
+import System.IO
------------------------------------------------------------------------------
#ifndef NODEBUG
import Snap.Internal.Debug
#endif
-import Snap.Iteratee
+import Snap.Iteratee hiding (map)
------------------------------------------------------------------------------
------------------------------------------------------------------------------
+showBuilder :: Builder -> String
+showBuilder = show . toByteString
+
+
+------------------------------------------------------------------------------
debugIteratee :: Iteratee ByteString IO ()
debugIteratee = continue f
where
@@ -42,11 +50,12 @@ debugIteratee = continue f
#ifndef NODEBUG
-iterateeDebugWrapper :: (Show a, MonadIO m) =>
- String
- -> Iteratee a m b
- -> Iteratee a m b
-iterateeDebugWrapper name iter = do
+iterateeDebugWrapperWith :: (MonadIO m) =>
+ (a -> String)
+ -> String
+ -> Iteratee a m b
+ -> Iteratee a m b
+iterateeDebugWrapperWith shower name iter = do
debug $ name ++ ": BEGIN"
step <- lift $ runIteratee iter
whatWasReturn step
@@ -55,7 +64,7 @@ iterateeDebugWrapper name iter = do
where
whatWasReturn (Continue _) = debug $ name ++ ": continue"
whatWasReturn (Yield _ z) = debug $ name ++ ": yield, with remainder "
- ++ show z
+ ++ showStream z
whatWasReturn (Error e) = debug $ name ++ ": error, with " ++ show e
check (Continue k) = continue $ f k
@@ -67,15 +76,35 @@ iterateeDebugWrapper name iter = do
k EOF
f k ch@(Chunks xs) = do
- debug $ name ++ ": got chunk: " ++ show xs
+ debug $ name ++ ": got chunk: " ++ showList xs
step <- lift $ runIteratee $ k ch
whatWasReturn step
check step
+ showStream = show . fmap shower
+ showList = show . map shower
+
+
+iterateeDebugWrapper :: (Show a, MonadIO m) =>
+ String
+ -> Iteratee a m b
+ -> Iteratee a m b
+iterateeDebugWrapper = iterateeDebugWrapperWith show
+
#else
-iterateeDebugWrapper :: String -> Iteratee IO a -> Iteratee IO a
+iterateeDebugWrapperWith :: (MonadIO m) =>
+ (s -> String)
+ -> String
+ -> Iteratee s m a
+ -> Iteratee s m a
+iterateeDebugWrapperWith _ _ = id
+{-# INLINE iterateeDebugWrapperWith #-}
+
+
+iterateeDebugWrapper :: (MonadIO m, Show s) =>
+ String -> Iteratee s m a -> Iteratee s m a
iterateeDebugWrapper _ = id
{-# INLINE iterateeDebugWrapper #-}
View
81 src/Snap/Internal/Types.hs
@@ -10,29 +10,32 @@ module Snap.Internal.Types where
------------------------------------------------------------------------------
import "MonadCatchIO-transformers" Control.Monad.CatchIO
-import Control.Applicative
-import Control.Exception (throwIO, ErrorCall(..))
-import Control.Monad
-import Control.Monad.State
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as S
-import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.CIByteString as CIB
-import Data.Int
-import Data.IORef
-import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy as LT
-import qualified Data.Text.Lazy.Encoding as LT
-import Data.Typeable
-import Prelude hiding (catch, take)
-
-
-------------------------------------------------------------------------------
-import Snap.Internal.Http.Types
-import Snap.Iteratee
-import Snap.Internal.Iteratee.Debug
+import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder.Char.Utf8
+import Control.Applicative
+import Control.Exception (throwIO, ErrorCall(..))
+import Control.Monad
+import Control.Monad.State
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.CIByteString as CIB
+import Data.Int
+import Data.IORef
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import Data.Typeable
+import Prelude hiding (catch, take)
+
+
+------------------------------------------------------------------
+import Snap.Internal.Http.Types
+import Snap.Iteratee
+import Snap.Internal.Iteratee.Debug
------------------------------------------------------------------------------
@@ -239,7 +242,7 @@ getRequestBody = liftM L.fromChunks $ runRequestBody consume
-- if you called 'finishWith'. Make sure you set any content types, headers,
-- cookies, etc. before you call this function.
--
-transformRequestBody :: (forall a . Enumerator ByteString IO a)
+transformRequestBody :: (forall a . Enumerator Builder IO a)
-- ^ the output 'Iteratee' is passed to this
-- 'Enumerator', and then the resulting 'Iteratee' is
-- fed the request body stream. Your 'Enumerator' is
@@ -249,14 +252,16 @@ transformRequestBody trans = do
req <- getRequest
let ioref = rqBody req
senum <- liftIO $ readIORef ioref
- let (SomeEnumerator enum) = senum
+ let (SomeEnumerator enum') = senum
+ let enum = mapEnum fromByteString enum'
liftIO $ writeIORef ioref (SomeEnumerator enumEOF)
origRsp <- getResponse
let rsp = setResponseBody
(\writeEnd -> do
- let i = iterateeDebugWrapper "transformRequestBody"
- $ trans writeEnd
+ let i = iterateeDebugWrapperWith showBuilder
+ "transformRequestBody"
+ $ trans writeEnd
st <- liftIO $ runIteratee i
enum st)
@@ -439,7 +444,7 @@ redirect' target status = do
finishWith
$ setResponseCode status
$ setContentLength 0
- $ modifyResponseBody (const $ enumBS "")
+ $ modifyResponseBody (const $ enumBuilder mempty)
$ setHeader "Location" target r
{-# INLINE redirect' #-}
@@ -457,20 +462,28 @@ logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s)
-- | Adds the output from the given enumerator to the 'Response'
-- stored in the 'Snap' monad state.
addToOutput :: MonadSnap m
- => (forall a . Enumerator ByteString IO a) -- ^ output to add
+ => (forall a . Enumerator Builder IO a) -- ^ output to add
-> m ()
addToOutput enum = modifyResponse $ modifyResponseBody (>==> enum)
------------------------------------------------------------------------------
+-- | Adds the given 'Builder' to the body of the 'Response' stored in the
+-- | 'Snap' monad state.
+writeBuilder :: MonadSnap m => Builder -> m ()
+writeBuilder b = addToOutput $ enumBuilder b
+{-# INLINE writeBuilder #-}
+
+
+------------------------------------------------------------------------------
-- | Adds the given strict 'ByteString' to the body of the 'Response' stored
-- in the 'Snap' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
writeBS :: MonadSnap m => ByteString -> m ()
-writeBS s = addToOutput $ enumBS s
+writeBS s = writeBuilder $ fromByteString s
------------------------------------------------------------------------------
@@ -481,7 +494,7 @@ writeBS s = addToOutput $ enumBS s
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
writeLBS :: MonadSnap m => L.ByteString -> m ()
-writeLBS s = addToOutput $ enumLBS s
+writeLBS s = writeBuilder $ fromLazyByteString s
------------------------------------------------------------------------------
@@ -492,7 +505,7 @@ writeLBS s = addToOutput $ enumLBS s
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
writeText :: MonadSnap m => T.Text -> m ()
-writeText s = writeBS $ T.encodeUtf8 s
+writeText s = writeBuilder $ fromText s
------------------------------------------------------------------------------
@@ -503,7 +516,7 @@ writeText s = writeBS $ T.encodeUtf8 s
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
writeLazyText :: MonadSnap m => LT.Text -> m ()
-writeLazyText s = writeLBS $ LT.encodeUtf8 s
+writeLazyText s = writeBuilder $ fromLazyText s
------------------------------------------------------------------------------
@@ -679,7 +692,7 @@ runSnap (Snap m) logerr req = do
where
fourohfour = setContentLength 3 $
setResponseStatus 404 "Not Found" $
- modifyResponseBody (>==> enumBS "404") $
+ modifyResponseBody (>==> enumBuilder (fromByteString "404")) $
emptyResponse
dresp = emptyResponse { rspHttpVersion = rqVersion req }
View
45 src/Snap/Iteratee.hs
@@ -17,6 +17,7 @@ module Snap.Iteratee
-- * Enumerators
enumBS
, enumLBS
+ , enumBuilder
, enumFile
, enumFilePartial
, InvalidRangeException
@@ -33,6 +34,8 @@ module Snap.Iteratee
, takeExactly
, takeNoMoreThan
, skipToEof
+ , mapEnum
+ , mapIter
, TooManyBytesReadException
, ShortWriteException
@@ -103,6 +106,7 @@ import Prelude hiding (catch,drop)
-}
+import Blaze.ByteString.Builder
import Control.DeepSeq
import Control.Exception (SomeException, assert)
import Control.Monad
@@ -113,6 +117,7 @@ import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Enumerator hiding (drop)
+import qualified Data.Enumerator as I
import Data.Enumerator.IO (enumHandle)
import Data.List (foldl')
import Data.Monoid (mappend)
@@ -154,11 +159,16 @@ streamLength EOF = 0
------------------------------------------------------------------------------
+-- | Enumerates a Builder.
+enumBuilder :: (Monad m) => Builder -> Enumerator Builder m a
+enumBuilder = enumList 1 . (:[])
+{-# INLINE enumBuilder #-}
+
+
+------------------------------------------------------------------------------
-- | Enumerates a strict bytestring.
enumBS :: (Monad m) => ByteString -> Enumerator ByteString m a
-enumBS bs (Continue k) = k (Chunks [bs])
-enumBS bs (Yield x s) = Iteratee $ return $ Yield x (s `mappend` Chunks [bs])
-enumBS _ (Error e) = Iteratee $ return $ Error e
+enumBS = enumList 1 . (:[])
{-# INLINE enumBS #-}
@@ -628,3 +638,32 @@ enumFilePartial fp rng@(start,end) st@(Continue k) = do
S.drop (fromEnum start) s ]
#endif
+
+
+------------------------------------------------------------------------------
+mapIter :: (Monad m) =>
+ (aOut -> aIn)
+ -> Iteratee aOut m a
+ -> Iteratee aIn m a
+mapIter f iter = iter >>== check
+ where
+ check (Continue k) = k EOF >>== \s -> case s of
+ Continue _ -> error "divergent iteratee"
+ _ -> check s
+ check (Yield x rest) = yield x (fmap f rest)
+ check (Error e) = throwError e
+
+
+------------------------------------------------------------------------------
+mapEnum :: (Monad m) =>
+ (aOut -> aIn)
+ -> Enumerator aOut m a
+ -> Enumerator aIn m a
+mapEnum f enum builderStep = do
+ -- z :: Iteratee ByteString m (Step Builder m a)
+ let z = I.map f builderStep
+ -- p :: Iteratee ByteString m a
+ let p = joinI z
+ -- q :: Iteratee ByteString m a
+ let q = enum $$ p
+ mapIter f q
View
1 src/Snap/Types.hs
@@ -110,6 +110,7 @@ module Snap.Types
, setResponseBody
, modifyResponseBody
, addToOutput
+ , writeBuilder
, writeBS
, writeLazyText
, writeText
View
2 src/Snap/Util/FileServe.hs
@@ -424,7 +424,7 @@ checkRangeReq req fp sz = do
. deleteHeader "Content-Type"
. deleteHeader "Content-Encoding"
. deleteHeader "Transfer-Encoding"
- . setResponseBody (enumBS "")
+ . setResponseBody (enumBuilder mempty)
return True
View
64 src/Snap/Util/GZip.hs
@@ -8,27 +8,29 @@ module Snap.Util.GZip
( withCompression
, withCompression' ) where
-import qualified Codec.Compression.GZip as GZip
-import qualified Codec.Compression.Zlib as Zlib
-import Control.Concurrent
-import Control.Applicative hiding (many)
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans
-import Data.Attoparsec.Char8 hiding (Done)
-import qualified Data.ByteString.Lazy.Char8 as L
-import Data.ByteString.Char8 (ByteString)
-import Data.Maybe
-import qualified Data.Set as Set
-import Data.Set (Set)
-import Data.Typeable
-import Prelude hiding (catch, takeWhile)
-
-------------------------------------------------------------------------------
-import Snap.Internal.Debug
-import Snap.Internal.Parsing
-import Snap.Iteratee
-import Snap.Types
+import Blaze.ByteString.Builder
+import qualified Codec.Compression.GZip as GZip
+import qualified Codec.Compression.Zlib as Zlib
+import Control.Concurrent
+import Control.Applicative hiding (many)
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans
+import Data.Attoparsec.Char8 hiding (Done)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.ByteString.Char8 (ByteString)
+import Data.Maybe
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Typeable
+import Prelude hiding (catch, takeWhile)
+
+----------------------------------------------------------------------------
+import Snap.Internal.Debug
+import Snap.Internal.Parsing
+import Snap.Iteratee
+import qualified Snap.Iteratee as I
+import Snap.Types
------------------------------------------------------------------------------
@@ -155,28 +157,32 @@ compressCompression ce = modifyResponse f
------------------------------------------------------------------------------
-- FIXME: use zlib-bindings
-gcompress :: forall a . Enumerator ByteString IO a
- -> Enumerator ByteString IO a
+gcompress :: forall a . Enumerator Builder IO a
+ -> Enumerator Builder IO a
gcompress = compressEnumerator GZip.compress
------------------------------------------------------------------------------
-ccompress :: forall a . Enumerator ByteString IO a
- -> Enumerator ByteString IO a
+ccompress :: forall a . Enumerator Builder IO a
+ -> Enumerator Builder IO a
ccompress = compressEnumerator Zlib.compress
------------------------------------------------------------------------------
compressEnumerator :: forall a .
(L.ByteString -> L.ByteString)
- -> Enumerator ByteString IO a
- -> Enumerator ByteString IO a
-compressEnumerator compFunc enum origStep = do
+ -> Enumerator Builder IO a
+ -> Enumerator Builder IO a
+compressEnumerator compFunc enum' origStep = do
+ let iter = joinI $ I.map fromByteString origStep
+ step <- lift $ runIteratee iter
writeEnd <- liftIO $ newChan
readEnd <- liftIO $ newChan
tid <- liftIO $ forkIO $ threadProc readEnd writeEnd
- enum (f readEnd writeEnd tid origStep)
+ let enum = mapEnum toByteString enum'
+ let outEnum = enum (f readEnd writeEnd tid step)
+ mapIter fromByteString outEnum
where
--------------------------------------------------------------------------

0 comments on commit 1e1a266

Please sign in to comment.