snap-core 0.5.4 → 0.5.5

raw patch · 9 files changed

+233/−216 lines, 9 filesdep +blaze-builder-enumeratordep +zlib-enumdep −zlibdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: blaze-builder-enumerator, zlib-enum

Dependencies removed: zlib

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• snap-core.cabal +4/−3
• src/Snap/Internal/Types.hs +63/−45
• src/Snap/Iteratee.hs +21/−0
• src/Snap/Util/FileServe.hs +85/−55
• src/Snap/Util/GZip.hs +29/−106
• src/Snap/Util/Readable.hs +1/−1
• test/snap-core-testsuite.cabal +4/−2
• test/suite/Snap/Types/Tests.hs +4/−4
• test/suite/Snap/Util/GZip/Tests.hs +22/−0

@@ -1,5 +1,5 @@ name:           snap-core-version:        0.5.4+version:        0.5.5 synopsis:       Snap: A Haskell Web Framework (Core)  description:@@ -131,8 +131,9 @@   build-depends:     attoparsec >= 0.8.0.2 && < 0.10,     attoparsec-enumerator >= 0.2.0.3,-    base >= 4.3 && < 5,+    base >= 4 && < 5,     blaze-builder >= 0.2.1.4 && <0.4,+    blaze-builder-enumerator >= 0.2 && <0.3,     bytestring,     bytestring-nums,     case-insensitive >= 0.2 && < 0.4,@@ -151,7 +152,7 @@     transformers == 0.2.*,     unix-compat >= 0.2 && <0.4,     vector >= 0.6 && <0.10,-    zlib+    zlib-enum >= 0.2.1 && <0.3    ghc-prof-options: -prof -auto-all 

