Add test for readRequestBody hang issue snapframework/snap-core#200

imalsogreg · Jun 25, 2014 · 7fb91c0 · 7fb91c0
1 parent 26818c9
commit 7fb91c0
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 6 deletions.
diff --git a/test/suite/Snap/Snaplet/Test/Tests.hs b/test/suite/Snap/Snaplet/Test/Tests.hs
@@ -5,6 +5,9 @@ module Snap.Snaplet.Test.Tests
 
 
 ------------------------------------------------------------------------------
+import           Control.Concurrent       (threadDelay)
+import           Control.Concurrent.Async (race)
+import           Control.Monad            (join)
 import qualified Data.Map as Map
 import           Test.Framework
 import           Test.Framework.Providers.HUnit
@@ -26,6 +29,7 @@ tests = testGroup "Snap.Snaplet.Test"
     , testEvalHandler'
     , testFailingEvalHandler
     , testFailingGetSnaplet
+--    , readRequestBodyHangIssue
     ]
 
 testRunHandler :: Test
@@ -91,3 +95,15 @@ testFailingGetSnaplet = testCase "getSnaplet failing" assertGetSnaplet
                          case init of
                            Left _ -> assertBool "" True
                            Right _ -> assertFailure "Should have failed in initializer"
+
+
+readRequestBodyHangIssue :: Test
+readRequestBodyHangIssue = testCase "readRequestBody doesn't hang" assertReadRqBody
+  where
+    assertReadRqBody = do let hdl = readRequestBody 5000 >>= writeLBS
+                          res <- race
+                                 (threadDelay 1000000)
+                                 (runHandler Nothing (ST.get "" Map.empty) hdl appInit)
+                          either (assertFailure . ("readRequestBody timeout" ++) . show)
+                            (either (assertFailure . show) ST.assertSuccess) res
+
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
@@ -59,13 +59,13 @@ main = do
                 testGroup "snap" [ --internalServerTests
 
                                    Snap.Snaplet.Auth.Tests.tests
---                                 , Snap.Snaplet.Test.Tests.tests
+                                 , Snap.Snaplet.Test.Tests.tests
 
-                                   , Snap.Snaplet.Heist.Tests.heistTests
-                                   , Snap.Snaplet.Config.Tests.configTests
-                                   , Snap.Snaplet.Internal.RST.Tests.tests
-                                   , Snap.Snaplet.Internal.LensT.Tests.tests
-                                   , Snap.Snaplet.Internal.Lensed.Tests.tests
+                                 , Snap.Snaplet.Heist.Tests.heistTests
+                                 , Snap.Snaplet.Config.Tests.configTests
+                                 , Snap.Snaplet.Internal.RST.Tests.tests
+                                 , Snap.Snaplet.Internal.LensT.Tests.tests
+                                 , Snap.Snaplet.Internal.Lensed.Tests.tests
                                  ]