This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via a43874fce4ab984998a774e0467ab8234d9d646a (commit)
from 2a39406dc8a746dd9e2da02750c6a0f45d9a8ba1 (commit)
Summary of changes:
snap-server.cabal | 1 +
src/Snap/Internal/Http/Server.hs | 14 +++-
test/{suite => common}/Snap/Test/Common.hs | 7 ++
test/runTestsAndCoverage.sh | 1 -
test/suite/Test/Blackbox.hs | 116 +++++++++++++++++++++++++++-
test/suite/TestSuite.hs | 30 +++++---
6 files changed, 150 insertions(+), 19 deletions(-)
copy test/{suite => common}/Snap/Test/Common.hs (73%)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit a43874fce4ab984998a774e0467ab8234d9d646a
Author: Gregory Collins <[email protected]>
Date: Thu Sep 9 17:21:56 2010 -0400
Get blackbox test for 'echo' working
diff --git a/snap-server.cabal b/snap-server.cabal
index e0b1ab5..a7cc12c 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -59,6 +59,7 @@ extra-source-files:
test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs,
test/common/Paths_snap_server.hs,
test/common/Test/Common/TestHandler.hs
+ test/common/Snap/Test/Common.hs
test/data/fileServe/foo.bin,
test/data/fileServe/foo.bin.bin.bin,
test/data/fileServe/foo.html,
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 40988ed..66eda6a 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -614,16 +614,22 @@ sendResponse rsp' writeEnd onSendFile = do
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
- (Enum e) -> lift $ whenEnum headerString e
+ (Enum e) -> lift $ whenEnum headerString rsp e
(SendFile f) -> lift $ whenSendFile headerString rsp f
return $! (bs,x)
where
--------------------------------------------------------------------------
- whenEnum :: ByteString -> (forall x . Enumerator IO x) -> Iteratee IO
(a,Int64)
- whenEnum hs e = do
- let enum = enumBS hs >. e >. enumEof
+ whenEnum :: ByteString
+ -> Response
+ -> (forall x . Enumerator IO x)
+ -> Iteratee IO (a,Int64)
+ whenEnum hs rsp e = do
+ let enum = if rspDetachedBody rsp
+ then enumBS hs >. e
+ else enumBS hs >. e >. enumEof
+
let hl = fromIntegral $ S.length hs
(x,bs) <- joinIM $ enum (countBytes writeEnd)
diff --git a/test/common/Snap/Test/Common.hs b/test/common/Snap/Test/Common.hs
new file mode 100644
index 0000000..f9770f9
--- /dev/null
+++ b/test/common/Snap/Test/Common.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
+module Snap.Test.Common where
+
+import Control.Monad
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Internal (c2w)
+import Data.Iteratee.WrappedByteString
+import Data.Word
+import Test.QuickCheck
+
+
+instance Show (WrappedByteString Word8) where
+ show (WrapBS s) = show s
+
+instance Arbitrary S.ByteString where
+ arbitrary = liftM (S.pack . map c2w) arbitrary
+
+instance Arbitrary L.ByteString where
+ arbitrary = do
+ n <- choose(0,5)
+ chunks <- replicateM n arbitrary
+ return $ L.fromChunks chunks
+
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
index be73ea5..48f8470 100755
--- a/test/runTestsAndCoverage.sh
+++ b/test/runTestsAndCoverage.sh
@@ -1,7 +1,6 @@
#!/bin/sh
set -e
-set -x
SUITE=./dist/build/testsuite/testsuite
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index d5ae3ee..c73633e 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -3,11 +3,121 @@
{-# LANGUAGE PackageImports #-}
module Test.Blackbox
- ( tests ) where
+ ( tests
+ , startTestServer ) where
+import Control.Concurrent
+import Control.Exception (try, SomeException)
+import Control.Monad
+import "monads-fd" Control.Monad.Trans
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as LC
+import Data.ByteString (ByteString)
+import Data.ByteString.Internal (c2w, w2c)
+import Data.Char
+import Data.Int
+import Data.IORef
+import Data.Iteratee.WrappedByteString
+import qualified Data.Map as Map
+import Data.Maybe (fromJust)
+import Data.Monoid
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Word
+import qualified Network.URI as URI
+import qualified Network.HTTP as HTTP
+import Prelude hiding (take)
+import qualified Prelude
import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.HUnit hiding (Test, path)
+import Test.QuickCheck
+import qualified Test.QuickCheck.Monadic as QC
+import Test.QuickCheck.Monadic hiding (run, assert)
+import Snap.Http.Server
+import Snap.Iteratee
+import Snap.Test.Common ()
+import Snap.Types
-tests :: [Test]
-tests = []
+import Test.Common.TestHandler
+
+
+startTestServer :: IO (ThreadId,Int)
+startTestServer = do
+ tid <- forkIO $
+ httpServe "*"
+ port
+ "localhost"
+ (Just "ts-access.log")
+ (Just "ts-error.log")
+ testHandler
+ waitabit
+
+ return $ (tid, port)
+
+ where
+ port = 8199
+
+
+tests :: Int -> [Test]
+tests port = [ testPong port
+ , testEcho port ]
+
+
+testPong :: Int -> Test
+testPong port = testCase "blackbox/pong" $ do
+ rsp <- HTTP.simpleHTTP $
+ HTTP.getRequest $
+ "http://localhost:"; ++ show port ++ "/pong"
+
+ doc <- HTTP.getResponseBody rsp
+ assertEqual "pong response" "PONG" doc
+
+
+testEcho :: Int -> Test
+testEcho port = testProperty "blackbox/echo" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop txt = do
+ let uri = fromJust $
+ URI.parseURI $
+ "http://localhost:"; ++ show port ++ "/echo"
+
+ let len = S.length txt
+
+ let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
+ let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
+
+ rsp <- QC.run $ HTTP.simpleHTTP $ req { HTTP.rqBody =
(txt::S.ByteString) }
+ doc <- QC.run $ HTTP.getResponseBody rsp
+
+ QC.assert $ txt == doc
+
+
+{-
+foo = do
+ let uri = fromJust $
+ URI.parseURI $
+ "http://localhost:3000/echo";
+
+ let txt = "fdslkjflkdsjflkdsjfldskjflds" :: S.ByteString
+ let len = S.length txt
+
+ let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
+ let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
+
+ rsp <- HTTP.simpleHTTP $ req { HTTP.rqBody = txt }
+ doc <- HTTP.getResponseBody rsp
+
+ putStrLn $ "txt: " ++ show txt
+ putStrLn $ "doc: " ++ show doc
+-}
+
+
+------------------------------------------------------------------------------
+waitabit :: IO ()
+waitabit = threadDelay $ 2*((10::Int)^(6::Int))
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
index ddf663a..9e4425e 100644
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -1,6 +1,9 @@
module Main where
-import Test.Framework (defaultMain, testGroup)
+import Control.Concurrent (killThread)
+import Test.Framework (defaultMain, testGroup)
+
+
import qualified Data.Concurrent.HashMap.Tests
import qualified Snap.Internal.Http.Parser.Tests
@@ -8,13 +11,18 @@ import qualified Snap.Internal.Http.Server.Tests
import qualified Test.Blackbox
main :: IO ()
-main = defaultMain tests
- where tests = [ testGroup "Data.Concurrent.HashMap.Tests"
- Data.Concurrent.HashMap.Tests.tests
- , testGroup "Snap.Internal.Http.Parser.Tests"
- Snap.Internal.Http.Parser.Tests.tests
- , testGroup "Snap.Internal.Http.Server.Tests"
- Snap.Internal.Http.Server.Tests.tests
- , testGroup "Test.Blackbox"
- Test.Blackbox.tests
- ]
+main = do
+ (tid,pt) <- Test.Blackbox.startTestServer
+ defaultMain $ tests pt
+ killThread tid
+
+ where tests pt =
+ [ testGroup "Data.Concurrent.HashMap.Tests"
+ Data.Concurrent.HashMap.Tests.tests
+ , testGroup "Snap.Internal.Http.Parser.Tests"
+ Snap.Internal.Http.Parser.Tests.tests
+ , testGroup "Snap.Internal.Http.Server.Tests"
+ Snap.Internal.Http.Server.Tests.tests
+ , testGroup "Test.Blackbox"
+ $ Test.Blackbox.tests pt
+ ]
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