@@ -1,10 +1,13 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE EmptyDataDecls      #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE PackageImports      #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PackageImports        #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeSynonymInstances  #-}  module Snap.Internal.Types where @@ -15,6 +18,7 @@ import           Control.Exception (SomeException, throwIO, ErrorCall(..)) import           Control.Monad import           Control.Monad.CatchIO+import qualified Control.Monad.Error.Class as EC import           Control.Monad.State import           Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S@@ -63,12 +67,13 @@    > c = a <|> b             -- try running a, if it fails then try b  4. convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText',-   'addToOutput') for writing output to the 'Response':+   'addToOutput') for queueing output to be written to the 'Response':     > a :: (forall a . Enumerator a) -> Snap ()    > a someEnumerator = do    >     writeBS "I'm a strict bytestring"    >     writeLBS "I'm a lazy bytestring"+   >     writeText "I'm strict text"    >     addToOutput someEnumerator  5. early termination: if you call 'finishWith':@@ -89,11 +94,23 @@    > a = liftIO fireTheMissiles  7. the ability to set a timeout which will kill the handler thread after @N@-   seconds of inactivity:+   seconds of inactivity (the default is 20 seconds):     > a :: Snap ()    > a = setTimeout 30 +8. throw and catch exceptions using a 'MonadCatchIO' instance:++   > foo :: Snap ()+   > foo = bar `catch` \(e::SomeException) -> baz+   >   where+   >     bar = throw FooException++9. log a message to the error log:++   > foo :: Snap ()+   > foo = logError "grumble."+ You may notice that most of the type signatures in this module contain a @(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which, in essence, says \"you can get back to the 'Snap' monad from here\". Using@@ -113,9 +130,9 @@   -------------------------------------------------------------------------------data SnapResult a = PassOnProcessing+data SnapResult a = SnapValue a+                  | PassOnProcessing String                   | EarlyTermination Response-                  | SnapValue a  ------------------------------------------------------------------------------ newtype Snap a = Snap {@@ -136,18 +153,7 @@     (>>=)  = snapBind     return = snapReturn     fail   = snapFail-{--    (Snap m) >>= f =-        Snap $ do-            eth <- m-            maybe (return Nothing)-                  (either (return . Just . Left)-                          (unSnap . f))-                  eth -    return = Snap . return . Just . Right-    fail   = const $ Snap $ return Nothing--}  ------------------------------------------------------------------------------ snapBind :: Snap a -> (a -> Snap b) -> Snap b@@ -155,8 +161,8 @@     res <- m      case res of-      SnapValue a        -> unSnap $ f a-      PassOnProcessing   -> return PassOnProcessing+      SnapValue a        -> unSnap $! f a+      PassOnProcessing r -> return $! PassOnProcessing r       EarlyTermination r -> return $! EarlyTermination r {-# INLINE snapBind #-} @@ -167,7 +173,7 @@   snapFail :: String -> Snap a-snapFail _ = Snap $ return PassOnProcessing+snapFail !m = Snap $! return $! PassOnProcessing m {-# INLINE snapFail #-}  @@ -178,15 +184,13 @@  ------------------------------------------------------------------------------ instance MonadCatchIO Snap where-    catch (Snap m) handler = Snap $ do-        x <- try m-        case x of-          (Left e)  -> do-              rethrowIfTermination $ fromException e-              maybe (throw e)-                    (\e' -> let (Snap z) = handler e' in z)-                    (fromException e)-          (Right y) -> return y+    catch (Snap m) handler = Snap $ m `catch` h+      where+        h e = do+            rethrowIfTermination $ fromException e+            maybe (throw e)+                  (\e' -> let (Snap z) = handler e' in z)+                  (fromException e)      block (Snap m) = Snap $ block m     unblock (Snap m) = Snap $ unblock m@@ -202,17 +206,31 @@  ------------------------------------------------------------------------------ instance MonadPlus Snap where-    mzero = Snap $ return PassOnProcessing+    mzero = Snap $ return $ PassOnProcessing ""      a `mplus` b =         Snap $ do             r <- unSnap a+            -- redundant just in case ordering by frequency helps here.             case r of-              PassOnProcessing -> unSnap b-              _                -> return r+              SnapValue _        -> return r+              PassOnProcessing _ -> unSnap b+              _                  -> return r   ------------------------------------------------------------------------------+instance (EC.MonadError String) Snap where+    throwError = fail+    catchError act hndl = Snap $ do+        r <- unSnap act+        -- redundant just in case ordering by frequency helps here.+        case r of+          SnapValue _        -> return r+          PassOnProcessing m -> unSnap $ hndl m+          _                  -> return r+++------------------------------------------------------------------------------ instance Functor Snap where     fmap = liftM @@ -363,9 +381,9 @@ catchFinishWith (Snap m) = Snap $ do     r <- m     case r of-      PassOnProcessing      -> return PassOnProcessing-      EarlyTermination resp -> return $! SnapValue $! Left resp       SnapValue a           -> return $! SnapValue $! Right a+      PassOnProcessing e    -> return $! PassOnProcessing e+      EarlyTermination resp -> return $! SnapValue $! Left resp {-# INLINE catchFinishWith #-}  @@ -772,13 +790,13 @@  ------------------------------------------------------------------------------ -- | This exception is thrown if the handler you supply to 'runSnap' fails.-data NoHandlerException = NoHandlerException+data NoHandlerException = NoHandlerException String    deriving (Eq, Typeable)   ------------------------------------------------------------------------------ instance Show NoHandlerException where-    show NoHandlerException = "No handler for request"+    show (NoHandlerException e) = "No handler for request: failure was " ++ e   ------------------------------------------------------------------------------@@ -817,9 +835,9 @@     (r, ss') <- runStateT m ss      let resp = case r of-                 PassOnProcessing   -> fourohfour-                 EarlyTermination x -> x                  SnapValue _        -> _snapResponse ss'+                 PassOnProcessing _ -> fourohfour+                 EarlyTermination x -> x      return (_snapRequest ss', resp) @@ -846,9 +864,9 @@     (r, _) <- runStateT m ss      case r of-      PassOnProcessing   -> liftIO $ throwIO NoHandlerException-      EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"       SnapValue x        -> return x+      PassOnProcessing e -> liftIO $ throwIO $ NoHandlerException e+      EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"    where     dresp = emptyResponse { rspHttpVersion = rqVersion req }

