diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -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 diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -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 } diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -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 "\n\n" + writeBS "Directory Listing: " + writeBS uri + writeBS "" writeBS "
Directory Listing: " + writeBS "" + writeBS "
Directory Listing: " writeBS uri writeBS "
" writeBS "" - when (uri /= "/") $ + when (pInfo /= "") $ writeBS "" 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 "" + writeBS f + writeBS "" - 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 "" writeBS "
File NameTypeLast Modified" writeBS "
..DIR
" - writeBS (S.pack f) - writeBS "DIR
DIR
" - writeBS (S.pack f) - writeBS "" - writeBS (fileType mm f) + writeBS f + writeBS "" + writeBS (fileType mm f0) writeBS "" writeBS tm writeBS "
Powered by " writeBS "Snap
" + writeBS "" + 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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -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) ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/Readable.hs b/src/Snap/Util/Readable.hs --- a/src/Snap/Util/Readable.hs +++ b/src/Snap/Util/Readable.hs @@ -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 diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -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 diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs --- a/test/suite/Snap/Types/Tests.hs +++ b/test/suite/Snap/Types/Tests.hs @@ -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) diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -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 + + +