snap-core 0.2.11 → 0.2.12
raw patch · 13 files changed
+174/−132 lines, 13 files
Files
- snap-core.cabal +22/−20
- src/Snap/Internal/Debug.hs +78/−32
- src/Snap/Internal/Http/Types.hs +13/−7
- src/Snap/Internal/Iteratee/Debug.hs +5/−1
- src/Snap/Internal/Types.hs +33/−16
- src/Snap/Iteratee.hs +4/−20
- src/Snap/Starter.hs +1/−1
- src/Snap/Types.hs +4/−2
- src/Snap/Util/GZip.hs +2/−0
- test/runTestsAndCoverage.sh +1/−0
- test/snap-core-testsuite.cabal +0/−15
- test/suite/Snap/Iteratee/Tests.hs +7/−7
- test/suite/Snap/Types/Tests.hs +4/−11
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.11+version: 0.2.12 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -98,29 +98,29 @@ test/suite/Snap/Util/GZip/Tests.hs -Flag debug- Description: Enable debug logging to stderr- Default: False--Flag testsuite- Description: Are we running the testsuite? Causes arguments to \"debug\" to- be evaluated but not printed.- Default: False- Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used. Default: False ++Flag no-debug+ Description: Disable any debug logging code. Without this flag, Snap will+ test the DEBUG environment variable to decide whether to do+ logging, and this introduces a tiny amount of overhead+ (a call into a function pointer) because the calls to 'debug'+ cannot be inlined. Users who want to squeeze out maximum+ performance can set the no-debug flag to get a version of Snap+ which has debug calls that should be inlined away.+ + Default: False++ Library hs-source-dirs: src - if flag(debug)- cpp-options: -DDEBUG-- if flag(testsuite)- cpp-options: -DDEBUG_TEST- build-depends: deepseq >= 1.1 && <1.2+ if flag(no-debug)+ cpp-options: -DNODEBUG if flag(portable) || os(windows) cpp-options: -DPORTABLE@@ -150,6 +150,7 @@ bytestring-nums, cereal >= 0.3 && < 0.4, containers,+ deepseq >= 1.1 && <1.2, directory, dlist >= 0.5 && < 0.6, filepath,@@ -173,16 +174,16 @@ else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -Executable snap- if flag(testsuite)- cpp-options: -DDEBUG_TEST- build-depends: deepseq >= 1.1 && <1.2 +Executable snap hs-source-dirs: src main-is: Snap/Starter.hs other-modules: Snap.StarterTH + if flag(no-debug)+ cpp-options: -DNODEBUG+ build-depends: attoparsec >= 0.8.1 && < 0.9, base >= 4 && < 5,@@ -190,6 +191,7 @@ bytestring-nums, cereal >= 0.3 && < 0.4, containers,+ deepseq >= 1.1 && <1.2, directory, directory-tree, dlist >= 0.5 && < 0.6,
src/Snap/Internal/Debug.hs view
@@ -1,63 +1,102 @@ -- | An internal Snap module for (optionally) printing debugging--- messages. Normally 'debug' does nothing, but you can pass \"-fdebug\" to--- @cabal install@ to build a @snap-core@ which debugs to stderr.+-- messages. Normally 'debug' does nothing, but if you set @DEBUG=1@ in the+-- environment you'll get debugging messages. We use 'unsafePerformIO' to make+-- sure that the call to 'getEnv' is only made once. -- -- /N.B./ this is an internal interface, please don't write external code that -- depends on it. -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-cse #-} -module Snap.Internal.Debug where -import Control.Monad.Trans--#ifdef DEBUG_TEST-import Control.DeepSeq--debug :: (MonadIO m) => String -> m ()-debug !s = let !s' = rnf s in return $! s' `deepseq` ()-{-# INLINE debug #-}--debugErrno :: (MonadIO m) => String -> m ()-debugErrno !s = let !s' = rnf s in return $! s' `deepseq` ()--#elif defined(DEBUG)+module Snap.Internal.Debug where ------------------------------------------------------------------------------ import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad.Trans+import Data.Char import Data.List import Data.Maybe import Foreign.C.Error+import System.Environment import System.IO import System.IO.Unsafe import Text.Printf ------------------------------------------------------------------------------ +debug, debugErrno :: forall m . (MonadIO m => String -> m ()) ++#ifndef NODEBUG++{-# NOINLINE debug #-}+debug = let !x = unsafePerformIO $! do+ !e <- try $ getEnv "DEBUG"+ + !f <- either (\(_::SomeException) -> return debugIgnore)+ (\x -> if x == "1" || x == "on"+ then return debugOn+ else if x == "testsuite"+ then return debugSeq+ else return debugIgnore)+ (fmap (map toLower) e)+ return $! f+ in x+++{-# NOINLINE debugErrno #-}+debugErrno = let !x = unsafePerformIO $ do+ e <- try $ getEnv "DEBUG"+ + !f <- either (\(_::SomeException) -> return debugErrnoIgnore)+ (\x -> if x == "1" || x == "on"+ then return debugErrnoOn+ else if x == "testsuite"+ then return debugErrnoSeq+ else return debugErrnoIgnore)+ (fmap (map toLower) e)+ return $! f+ in x++ ------------------------------------------------------------------------------+debugSeq :: (MonadIO m) => String -> m ()+debugSeq !s = let !s' = rnf s in return $! s' `deepseq` ()+{-# NOINLINE debugSeq #-}++debugErrnoSeq :: (MonadIO m) => String -> m ()+debugErrnoSeq !s = let !s' = rnf s in return $! s' `deepseq` ()+{-# NOINLINE debugErrnoSeq #-}++------------------------------------------------------------------------------ _debugMVar :: MVar () _debugMVar = unsafePerformIO $ newMVar () {-# NOINLINE _debugMVar #-} + -------------------------------------------------------------------------------debug :: (MonadIO m) => String -> m ()-debug s = liftIO $ withMVar _debugMVar $ \_ -> do- tid <- myThreadId- hPutStrLn stderr $ s' tid- hFlush stderr+debugOn :: (MonadIO m) => String -> m ()+debugOn s = liftIO $ withMVar _debugMVar $ \_ -> do+ tid <- myThreadId+ hPutStrLn stderr $ s' tid+ hFlush stderr where chop x = let y = fromMaybe x $ stripPrefix "ThreadId " x in printf "%8s" y s' t = "[" ++ chop (show t) ++ "] " ++ s -{-# INLINE debug #-}+{-# NOINLINE debugOn #-} -------------------------------------------------------------------------------debugErrno :: (MonadIO m) => String -> m ()-debugErrno loc = liftIO $ do+debugErrnoOn :: (MonadIO m) => String -> m ()+debugErrnoOn loc = liftIO $ do err <- getErrno let ex = errnoToIOError loc err Nothing Nothing debug $ show ex@@ -65,13 +104,20 @@ #else --------------------------------------------------------------------------------debug :: (MonadIO m) => String -> m ()-debug _ = return ()+debug = debugIgnore {-# INLINE debug #-} -debugErrno :: (MonadIO m) => String -> m ()-debugErrno _ = return ()-------------------------------------------------------------------------------+debugErrno = debugErrnoIgnore+{-# INLINE debugErrno #-} #endif++------------------------------------------------------------------------------+debugIgnore :: (MonadIO m) => String -> m ()+debugIgnore _ = return ()+{-# INLINE debugIgnore #-}++debugErrnoIgnore :: (MonadIO m) => String -> m ()+debugErrnoIgnore _ = return ()+{-# INLINE debugErrnoIgnore #-}+------------------------------------------------------------------------------
src/Snap/Internal/Http/Types.hs view
@@ -168,6 +168,7 @@ -- request type ------------------------------------------------------------------------------ +-- | An existential wrapper for the 'Enumerator' type data SomeEnumerator = SomeEnumerator (forall a . Enumerator a) @@ -364,20 +365,24 @@ ------------------------------------------------------------------------------ -- | Represents an HTTP response. data Response = Response- { rspHeaders :: Headers- , rspHttpVersion :: !HttpVersion+ { rspHeaders :: Headers+ , rspHttpVersion :: !HttpVersion -- | We will need to inspect the content length no matter what, and -- looking up \"content-length\" in the headers and parsing the number -- out of the text will be too expensive.- , rspContentLength :: !(Maybe Int64)- , rspBody :: ResponseBody+ , rspContentLength :: !(Maybe Int64)+ , rspBody :: ResponseBody -- | Returns the HTTP status code.- , rspStatus :: !Int+ , rspStatus :: !Int -- | Returns the HTTP status explanation string.- , rspStatusReason :: !ByteString+ , rspStatusReason :: !ByteString++ -- | If true, we are transforming the request body with+ -- 'transformRequestBody'+ , rspTransformingRqBody :: !Bool } @@ -447,7 +452,8 @@ -- | An empty 'Response'. emptyResponse :: Response-emptyResponse = Response Map.empty (1,1) Nothing (Enum return) 200 "OK"+emptyResponse = Response Map.empty (1,1) Nothing (Enum return) 200+ "OK" False ------------------------------------------------------------------------------
src/Snap/Internal/Iteratee/Debug.hs view
@@ -48,8 +48,12 @@ iterateeDebugWrapper :: String -> Iteratee IO a -> Iteratee IO a iterateeDebugWrapper name iter = IterateeG f where- f c@(EOF _) = do+ f c@(EOF Nothing) = do debug $ name ++ ": got EOF: " ++ show c+ runIter iter c++ f c@(EOF (Just e)) = do+ debug $ name ++ ": got EOF **error**: " ++ show c runIter iter c f c@(Chunk _) = do
src/Snap/Internal/Types.hs view
@@ -27,6 +27,8 @@ ------------------------------------------------------------------------------ import Snap.Iteratee hiding (Enumerator) import Snap.Internal.Http.Types+import Snap.Internal.Debug+import Snap.Internal.Iteratee.Debug ------------------------------------------------------------------------------@@ -199,32 +201,42 @@ --------------------------------------------------------------------------------- | Detaches the request body's 'Enumerator' from the 'Request' and--- returns it. You would want to use this if you needed to send the--- HTTP request body (transformed or otherwise) through to the output--- in O(1) space. (Examples: transcoding, \"echo\", etc)+-- | Normally Snap is careful to ensure that the request body is fully consumed+-- after your web handler runs, but before the 'Response' enumerator is+-- streamed out the socket. If you want to transform the request body into some+-- output in O(1) space, you should use this function. ----- Normally Snap is careful to ensure that the request body is fully--- consumed after your web handler runs; this function is marked--- \"unsafe\" because it breaks this guarantee and leaves the--- responsibility up to you. If you don't fully consume the--- 'Enumerator' you get here, the next HTTP request in the pipeline--- (if any) will misparse. Be careful with exception handlers.-unsafeDetachRequestBody :: Snap (Enumerator a)-unsafeDetachRequestBody = do+-- Note that upon calling this function, response processing finishes early as+-- if you called 'finishWith'. Make sure you set any content types, headers,+-- cookies, etc. before you call this function.+--+transformRequestBody :: (forall a . Enumerator a)+ -- ^ the output 'Iteratee' is passed to this+ -- 'Enumerator', and then the resulting 'Iteratee' is+ -- fed the request body stream. Your 'Enumerator' is+ -- responsible for transforming the input.+ -> Snap ()+transformRequestBody trans = do req <- getRequest let ioref = rqBody req senum <- liftIO $ readIORef ioref let (SomeEnumerator enum) = senum liftIO $ writeIORef ioref (SomeEnumerator $ return . Iter.joinI . Iter.take 0)- return enum + origRsp <- getResponse+ let rsp = setResponseBody+ (\writeEnd -> do+ i <- trans writeEnd+ enum $ iterateeDebugWrapper "transformRequestBody" i)+ $ origRsp { rspTransformingRqBody = True }+ finishWith rsp + ------------------------------------------------------------------------------ -- | Short-circuits a 'Snap' monad action early, storing the given -- 'Response' value in its state.-finishWith :: Response -> Snap ()+finishWith :: Response -> Snap a finishWith = Snap . return . Just . Left {-# INLINE finishWith #-} @@ -385,10 +397,15 @@ -- 'Response' object stored in a 'Snap' monad. Note that the target URL is not -- validated in any way. redirect' :: ByteString -> Int -> Snap ()-redirect' target status =+redirect' target status = do+ r <- getResponse+ finishWith $ setResponseCode status- $ setHeader "Location" target emptyResponse+ $ setContentLength 0+ $ modifyResponseBody (const $ enumBS "")+ $ setHeader "Location" target r+ {-# INLINE redirect' #-}
src/Snap/Iteratee.hs view
@@ -71,7 +71,6 @@ import Control.Exception (SomeException) import System.IO.Posix.MMap import System.PosixCompat.Files-import System.Posix.Types #endif ------------------------------------------------------------------------------@@ -195,11 +194,7 @@ -- socket) it'll get changed out from underneath you, breaking referential -- transparency. Use with caution! ----- The IORef returned can be set to True to "cancel" buffering. We added this--- so that transfer-encoding: chunked (which needs its own buffer and therefore--- doesn't need /its/ output buffered) can switch the outer buffer off.----unsafeBufferIteratee :: Iteratee IO a -> IO (Iteratee IO a, IORef Bool)+unsafeBufferIteratee :: Iteratee IO a -> IO (Iteratee IO a) unsafeBufferIteratee iter = do buf <- mkIterateeBuffer unsafeBufferIterateeWithBuffer buf iter@@ -214,28 +209,17 @@ -- -- This version accepts a buffer created by 'mkIterateeBuffer'. ----- The IORef returned can be set to True to "cancel" buffering. We added this--- so that transfer-encoding: chunked (which needs its own buffer and therefore--- doesn't need /its/ output buffered) can switch the outer buffer off.--- unsafeBufferIterateeWithBuffer :: ForeignPtr CChar -> Iteratee IO a- -> IO (Iteratee IO a, IORef Bool)+ -> IO (Iteratee IO a) unsafeBufferIterateeWithBuffer buf iteratee = do- esc <- newIORef False- return $! (start esc iteratee, esc)+ return $! start iteratee where- start esc iter = IterateeG $! checkRef esc iter+ start iter = IterateeG $! f 0 iter go bytesSoFar iter = {-# SCC "unsafeBufferIteratee/go" #-} IterateeG $! f bytesSoFar iter-- checkRef esc iter ch = do- quit <- readIORef esc- if quit- then runIter iter ch- else f 0 iter ch sendBuf n iter = {-# SCC "unsafeBufferIteratee/sendBuf" #-}
src/Snap/Starter.hs view
@@ -48,7 +48,7 @@ else writeFile f c insertProjName c = T.unpack $ T.replace (T.pack "projname")- (T.pack projName) c+ (T.pack $ filter (/='_') projName) c ------------------------------------------------------------------------------ initProject :: [String] -> IO ()
src/Snap/Types.hs view
@@ -37,10 +37,11 @@ -- ** Logging , logError - -- ** Grabbing request bodies+ -- ** Grabbing/transforming request bodies , runRequestBody , getRequestBody- , unsafeDetachRequestBody+ , transformRequestBody+ -- * HTTP Datatypes and Functions -- $httpDoc --@@ -107,6 +108,7 @@ -- * Iteratee , Enumerator+ , SomeEnumerator(..) -- * HTTP utilities , formatHttpTime
src/Snap/Util/GZip.hs view
@@ -141,6 +141,7 @@ gzipCompression ce = modifyResponse f where f = setHeader "Content-Encoding" ce .+ setHeader "Vary" "Accept-Encoding" . clearContentLength . modifyResponseBody gcompress @@ -150,6 +151,7 @@ compressCompression ce = modifyResponse f where f = setHeader "Content-Encoding" ce .+ setHeader "Vary" "Accept-Encoding" . clearContentLength . modifyResponseBody ccompress
test/runTestsAndCoverage.sh view
@@ -2,6 +2,7 @@ set -e +export DEBUG=testsuite SUITE=./dist/build/testsuite/testsuite export LC_ALL=C
test/snap-core-testsuite.cabal view
@@ -3,15 +3,6 @@ build-type: Simple cabal-version: >= 1.6 -Flag debug- Description: Enable debug logging to stderr- Default: False--Flag testsuite- Description: Are we running the testsuite? Causes arguments to \"debug\" to- be evaluated but not printed.- Default: True- Flag portable Description: Compile in cross-platform mode. No platform-specific code or optimizations such as C routines will be used.@@ -20,12 +11,6 @@ Executable testsuite hs-source-dirs: ../src suite main-is: TestSuite.hs-- if flag(debug)- cpp-options: -DDEBUG-- if flag(testsuite)- cpp-options: -DDEBUG_TEST if flag(portable) || os(windows) cpp-options: -DPORTABLE
test/suite/Snap/Iteratee/Tests.hs view
@@ -197,8 +197,8 @@ bufferAndRun :: Iteratee IO a -> L.ByteString -> IO a bufferAndRun ii s = do- (i,_) <- unsafeBufferIteratee ii- iter <- enumLBS s i+ i <- unsafeBufferIteratee ii+ iter <- enumLBS s i run iter @@ -219,7 +219,7 @@ testUnsafeBuffer2 = testCase "testUnsafeBuffer2" prop where prop = do- (i,_) <- unsafeBufferIteratee $ drop 4 >> copyingStream2stream+ i <- unsafeBufferIteratee $ drop 4 >> copyingStream2stream s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap H.assertEqual "s == 'efgh'" "efgh" s@@ -244,13 +244,13 @@ monadicIO $ forAllM arbitrary prop where prop s = do- (i,_) <- liftQ $- unsafeBufferIteratee (copyingStream2stream >> throwErr (Err "foo"))+ i <- liftQ $+ unsafeBufferIteratee (copyingStream2stream >> throwErr (Err "foo")) i' <- liftQ $ enumLBS s i expectException $ run i' - (j,_) <- liftQ $- unsafeBufferIteratee (throwErr (Err "foo") >> copyingStream2stream)+ j <- liftQ $+ unsafeBufferIteratee (throwErr (Err "foo") >> copyingStream2stream) j' <- liftQ $ enumLBS s j expectException $ run j'
test/suite/Snap/Types/Tests.hs view
@@ -219,13 +219,10 @@ assertEqual "rq body" "zazzle" v1 assertEqual "rq body 2" "" v2 - _ <- goBody $ g mvar1 mvar2- w1 <- takeMVar mvar1- w2 <- takeMVar mvar2-- assertEqual "rq body" "zazzle" w1- assertEqual "rq body 2" "" w2+ (_,rsp) <- goBody g+ bd <- getBody rsp + assertEqual "detached rq body" "zazzle" bd where@@ -233,11 +230,7 @@ getRequestBody >>= liftIO . putMVar mvar1 getRequestBody >>= liftIO . putMVar mvar2 - g mvar1 mvar2 = do- enum <- unsafeDetachRequestBody- bs <- liftM fromWrap (liftIO $ enum stream2stream >>= run)- liftIO $ putMVar mvar1 bs- getRequestBody >>= liftIO . putMVar mvar2+ g = transformRequestBody return testTrivials :: Test