@@ -37,6 +37,9 @@   , skipToEof   , mapEnum   , mapIter+  , enumBuilderToByteString+  , unsafeEnumBuilderToByteString+  , enumByteStringToBuilder   , killIfTooSlow    , TooManyBytesReadException@@ -65,6 +68,8 @@   , ($$)   , (>==>)   , (<==<)+  , ($=)+  , (=$)      -- *** Iteratees   , run@@ -100,6 +105,7 @@ ------------------------------------------------------------------------------  import           Blaze.ByteString.Builder+import           Blaze.ByteString.Builder.Enumerator import           Control.DeepSeq import           Control.Exception (SomeException, assert) import           Control.Monad@@ -671,6 +677,21 @@       where         streamIn = fmap f streamOut         iterIn   = k streamIn+++------------------------------------------------------------------------------+enumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a+enumBuilderToByteString = builderToByteString++------------------------------------------------------------------------------+unsafeEnumBuilderToByteString :: MonadIO m => Enumeratee Builder ByteString m a+unsafeEnumBuilderToByteString =+    builderToByteStringWith (reuseBufferStrategy (allocBuffer 65536))+    ++------------------------------------------------------------------------------+enumByteStringToBuilder :: MonadIO m => Enumeratee ByteString Builder m a+enumByteStringToBuilder = IL.map fromByteString   ------------------------------------------------------------------------------

