This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, blaze-builder has been created
at 371e3a3c19638fb6a466395090ae39686de6261d (commit)
- Log -----------------------------------------------------------------
commit 371e3a3c19638fb6a466395090ae39686de6261d
Author: Gregory Collins <[email protected]>
Date: Sun Dec 26 14:35:42 2010 +0100
Tests with builder now passing.
diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal
index 996b4df..c2cb16f 100644
--- a/test/snap-core-testsuite.cabal
+++ b/test/snap-core-testsuite.cabal
@@ -26,6 +26,7 @@ Executable testsuite
blaze-builder >= 0.2.1 && <0.3,
bytestring,
bytestring-nums,
+ cereal == 0.3.*,
containers,
deepseq >= 1.1 && <1.2,
directory,
diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs
b/test/suite/Snap/Internal/Http/Types/Tests.hs
index 893c4dc..8ea0e24 100644
--- a/test/suite/Snap/Internal/Http/Types/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Types/Tests.hs
@@ -3,14 +3,14 @@
module Snap.Internal.Http.Types.Tests
( tests ) where
+import Blaze.ByteString.Builder
import Control.Monad
import Control.Parallel.Strategies
-import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Lazy.Char8 ()
import Data.IORef
-import Data.List (sort)
import qualified Data.Map as Map
+import Data.Monoid
import Data.Time.Calendar
import Data.Time.Clock
import Prelude hiding (take)
@@ -91,8 +91,8 @@ testTypes = testCase "show" $ do
assertEqual "content-length" (Just 4) $ rspContentLength resp
-- run response body
let benum = rspBodyToEnum $ rspBody resp
- bd <- runIteratee consume >>= run_ . benum
- assertEqual "response body" "PING" $ S.concat bd
+ bd <- liftM (toByteString . mconcat) (runIteratee consume >>= run_ . benum)
+ assertEqual "response body" "PING" $ bd
let !_ = show GET
let !_ = GET == POST
@@ -107,7 +107,7 @@ testTypes = testCase "show" $ do
resp = addResponseCookie cook $
setContentLength 4 $
modifyResponseBody id $
- setResponseBody (enumBS "PING") $
+ setResponseBody (enumBuilder (fromByteString "PING")) $
setContentType "text/plain" $
setResponseStatus 555 "bogus" $
emptyResponse
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
index a1c9713..6493053 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -5,6 +5,7 @@
module Snap.Types.Tests
( tests ) where
+import Blaze.ByteString.Builder
import Control.Applicative
import Control.Concurrent.MVar
import Control.Exception (SomeException)
@@ -16,6 +17,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef
+import Data.Monoid
import Data.Text ()
import Data.Text.Lazy ()
import qualified Data.Map as Map
@@ -305,7 +307,7 @@ testParam = testCase "types/getParam" $ do
getBody :: Response -> IO L.ByteString
getBody r = do
let benum = rspBodyToEnum $ rspBody r
- liftM L.fromChunks (runIteratee consume >>= run_ . benum)
+ liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)
testWrites :: Test
@@ -316,7 +318,7 @@ testWrites = testCase "types/writes" $ do
where
h :: Snap ()
h = do
- addToOutput $ enumBS "Foo1"
+ addToOutput $ enumBuilder $ fromByteString "Foo1"
writeBS "Foo2"
writeLBS "Foo3"
@@ -343,7 +345,7 @@ testDir2 = testCase "types/dir2" $ do
where
f = dir "foo" $ dir "bar" $ do
p <- liftM rqContextPath getRequest
- addToOutput $ enumBS p
+ addToOutput $ enumBuilder $ fromByteString p
testIpHeaderFilter :: Test
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs
b/test/suite/Snap/Util/FileServe/Tests.hs
index b708e82..8135d93 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -5,6 +5,7 @@
module Snap.Util.FileServe.Tests
( tests ) where
+import Blaze.ByteString.Builder
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
@@ -12,6 +13,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe
+import Data.Monoid
import Prelude hiding (take)
import Test.Framework
import Test.Framework.Providers.HUnit
@@ -40,7 +42,7 @@ expect404 m = do
getBody :: Response -> IO L.ByteString
getBody r = do
let benum = rspBodyToEnum $ rspBody r
- liftM L.fromChunks (runIteratee consume >>= run_ . benum)
+ liftM (toLazyByteString . mconcat) (runIteratee consume >>= run_ . benum)
go :: Snap a -> ByteString -> IO Response
diff --git a/test/suite/Snap/Util/GZip/Tests.hs
b/test/suite/Snap/Util/GZip/Tests.hs
index b96dd0b..3247d12 100644
--- a/test/suite/Snap/Util/GZip/Tests.hs
+++ b/test/suite/Snap/Util/GZip/Tests.hs
@@ -6,16 +6,17 @@
module Snap.Util.GZip.Tests
( tests ) where
+import Blaze.ByteString.Builder
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Zlib as Zlib
import Control.Exception hiding (assert)
import Control.Monad (liftM)
-import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Digest.Pure.MD5
import Data.IORef
import qualified Data.Map as Map
-import Data.Serialize
+import Data.Monoid
+import Data.Serialize (encode)
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
@@ -32,8 +33,8 @@ import Snap.Util.GZip
stream2stream
- :: Iteratee ByteString IO L.ByteString
-stream2stream = liftM L.fromChunks consume
+ :: Iteratee Builder IO L.ByteString
+stream2stream = liftM (toLazyByteString . mconcat) consume
------------------------------------------------------------------------------
tests :: [Test]
@@ -150,20 +151,21 @@ goNoHeaders = goGeneric mkNoHeaders
------------------------------------------------------------------------------
noContentType :: L.ByteString -> Snap ()
-noContentType s = modifyResponse $ setResponseBody (enumLBS s)
+noContentType s = modifyResponse $ setResponseBody $
+ enumBuilder $ fromLazyByteString s
------------------------------------------------------------------------------
textPlain :: L.ByteString -> Snap ()
textPlain s = modifyResponse $
- setResponseBody (enumLBS s) .
+ setResponseBody (enumBuilder $ fromLazyByteString s) .
setContentType "text/plain"
------------------------------------------------------------------------------
binary :: L.ByteString -> Snap ()
binary s = modifyResponse $
- setResponseBody (enumLBS s) .
+ setResponseBody (enumBuilder $ fromLazyByteString s) .
setContentType "application/octet-stream"
commit c9da51d3deeea8afcf94633004c3c27f470e2fc3
Merge: db70866 8365c6b
Author: Gregory Collins <[email protected]>
Date: Sun Dec 26 14:25:25 2010 +0100
Merge branch 'master' into blaze-builder
commit db70866664f6192ae04fde618126943fb02d34fd
Author: Gregory Collins <[email protected]>
Date: Wed Dec 22 13:48:14 2010 +0100
Checkpoint: remove deps from testsuite
diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal
index 7a5ab59..996b4df 100644
--- a/test/snap-core-testsuite.cabal
+++ b/test/snap-core-testsuite.cabal
@@ -23,10 +23,9 @@ Executable testsuite
QuickCheck >= 2.3.0.2,
attoparsec >= 0.8.1 && < 0.9,
base >= 4 && < 5,
+ blaze-builder >= 0.2.1 && <0.3,
bytestring,
bytestring-nums,
- bytestring-show >= 0.3.2 && < 0.4,
- cereal >= 0.3 && < 0.4,
containers,
deepseq >= 1.1 && <1.2,
directory,
@@ -35,7 +34,7 @@ Executable testsuite
HUnit >= 1.2 && < 2,
enumerator == 0.4.*,
MonadCatchIO-transformers >= 0.2 && < 0.3,
- monads-fd <0.2,
+ mtl >= 2 && <3,
old-locale,
old-time,
parallel >= 2.2 && <2.3,
commit efbf4dc4fb8c9286629845d4ec1e179ea3bcab75
Merge: 6e7858d 9875cff
Author: Gregory Collins <[email protected]>
Date: Wed Dec 22 10:11:49 2010 +0100
Merge branch 'master' into blaze-builder
diff --cc src/Snap/Internal/Iteratee/Debug.hs
index 6892cdb,9565f86..4d568ea
--- a/src/Snap/Internal/Iteratee/Debug.hs
+++ b/src/Snap/Internal/Iteratee/Debug.hs
@@@ -94,17 -75,10 +94,19 @@@ iterateeDebugWrapper = iterateeDebugWra
#else
+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 :: (Show a, MonadIO m) =>
+ String
+ -> Iteratee a m b
+ -> Iteratee a m b
iterateeDebugWrapper _ = id
{-# INLINE iterateeDebugWrapper #-}
commit 6e7858d7bd4314365a03a27c8d8d45de88f17098
Author: Gregory Collins <[email protected]>
Date: Wed Dec 22 10:09:45 2010 +0100
Checkpoint: cleanup warnings
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 26162c7..cdce09f 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -40,24 +40,25 @@ import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Time.Clock
-import Data.Time.Format
import Data.Word
import Foreign hiding (new)
import Foreign.C.Types
import Prelude hiding (take)
-import System.Locale (defaultTimeLocale)
#ifdef PORTABLE
+import Data.Time.Format
import Data.Time.LocalTime
import Data.Time.Clock.POSIX
+import System.Locale (defaultTimeLocale)
#else
+import Data.Time.Format ()
import Foreign.C.String
#endif
------------------------------------------------------------------------------
import Data.CIByteString
-import Snap.Iteratee (Enumerator, ($$), (>>==))
+import Snap.Iteratee (Enumerator)
import qualified Snap.Iteratee as I
diff --git a/src/Snap/Internal/Iteratee/Debug.hs
b/src/Snap/Internal/Iteratee/Debug.hs
index 625573c..6892cdb 100644
--- a/src/Snap/Internal/Iteratee/Debug.hs
+++ b/src/Snap/Internal/Iteratee/Debug.hs
@@ -55,7 +55,7 @@ iterateeDebugWrapperWith :: (MonadIO m) =>
-> String
-> Iteratee a m b
-> Iteratee a m b
-iterateeDebugWrapperWith shower name iter = do
+iterateeDebugWrapperWith showFunc name iter = do
debug $ name ++ ": BEGIN"
step <- lift $ runIteratee iter
whatWasReturn step
@@ -76,13 +76,13 @@ iterateeDebugWrapperWith shower name iter = do
k EOF
f k ch@(Chunks xs) = do
- debug $ name ++ ": got chunk: " ++ showList xs
+ debug $ name ++ ": got chunk: " ++ showL xs
step <- lift $ runIteratee $ k ch
whatWasReturn step
check step
- showStream = show . fmap shower
- showList = show . map shower
+ showStream = show . fmap showFunc
+ showL = show . map showFunc
iterateeDebugWrapper :: (Show a, MonadIO m) =>
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 683e31a..ec5216a 100644
--- a/src/Snap/Internal/Types.hs
+++ b/src/Snap/Internal/Types.hs
@@ -25,9 +25,7 @@ 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)
commit 1e1a266af4518f71e883ea3162d59142deecc2bc
Author: Gregory Collins <[email protected]>
Date: Wed Dec 22 09:11:03 2010 +0100
Needs cleanup, but compiles now with builder definition
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 53fa105..26162c7 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/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) }
diff --git a/src/Snap/Internal/Iteratee/Debug.hs
b/src/Snap/Internal/Iteratee/Debug.hs
index f3c8f8c..625573c 100644
--- a/src/Snap/Internal/Iteratee/Debug.hs
+++ b/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 #-}
diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs
index 0226fb1..683e31a 100644
--- a/src/Snap/Internal/Types.hs
+++ b/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,12 +462,20 @@ 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.
--
@@ -470,7 +483,7 @@ addToOutput enum = modifyResponse $ modifyResponseBody
(>==> enum)
-- 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 }
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index a110b33..13de58c 100644
--- a/src/Snap/Iteratee.hs
+++ b/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
diff --git a/src/Snap/Types.hs b/src/Snap/Types.hs
index 9e47874..9de20e5 100644
--- a/src/Snap/Types.hs
+++ b/src/Snap/Types.hs
@@ -110,6 +110,7 @@ module Snap.Types
, setResponseBody
, modifyResponseBody
, addToOutput
+ , writeBuilder
, writeBS
, writeLazyText
, writeText
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 025e9f9..2b3dcec 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/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
diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs
index ba38c9b..ad109b0 100644
--- a/src/Snap/Util/GZip.hs
+++ b/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
--------------------------------------------------------------------------
commit 7f65679d0d5737063b3294b2e5961c7b4244bb16
Author: Gregory Collins <[email protected]>
Date: Wed Dec 22 07:31:08 2010 +0100
Checkpoint: remove cereal, bytestring-show dependencies, add blaze-builder
diff --git a/snap-core.cabal b/snap-core.cabal
index 53d4cdf..a010117 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -1,5 +1,5 @@
name: snap-core
-version: 0.3.0
+version: 0.4.0
synopsis: Snap: A Haskell Web Framework (Core)
description:
@@ -141,9 +141,9 @@ Library
build-depends:
attoparsec >= 0.8.0.2 && < 0.9,
base >= 4 && < 5,
+ blaze-builder >= 0.2.1 && <0.3,
bytestring,
bytestring-nums,
- bytestring-show >= 0.3.2 && < 0.4,
cereal >= 0.3 && < 0.4,
containers,
deepseq >= 1.1 && <1.2,
diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs
index 5f4a356..53fa105 100644
--- a/src/Snap/Internal/Http/Types.hs
+++ b/src/Snap/Internal/Http/Types.hs
@@ -16,6 +16,7 @@ module Snap.Internal.Http.Types where
------------------------------------------------------------------------------
+import Blaze.ByteString.Builder
import Control.Applicative hiding (empty)
import Control.Monad (liftM, when)
import qualified Data.Attoparsec as Atto
@@ -38,7 +39,6 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
-import Data.Serialize.Builder
import Data.Time.Clock
import Data.Time.Format
import Data.Word
@@ -731,13 +731,13 @@ urlDecode = parseToCompletion pUrlEscaped
-- | URL-escapes a string (see
-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)
urlEncode :: ByteString -> ByteString
-urlEncode = toByteString . S.foldl' f empty
+urlEncode = toByteString . S.foldl' f mempty
where
f b c =
if c == c2w ' '
- then b `mappend` singleton (c2w '+')
+ then b `mappend` fromWord8 (c2w '+')
else if isKosher c
- then b `mappend` singleton c
+ then b `mappend` fromWord8 c
else b `mappend` hexd c
isKosher w = any ($ c) [ isAlphaNum
@@ -749,7 +749,7 @@ urlEncode = toByteString . S.foldl' f empty
------------------------------------------------------------------------------
hexd :: Word8 -> Builder
-hexd c = singleton (c2w '%') `mappend` singleton hi `mappend` singleton low
+hexd c = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low
where
d = c2w . intToDigit
low = d $ fromEnum $ c .&. 0xf
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 0f1db50..025e9f9 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/src/Snap/Util/FileServe.hs
@@ -16,23 +16,25 @@ module Snap.Util.FileServe
) where
------------------------------------------------------------------------------
+import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder.Char8
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Attoparsec.Char8 hiding (Done)
import qualified Data.ByteString.Char8 as S
-import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Char8 (ByteString)
+import Data.ByteString.Internal (c2w)
import Data.Int
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing)
+import Data.Monoid
import Prelude hiding (show, Show)
import qualified Prelude
import System.Directory
import System.FilePath
import System.PosixCompat.Files
-import Text.Show.ByteString hiding (runPut)
------------------------------------------------------------------------------
import Snap.Internal.Debug
import Snap.Internal.Parsing
@@ -385,14 +387,13 @@ checkRangeReq req fp sz = do
send206 start end = do
dbg "inside send206"
let len = end-start+1
- let crng = S.concat $
- L.toChunks $
- L.concat [ "bytes "
- , show start
- , "-"
- , show end
- , "/"
- , show sz ]
+ let crng = toByteString $
+ mconcat [ fromByteString "bytes "
+ , fromShow start
+ , fromWord8 (c2w '-')
+ , fromShow end
+ , fromWord8 (c2w '/')
+ , fromShow sz ]
modifyResponse $ setResponseCode 206
. setHeader "Content-Range" crng
@@ -413,9 +414,9 @@ checkRangeReq req fp sz = do
if getHeader "If-Range" req /= Nothing
then return False
else do
- let crng = S.concat $
- L.toChunks $
- L.concat ["bytes */", show sz]
+ let crng = toByteString $
+ mconcat [ fromByteString "bytes */"
+ , fromShow sz ]
modifyResponse $ setResponseCode 416
. setHeader "Content-Range" crng
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
