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 0628a7fadbef0eadd6bbef6ae4b862bf37f57f48 (commit)
from 65ed2c88b5bc7f4296ab123c369f4ec8d5cebf4f (commit)
Summary of changes:
snap-server.cabal | 2 +-
test/common/Snap/Test/Common.hs | 5 +---
test/common/Test/Common/Rot13.hs | 19 ++++++++++++++
test/common/Test/Common/TestHandler.hs | 25 ++++++++++++++----
test/suite/Snap/Test/Common.hs | 20 ---------------
test/suite/Test/Blackbox.hs | 42 ++++++++++++++++---------------
6 files changed, 62 insertions(+), 51 deletions(-)
create mode 100644 test/common/Test/Common/Rot13.hs
delete mode 100644 test/suite/Snap/Test/Common.hs
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 0628a7fadbef0eadd6bbef6ae4b862bf37f57f48
Author: Gregory Collins <[email protected]>
Date: Fri Sep 10 16:39:06 2010 -0400
Add rot13 test, another example of transformRequestBody
diff --git a/snap-server.cabal b/snap-server.cabal
index a7cc12c..afe024e 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/Test/Common/Rot13.hs
test/common/Snap/Test/Common.hs
test/data/fileServe/foo.bin,
test/data/fileServe/foo.bin.bin.bin,
@@ -70,7 +71,6 @@ extra-source-files:
test/suite/Data/Concurrent/HashMap/Tests.hs,
test/suite/Snap/Internal/Http/Parser/Tests.hs,
test/suite/Snap/Internal/Http/Server/Tests.hs,
- test/suite/Snap/Test/Common.hs,
test/suite/TestSuite.hs,
test/testserver/Main.hs,
test/testserver/static/hello.txt
diff --git a/test/common/Snap/Test/Common.hs b/test/common/Snap/Test/Common.hs
index f9770f9..14fc25e 100644
--- a/test/common/Snap/Test/Common.hs
+++ b/test/common/Snap/Test/Common.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -12,9 +11,7 @@ import Data.Iteratee.WrappedByteString
import Data.Word
import Test.QuickCheck
-
-instance Show (WrappedByteString Word8) where
- show (WrapBS s) = show s
+import Snap.Internal.Iteratee.Debug ()
instance Arbitrary S.ByteString where
arbitrary = liftM (S.pack . map c2w) arbitrary
diff --git a/test/common/Test/Common/Rot13.hs b/test/common/Test/Common/Rot13.hs
new file mode 100644
index 0000000..89c3250
--- /dev/null
+++ b/test/common/Test/Common/Rot13.hs
@@ -0,0 +1,19 @@
+module Test.Common.Rot13 (rot13) where
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as S
+import Data.Char
+
+rotone :: Char -> Char
+rotone x | acc x = f
+ | otherwise = x
+ where
+ aA = ord 'A'
+ aa = ord 'a'
+ xx = ord x
+ f = g $ if isAsciiUpper x then aA else aa
+ g st = chr $ st + (xx - st + 13) `mod` 26
+ acc c = isAlpha c && (isAsciiUpper c || isAsciiLower c)
+
+rot13 :: ByteString -> ByteString
+rot13 = S.map rotone
diff --git a/test/common/Test/Common/TestHandler.hs
b/test/common/Test/Common/TestHandler.hs
index 81738dd..be553fa 100644
--- a/test/common/Test/Common/TestHandler.hs
+++ b/test/common/Test/Common/TestHandler.hs
@@ -7,14 +7,15 @@ module Test.Common.TestHandler (testHandler) where
import Control.Monad
import qualified Data.ByteString.Char8 as B
+import Data.Iteratee.WrappedByteString
import Data.Maybe
import Snap.Iteratee hiding (Enumerator)
import Snap.Types
import Snap.Http.Server
import Snap.Util.FileServe
-
import Snap.Internal.Iteratee.Debug
+import Test.Common.Rot13 (rot13)
pongHandler :: Snap ()
@@ -32,6 +33,17 @@ echoHandler :: Snap ()
echoHandler = transformRequestBody return
+rot13Handler :: Snap ()
+rot13Handler = transformRequestBody $ return . f
+ where
+ f i = IterateeG $ \ch -> do
+ case ch of
+ (EOF _) -> runIter i ch
+ (Chunk (WrapBS s)) -> do
+ i' <- liftM liftI $ runIter i $ Chunk $ WrapBS $ rot13
s
+ return $ Cont (f i') Nothing
+
+
responseHandler :: Snap ()
responseHandler = do
!code <- liftM (read . B.unpack . fromMaybe "503") $ getParam "code"
@@ -41,10 +53,11 @@ responseHandler = do
testHandler :: Snap ()
testHandler =
- route [ ("pong", pongHandler)
- , ("echo", echoHandler)
- , ("echoUri", echoUriHandler)
- , ("fileserve", fileServe "testserver/static")
- , ("respcode/:code", responseHandler)
+ route [ ("pong" , pongHandler )
+ , ("echo" , echoHandler )
+ , ("rot13" , rot13Handler )
+ , ("echoUri" , echoUriHandler )
+ , ("fileserve" , fileServe "testserver/static")
+ , ("respcode/:code" , responseHandler )
]
diff --git a/test/suite/Snap/Test/Common.hs b/test/suite/Snap/Test/Common.hs
deleted file mode 100644
index 65f3124..0000000
--- a/test/suite/Snap/Test/Common.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# 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 Test.QuickCheck
-
-
-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/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index c73633e..e85784b 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -43,9 +43,16 @@ import Snap.Iteratee
import Snap.Test.Common ()
import Snap.Types
+import Test.Common.Rot13
import Test.Common.TestHandler
+tests :: Int -> [Test]
+tests port = [ testPong port
+ , testEcho port
+ , testRot13 port ]
+
+
startTestServer :: IO (ThreadId,Int)
startTestServer = do
tid <- forkIO $
@@ -63,11 +70,6 @@ startTestServer = do
port = 8199
-tests :: Int -> [Test]
-tests port = [ testPong port
- , testEcho port ]
-
-
testPong :: Int -> Test
testPong port = testCase "blackbox/pong" $ do
rsp <- HTTP.simpleHTTP $
@@ -98,24 +100,24 @@ testEcho port = testProperty "blackbox/echo" $
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
+testRot13 :: Int -> Test
+testRot13 port = testProperty "blackbox/rot13" $
+ monadicIO $ forAllM arbitrary prop
+ where
+ prop txt = do
+ let uri = fromJust $
+ URI.parseURI $
+ "http://localhost:"; ++ show port ++ "/rot13"
- let req' = (HTTP.mkRequest HTTP.POST uri) :: HTTP.Request S.ByteString
- let req = HTTP.replaceHeader HTTP.HdrContentLength (show len) req'
+ let len = S.length txt
- rsp <- HTTP.simpleHTTP $ req { HTTP.rqBody = txt }
- doc <- HTTP.getResponseBody rsp
+ 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
- putStrLn $ "txt: " ++ show txt
- putStrLn $ "doc: " ++ show doc
--}
+ QC.assert $ txt == rot13 doc
------------------------------------------------------------------------------
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