@@ -1,6 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}  -- | Contains web handlers to serve files from a directory.@@ -32,7 +32,9 @@ import           Blaze.ByteString.Builder import           Blaze.ByteString.Builder.Char8 import           Control.Applicative+import           Control.Exception (SomeException, evaluate) import           Control.Monad+import           Control.Monad.CatchIO import           Control.Monad.Trans import           Data.Attoparsec.Char8 hiding (Done) import qualified Data.ByteString.Char8 as S@@ -44,7 +46,9 @@ import qualified Data.Map as Map import           Data.Maybe (fromMaybe, isNothing) import           Data.Monoid-import           Prelude hiding (show, Show)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Prelude hiding (catch, show, Show) import qualified Prelude import           System.Directory import           System.FilePath@@ -114,6 +118,7 @@ -- >   ( ".jpeg"    , "image/jpeg"                        ), -- >   ( ".jpg"     , "image/jpeg"                        ), -- >   ( ".js"      , "text/javascript"                   ),+-- >   ( ".json"    , "application/json"                  ), -- >   ( ".log"     , "text/plain"                        ), -- >   ( ".m3u"     , "audio/x-mpegurl"                   ), -- >   ( ".mov"     , "video/quicktime"                   ),@@ -172,6 +177,7 @@   ( ".jpeg"    , "image/jpeg"                        ),   ( ".jpg"     , "image/jpeg"                        ),   ( ".js"      , "text/javascript"                   ),+  ( ".json"    , "application/json"                  ),   ( ".log"     , "text/plain"                        ),   ( ".m3u"     , "audio/x-mpegurl"                   ),   ( ".mov"     , "video/quicktime"                   ),@@ -235,38 +241,41 @@ -- | Style information for the default directory index generator. snapIndexStyles :: ByteString snapIndexStyles =-    "body { margin: 0px 0px 0px 0px; font-family: sans-serif }"-    `S.append` "div.header {"-    `S.append`     "padding: 40px 40px 0px 40px; height:35px;"-    `S.append`     "background:rgb(25,50,87);"-    `S.append`     "background-image:-webkit-gradient("-    `S.append`         "linear,left bottom,left top,"-    `S.append`         "color-stop(0.00, rgb(31,62,108)),"-    `S.append`         "color-stop(1.00, rgb(19,38,66)));"-    `S.append`     "background-image:-moz-linear-gradient("-    `S.append`         "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"-    `S.append`     "text-shadow:-1px 3px 1px rgb(16,33,57);"-    `S.append`     "font-size:16pt; letter-spacing: 2pt; color:white;"-    `S.append`     "border-bottom:10px solid rgb(46,93,156) }"-    `S.append` "div.content {"-    `S.append`     "background:rgb(255,255,255);"-    `S.append`     "background-image:-webkit-gradient("-    `S.append`         "linear,left bottom, left top,"-    `S.append`         "color-stop(0.50, rgb(255,255,255)),"-    `S.append`         "color-stop(1.00, rgb(224,234,247)));"-    `S.append`     "background-image:-moz-linear-gradient("-    `S.append`         "center bottom, white 50%, rgb(224,234,247) 100%);"-    `S.append`     "padding: 40px 40px 40px 40px }"-    `S.append` "div.footer {"-    `S.append`     "padding: 16px 0px 10px 10px; height:31px;"-    `S.append`     "border-top: 1px solid rgb(194,209,225);"-    `S.append`     "color: rgb(160,172,186); font-size:10pt;"-    `S.append`     "background: rgb(245,249,255) }"-    `S.append` "table { width:100% }"-    `S.append` "tr:hover { background:rgb(256,256,224) }"-    `S.append` "td { border:dotted thin black; font-family:monospace }"-    `S.append` "th { border:solid thin black; background:rgb(28,56,97);"-    `S.append`      "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"+    S.intercalate "\n"+        [ "body { margin: 0px 0px 0px 0px; font-family: sans-serif }"+        , "div.header {"+        ,     "padding: 40px 40px 0px 40px; height:35px;"+        ,     "background:rgb(25,50,87);"+        ,     "background-image:-webkit-gradient("+        ,         "linear,left bottom,left top,"+        ,         "color-stop(0.00, rgb(31,62,108)),"+        ,         "color-stop(1.00, rgb(19,38,66)));"+        ,     "background-image:-moz-linear-gradient("+        ,         "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"+        ,     "text-shadow:-1px 3px 1px rgb(16,33,57);"+        ,     "font-size:16pt; letter-spacing: 2pt; color:white;"+        ,     "border-bottom:10px solid rgb(46,93,156) }"+        , "div.content {"+        ,     "background:rgb(255,255,255);"+        ,     "background-image:-webkit-gradient("+        ,         "linear,left bottom, left top,"+        ,         "color-stop(0.50, rgb(255,255,255)),"+        ,         "color-stop(1.00, rgb(224,234,247)));"+        ,     "background-image:-moz-linear-gradient("+        ,         "center bottom, white 50%, rgb(224,234,247) 100%);"+        ,     "padding: 40px 40px 40px 40px }"+        , "div.footer {"+        ,     "padding: 16px 0px 10px 10px; height:31px;"+        ,     "border-top: 1px solid rgb(194,209,225);"+        ,     "color: rgb(160,172,186); font-size:10pt;"+        ,     "background: rgb(245,249,255) }"+        , "table { max-width:100%; margin: 0 auto; border-collapse: collapse; }"+        , "tr:hover { background:rgb(256,256,224) }"+        , "td { border:0; font-family:monospace; padding: 2px 0; }"+        , "td.filename, td.type { padding-right: 2em; }"+        , "th { border:0; background:rgb(28,56,97);"+        ,      "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"+        ]   ------------------------------------------------------------------------------@@ -288,49 +297,71 @@                       -> FilePath   -- ^ Directory to generate index for                       -> m () defaultIndexGenerator mm styles d = do-    modifyResponse $ setContentType "text/html"+    modifyResponse $ setContentType "text/html; charset=utf-8"     rq      <- getRequest -    let uri = uriWithoutQueryString rq+    let uri   = uriWithoutQueryString rq+    let pInfo = rqPathInfo rq +    writeBS "<!DOCTYPE html>\n<html>\n<head>"+    writeBS "<title>Directory Listing: "+    writeBS uri+    writeBS "</title>"     writeBS "<style type='text/css'>"     writeBS styles-    writeBS "</style><div class=\"header\">Directory Listing: "+    writeBS "</style></head><body>"+    writeBS "<div class=\"header\">Directory Listing: "     writeBS uri     writeBS "</div><div class=\"content\">"     writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"     writeBS "</th></tr>" -    when (uri /= "/") $+    when (pInfo /= "") $         writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"      entries <- liftIO $ getDirectoryContents d     dirs    <- liftIO $ filterM (doesDirectoryExist . (d </>)) entries     files   <- liftIO $ filterM (doesFileExist . (d </>)) entries -    forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f -> do-        writeBS "<tr><td><a href='"-        writeBS (S.pack f)+    forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f0 -> do+        f <- liftIO $ liftM (\s -> T.encodeUtf8 s `mappend` "/") $ packFn f0+        writeBS "<tr><td class='filename'><a href='"+        writeBS f         writeBS "/'>"-        writeBS (S.pack f)-        writeBS "</a></td><td colspan=2>DIR</td></tr>"+        writeBS f+        writeBS "</a></td><td class='type' colspan=2>DIR</td></tr>" -    forM_ (sort files) $ \f -> do-        stat <- liftIO $ getFileStatus (d </> f)+    forM_ (sort files) $ \f0 -> do+        f <- liftIO $ liftM T.encodeUtf8 $ packFn f0+        stat <- liftIO $ getFileStatus (d </> f0)         tm   <- liftIO $ formatHttpTime (modificationTime stat)-        writeBS "<tr><td><a href='"-        writeBS (S.pack f)+        writeBS "<tr><td class='filename'><a href='"+        writeBS f         writeBS "'>"-        writeBS (S.pack f)-        writeBS "</a></td><td>"-        writeBS (fileType mm f)+        writeBS f+        writeBS "</a></td><td class='type'>"+        writeBS (fileType mm f0)         writeBS "</td><td>"         writeBS tm         writeBS "</tr>"      writeBS "</table></div><div class=\"footer\">Powered by "     writeBS "<b><a href=\"http://snapframework.com\">Snap</a></b></div>"+    writeBS "</body>"+  where+    packFn fp = do+        tryFirst [ T.decodeUtf8+                 , T.decodeUtf16LE+                 , T.decodeUtf16BE+                 , T.decodeUtf32LE+                 , T.decodeUtf32BE+                 , const (T.pack fp) ]+      where+        tryFirst []     = error "No valid decoding"+        tryFirst (f:fs) =+            evaluate (f bs) `catch` \(_::SomeException) -> tryFirst fs +        bs = S.pack fp  ------------------------------------------------------------------------------ -- | A very simple configuration for directory serving.  This configuration@@ -733,10 +764,9 @@  ------------------------------------------------------------------------------ uriWithoutQueryString :: Request -> ByteString-uriWithoutQueryString rq = S.concat [ cp, pinfo ]+uriWithoutQueryString rq = S.takeWhile (/= '?') uri   where-    cp    = rqContextPath rq-    pinfo = rqPathInfo rq+    uri   = rqURI rq   ------------------------------------------------------------------------------

