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 c5f14197fa80fe4eb9343ab9caed2e530fbfb8b9 (commit)
from 7761dd4fcb79209d2af3f429bd6585288def2861 (commit)
Summary of changes:
test/common/Test/Common/TestHandler.hs | 5 +-
test/snap-server-testsuite.cabal | 2 +
test/suite/Test/Blackbox.hs | 121 ++++++++++++++++++++++++++------
3 files changed, 103 insertions(+), 25 deletions(-)
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 c5f14197fa80fe4eb9343ab9caed2e530fbfb8b9
Author: Gregory Collins <[email protected]>
Date: Sat Feb 5 19:47:58 2011 -0500
Blackbox test for file upload
diff --git a/test/common/Test/Common/TestHandler.hs
b/test/common/Test/Common/TestHandler.hs
index e02370e..e43d17e 100644
--- a/test/common/Test/Common/TestHandler.hs
+++ b/test/common/Test/Common/TestHandler.hs
@@ -8,6 +8,7 @@ import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
+import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
@@ -106,7 +107,7 @@ uploadHandler = do
c <- liftIO $ S.readFile fp
return (x,c)) xs
- let m = Map.toAscList $ Map.fromList files
+ let m = sort files
params <- liftM (Prelude.map (\(a,b) -> (a,S.concat b)) .
Map.toAscList .
@@ -124,7 +125,7 @@ uploadHandler = do
, fromByteString "\nValue:\n"
, fromByteString v
, fromByteString "\n\n"
- , buildRqParams xs ]
+ , builder ty xs ]
buildRqParams = builder "Param"
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 9cf674b..36333ac 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -26,6 +26,7 @@ Executable testsuite
attoparsec >= 0.8.1 && < 0.9,
attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
+ base16-bytestring == 0.1.*,
binary >= 0.5 && < 0.6,
blaze-builder >= 0.2.1.4 && <0.3,
blaze-builder-enumerator >= 0.2.0 && <0.3,
@@ -87,6 +88,7 @@ Executable pongserver
attoparsec >= 0.8.1 && < 0.9,
attoparsec-enumerator >= 0.2.0.1 && < 0.3,
base >= 4 && < 5,
+ base16-bytestring == 0.1.*,
blaze-builder >= 0.2.1.4 && <0.3,
blaze-builder-enumerator >= 0.2.0 && <0.3,
bytestring,
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 746050a..1d0e934 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -7,30 +7,32 @@ module Test.Blackbox
, ssltests
, startTestServer ) where
+--------------------------------------------------------------------------------
+import Control.Concurrent
+import Control.Exception (SomeException, catch)
+import Control.Monad
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Char8 as S
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Int
+import Data.List
+import qualified Network.HTTP.Enumerator as HTTP
+import qualified Network.Socket.ByteString as N
+import Prelude hiding (catch, take)
+import System.Timeout
+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 Control.Concurrent
-import Control.Exception (SomeException, catch)
-import Control.Monad
-import qualified Data.ByteString.Char8 as S
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as L
-import Data.Int
-import qualified Network.HTTP.Enumerator as HTTP
-import qualified Network.Socket.ByteString as N
-import Prelude hiding (catch, take)
-import System.Timeout
-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.Test.Common
-import Test.Common.Rot13
-import Test.Common.TestHandler
+import Snap.Http.Server
+import Snap.Test.Common
+import Test.Common.Rot13
+import Test.Common.TestHandler
------------------------------------------------------------------------------
testFunctions :: [Bool -> Int -> String -> Test]
@@ -43,6 +45,7 @@ testFunctions = [ testPong
, testBlockingRead
, testBigResponse
, testPartial
+ , testFileUpload
]
@@ -145,6 +148,78 @@ testEcho ssl port name = testProperty (name ++
"/blackbox/echo") $
------------------------------------------------------------------------------
+testFileUpload :: Bool -> Int -> String -> Test
+testFileUpload ssl port name = testProperty (name ++ "/blackbox/upload") $
+ monadicIO $ forAllM arbitrary prop
+ where
+ boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"
+
+ prefix = [ "--"
+ , boundary
+ , "\r\n"
+ , "content-disposition: form-data; name=\"submit\"\r\n"
+ , "\r\nSubmit\r\n" ]
+
+ body kvps = L.concat $ prefix ++ concatMap part kvps ++ suffix
+ where
+ part (k,v) = [ "--"
+ , boundary
+ , "\r\ncontent-disposition: attachment; filename=\""
+ , k
+ , "\"\r\nContent-Type: text/plain\r\n\r\n"
+ , v
+ , "\r\n" ]
+
+ suffix = [ "--", boundary, "--\r\n" ]
+
+ hdrs = [ ("Content-type", S.concat $ [ "multipart/form-data; boundary=" ]
+ ++ L.toChunks boundary) ]
+
+ b16 (k,v) = (ne $ e k, e v)
+ where
+ ne s = if L.null s then "file" else s
+ e s = L.fromChunks [ B16.encode $ S.concat $ L.toChunks s ]
+
+ response kvps = L.concat $ [ "Param:\n"
+ , "submit\n"
+ , "Value:\n"
+ , "Submit\n\n" ] ++ concatMap responseKVP kvps
+
+ responseKVP (k,v) = [ "File:\n"
+ , k
+ , "\nValue:\n"
+ , v
+ , "\n\n" ]
+
+ prop kvps' = do
+ let kvps = sort $ map b16 kvps'
+
+ let uri = (if ssl then "https" else "http")
+ ++ "://127.0.0.1:" ++ show port ++ "/upload/handle"
+
+ req0 <- QC.run $ HTTP.parseUrl uri
+ let req = req0 { HTTP.requestBody = body kvps
+ , HTTP.method = "POST"
+ , HTTP.requestHeaders = hdrs }
+
+ let txt = response kvps
+ rsp <- QC.run $ HTTP.httpLbs req
+ let doc = HTTP.responseBody rsp
+
+ when (txt /= doc) $ QC.run $ do
+ L.putStrLn "expected:"
+ L.putStrLn "----------------------------------------"
+ L.putStrLn txt
+ L.putStrLn "----------------------------------------"
+ L.putStrLn "\ngot:"
+ L.putStrLn "----------------------------------------"
+ L.putStrLn doc
+ L.putStrLn "----------------------------------------"
+
+ QC.assert $ txt == doc
+
+
+------------------------------------------------------------------------------
testRot13 :: Bool -> Int -> String -> Test
testRot13 ssl port name = testProperty (name ++ "/blackbox/rot13") $
monadicIO $ forAllM arbitrary prop
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
