Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add regression test for broken timeout tickle

  • Loading branch information...
commit dcfa97181c8c9e05e401bec20ed766750d1afbc2 1 parent 40519bd
@gregorycollins gregorycollins authored
View
2  .gitignore
@@ -1,5 +1,7 @@
*~
dist/
+cabal-dev
+**/cabal-dev
*.tix
.hpc
.hpc-blackbox
View
34 test/common/Test/Common/TestHandler.hs
@@ -4,6 +4,7 @@
module Test.Common.TestHandler (testHandler) where
import Blaze.ByteString.Builder
+import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
@@ -22,6 +23,38 @@ import System.Directory
import Test.Common.Rot13 (rot13)
+
+------------------------------------------------------------------------------
+-- timeout handling
+------------------------------------------------------------------------------
+timeoutTickleHandler :: Snap ()
+timeoutTickleHandler = do
+ noCompression -- FIXME: remove this when zlib-bindings and
+ -- zlib-enumerator support gzip stream flushing
+ modifyResponse $ setResponseBody (trickleOutput 6)
+ . setContentType "text/plain"
+ setTimeout 2
+
+ where
+ trickleOutput :: Int -> Enumerator Builder IO a
+ trickleOutput n = concatEnums $ dots `interleave` delays
+ where
+ enumOne = enumList 1 [fromByteString ".\n", flush]
+ delay st = do
+ liftIO $ threadDelay 1000000
+ returnI st
+
+ interleave x0 y0 = (go id x0 y0) []
+ where
+ go !dl [] ys = dl . (++ys)
+ go !dl xs [] = dl . (++xs)
+ go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys
+
+ dots = replicate n enumOne
+ delays = replicate n delay
+
+
+------------------------------------------------------------------------------
pongHandler :: Snap ()
pongHandler = modifyResponse $
setResponseBody (enumBuilder $ fromByteString "PONG") .
@@ -148,4 +181,5 @@ testHandler = withCompression $
, ("respcode/:code" , responseHandler )
, ("upload/form" , uploadForm )
, ("upload/handle" , uploadHandler )
+ , ("timeout/tickle" , timeoutTickleHandler )
]
View
18 test/suite/Test/Blackbox.hs
@@ -9,9 +9,11 @@ module Test.Blackbox
, startTestServer ) where
--------------------------------------------------------------------------------
+import Blaze.ByteString.Builder
import Control.Concurrent
import Control.Exception (SomeException, catch, throwIO)
import Control.Monad
+import Control.Monad.Trans
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
@@ -36,6 +38,8 @@ import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic hiding (run, assert)
------------------------------------------------------------------------------
import Snap.Internal.Debug
+import Snap.Iteratee hiding (map, head)
+import qualified Snap.Iteratee as I
import Snap.Http.Server
import Snap.Test.Common
import Test.Common.Rot13
@@ -53,6 +57,7 @@ testFunctions = [ testPong
, testBigResponse
, testPartial
, testFileUpload
+ , testTimeoutTickle
]
@@ -412,3 +417,16 @@ post url body hdrs = do
, HTTP.requestHeaders = hdrs }
+------------------------------------------------------------------------------
+-- This test checks two things:
+--
+-- 1. that the timeout tickling logic works
+-- 2. that "flush" is passed along through a gzip operation.
+testTimeoutTickle :: Bool -> Int -> String -> Test
+testTimeoutTickle ssl port name =
+ testCase (name ++ "/blackbox/timeout/tickle") $ do
+ let uri = (if ssl then "https" else "http")
+ ++ "://127.0.0.1:" ++ show port ++ "/timeout/tickle"
+ doc <- liftM (S.concat . L.toChunks) $ fetch uri
+ let expected = S.concat $ replicate 6 ".\n"
+ assertEqual "response equal" expected doc
Please sign in to comment.
Something went wrong with that request. Please try again.