@@ -6,11 +6,11 @@  module Snap.Util.GZip ( withCompression-, withCompression' ) where+, withCompression'+, noCompression ) where  import           Blaze.ByteString.Builder-import qualified Codec.Compression.GZip as GZip-import qualified Codec.Compression.Zlib as Zlib+import qualified Codec.Zlib.Enum as Z import           Control.Concurrent import           Control.Applicative hiding (many) import           Control.Exception@@ -22,11 +22,13 @@ import qualified Data.ByteString.Char8 as S import qualified Data.Char as Char import           Data.Maybe+import           Data.Monoid 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@@ -122,6 +124,13 @@   ------------------------------------------------------------------------------+-- | Turn off compression by setting \"Content-Encoding: identity\" in the+-- response headers.+noCompression :: MonadSnap m => m ()+noCompression = modifyResponse $ setHeader "Content-Encoding" "identity"+++------------------------------------------------------------------------------ -- private following ------------------------------------------------------------------------------ @@ -160,117 +169,31 @@   --------------------------------------------------------------------------------- FIXME: use zlib-bindings gcompress :: forall a . Enumerator Builder IO a-          -> Enumerator Builder IO  a-gcompress = compressEnumerator GZip.compress+          -> Enumerator Builder IO a+gcompress e st = e $$ iFinal+  where+    i0     = returnI st+    iB     = mapFlush                =$ i0+    iZ     = Z.gzip                  =$ iB+    iFinal = enumBuilderToByteString =$ iZ +    mapFlush :: Monad m => Enumeratee ByteString Builder m b+    mapFlush = I.map ((`mappend` flush) . fromByteString) + ------------------------------------------------------------------------------ ccompress :: forall a . Enumerator Builder IO a           -> Enumerator Builder IO a-ccompress = compressEnumerator Zlib.compress----------------------------------------------------------------------------------compressEnumerator :: forall a .-                      (L.ByteString -> L.ByteString)-                   -> 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--    let enum = mapEnum fromByteString toByteString enum'-    let outEnum = enum (f readEnd writeEnd tid step)-    mapIter toByteString fromByteString outEnum-+ccompress e st = e $$ iFinal   where-    ---------------------------------------------------------------------------    streamFinished :: Stream ByteString -> Bool-    streamFinished EOF        = True-    streamFinished (Chunks _) = False---    ---------------------------------------------------------------------------    consumeSomeOutput :: Chan (Either SomeException (Stream ByteString))-                      -> Step ByteString IO a-                      -> Iteratee ByteString IO (Step ByteString IO a)-    consumeSomeOutput writeEnd step = do-        e <- lift $ isEmptyChan writeEnd-        if e-          then return step-          else do-            ech <- lift $ readChan writeEnd-            either throwError-                   (\ch -> do-                        step' <- checkDone (\k -> lift $ runIteratee $ k ch)-                                           step-                        consumeSomeOutput writeEnd step')-                   ech--    ---------------------------------------------------------------------------    consumeRest :: Chan (Either SomeException (Stream ByteString))-                -> Step ByteString IO a-                -> Iteratee ByteString IO a-    consumeRest writeEnd step = do-        ech <- lift $ readChan writeEnd-        either throwError-               (\ch -> do-                   step' <- checkDone (\k -> lift $ runIteratee $ k ch) step-                   if (streamFinished ch)-                      then returnI step'-                      else consumeRest writeEnd step')-               ech--    ---------------------------------------------------------------------------    f _ _ _ (Error e) = Error e-    f _ _ _ (Yield x _) = Yield x EOF-    f readEnd writeEnd tid st@(Continue k) = Continue $ \ch ->-        case ch of-          EOF -> do-            lift $ writeChan readEnd Nothing-            x <- consumeRest writeEnd st-            lift $ killThread tid-            return x--          (Chunks xs) -> do-            mapM_ (lift . writeChan readEnd . Just) xs-            step' <- consumeSomeOutput writeEnd (Continue k)-            returnI $ f readEnd writeEnd tid step'---    ---------------------------------------------------------------------------    threadProc :: Chan (Maybe ByteString)-               -> Chan (Either SomeException (Stream ByteString))-               -> IO ()-    threadProc readEnd writeEnd = do-        stream <- getChanContents readEnd--        let bs = L.fromChunks $ streamToChunks stream-        let output = L.toChunks $ compFunc bs--        runIt output `catch` \(e::SomeException) ->-            writeChan writeEnd $ Left e--      where-        runIt (x:xs) = do-            writeChan writeEnd (toChunk x) >> runIt xs--        runIt []     = do-            writeChan writeEnd $ Right EOF--    ---------------------------------------------------------------------------    streamToChunks []            = []-    streamToChunks (Nothing:_)   = []-    streamToChunks ((Just x):xs) = x:(streamToChunks xs)-+    i0     = returnI st+    iB     = mapFlush                         =$ i0+    iZ     = Z.compress 5 Z.defaultWindowBits =$ iB+    iFinal = enumBuilderToByteString          =$ iZ -    ---------------------------------------------------------------------------    toChunk = Right . Chunks . (:[])+    mapFlush :: Monad m => Enumeratee ByteString Builder m b+    mapFlush = I.map ((`mappend` flush) . fromByteString)   ------------------------------------------------------------------------------

@@ -11,7 +11,7 @@   --------------------------------------------------------------------------------- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.+-- | Monadic analog to Read that uses ByteString instead of String. class Readable a where     fromBS :: Monad m => ByteString -> m a 

@@ -25,9 +25,10 @@     QuickCheck >= 2.3.0.2,     attoparsec >= 0.8.1 && < 0.10,     attoparsec-enumerator >= 0.2.0.3,-    base >= 4.3 && < 5,+    base >= 4 && < 5,     base16-bytestring == 0.1.*,     blaze-builder >= 0.2.1.4 && <0.4,+    blaze-builder-enumerator >= 0.2 && <0.3,     bytestring,     bytestring-nums,     case-insensitive >= 0.2 && < 0.4,@@ -54,7 +55,8 @@     transformers,     unix-compat >= 0.2 && <0.4,     vector >= 0.6 && <0.10,-    zlib+    zlib,+    zlib-enum >= 0.2.1 && <0.3        ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded                -fno-warn-unused-do-bind

@@ -155,7 +155,7 @@    where     f :: Snap ()-    f = (block $ unblock $ throw NoHandlerException) `catch` h+    f = (block $ unblock $ throw $ NoHandlerException "") `catch` h      g :: Snap ()     g = return () `catch` h@@ -268,7 +268,7 @@      ref <- newIORef 0 -    expectSpecificException NoHandlerException $+    expectSpecificException (NoHandlerException "") $         run_ $ evalSnap (act ref) (const $ return ()) (const $ return ()) rq      y <- readIORef ref@@ -408,11 +408,11 @@      b <- getBody rsp     coverShowInstance b-    coverShowInstance NoHandlerException+    coverShowInstance $ NoHandlerException ""     coverShowInstance GET     coverReadInstance GET     coverEqInstance GET-    coverEqInstance NoHandlerException+    coverEqInstance $ NoHandlerException ""     coverOrdInstance GET      Prelude.map (\(x,y) -> (x,show y)) (IM.toList statusReasonMap)

@@ -50,6 +50,7 @@         , testNopWhenContentEncodingSet         , testCompositionDoesn'tExplode         , testGzipLotsaChunks+        , testNoCompression         , testBadHeaders ]  @@ -400,4 +401,25 @@     -- string     frobnicate s = let s' = encode $ md5 $ L.fromChunks [s]                    in (s:frobnicate s')+++------------------------------------------------------------------------------+testNoCompression :: Test+testNoCompression = testProperty "gzip/noCompression" $+                    monadicIO $ forAllM arbitrary prop+  where+    prop :: L.ByteString -> PropertyM IO ()+    prop s = do+        (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $+                                     (noCompression >> textPlain s))+        assert $ getHeader "Content-Encoding" rsp == Just "identity"+        let body = rspBodyToEnum $ rspBody rsp++        s1 <- liftQ $+             runIteratee stream2stream >>= run_ . body++        assert $ s == s1+++