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 71e522d0cebb5055a648c0e7c57a9cfeebbe1762 (commit)
from 013c2661a14b4f50cc7fdc85c73d46dc746f16e4 (commit)
Summary of changes:
test/suite/Test/Blackbox.hs | 63 ++++++++++++++++++++++++++++++++++--------
test/suite/TestSuite.hs | 1 -
2 files changed, 51 insertions(+), 13 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 71e522d0cebb5055a648c0e7c57a9cfeebbe1762
Author: Gregory Collins <[email protected]>
Date: Sat Jun 18 14:44:21 2011 -0400
Get http-enumerator to shut up about certificate checking
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index ff6e6a5..8086e53 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -15,6 +15,7 @@ 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.CaseInsensitive (CI)
import Data.Int
import Data.List
import Data.Monoid
@@ -59,6 +60,7 @@ tests port name = map (\f -> f False port name) testFunctions
------------------------------------------------------------------------------
+slowTestOptions :: Bool -> TestOptions' Maybe
slowTestOptions ssl =
if ssl
then mempty { topt_maximum_generated_tests = Just 75 }
@@ -89,7 +91,7 @@ startTestServer port sslport backend = do
let cfg' = case sslport of
Nothing -> cfg
Just p -> setSSLPort p .
- setSSLBind "*" .
+ setSSLBind "*" .
setSSLCert "cert.pem" .
setSSLKey "key.pem" $
cfg
@@ -112,9 +114,8 @@ doPong ssl port = do
++ "://127.0.0.1:" ++ show port ++ "/pong"
debug $ "URI is: '" ++ uri ++ "', calling simpleHttp"
- rsp <- HTTP.simpleHttp uri `catch` (\(e::SomeException) -> do
- debug $ "simpleHttp threw exception: " ++ show e
- throwIO e)
+ rsp <- fetch uri
+
debug $ "response was " ++ show rsp
return $ S.concat $ L.toChunks rsp
@@ -159,19 +160,13 @@ testEcho ssl port name =
let uri = (if ssl then "https" else "http")
++ "://127.0.0.1:" ++ show port ++ "/echo"
- req0 <- QC.run $ HTTP.parseUrl uri
- let req = req0 { HTTP.requestBody = HTTP.RequestBodyLBS txt
- , HTTP.method = "POST" }
-
- rsp <- QC.run $ HTTP.withManager $ HTTP.httpLbs req
- let doc = HTTP.responseBody rsp
-
+ doc <- QC.run $ post uri txt []
QC.assert $ txt == doc
------------------------------------------------------------------------------
testFileUpload :: Bool -> Int -> String -> Test
-testFileUpload ssl port name =
+testFileUpload ssl port name =
plusTestOptions (slowTestOptions ssl) $
testProperty (name ++ "/blackbox/upload") $
QC.mapSize (if ssl then min 100 else min 300) $
@@ -223,6 +218,7 @@ testFileUpload ssl port name =
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 = HTTP.RequestBodyLBS $ body kvps
, HTTP.method = "POST"
@@ -383,3 +379,46 @@ waitabit = threadDelay $ 2*seconds
------------------------------------------------------------------------------
seconds :: Int
seconds = (10::Int) ^ (6::Int)
+
+
+------------------------------------------------------------------------------
+parseURL :: String -> IO (HTTP.Request IO)
+parseURL url = do
+ req <- HTTP.parseUrl url
+ return $ req { HTTP.checkCerts = const $ return True }
+
+
+------------------------------------------------------------------------------
+fetchReq :: HTTP.Request IO -> IO (L.ByteString)
+fetchReq req = go `catch` (\(e::SomeException) -> do
+ debug $ "simpleHttp threw exception: " ++ show e
+ throwIO e)
+ where
+ go = do
+ rsp <- HTTP.withManager $ HTTP.httpLbs req
+ return $ HTTP.responseBody rsp
+
+
+------------------------------------------------------------------------------
+fetch :: String -> IO (L.ByteString)
+fetch url = do
+ req <- parseURL url `catch` (\(e::SomeException) -> do
+ debug $ "parseURL threw exception: " ++ show e
+ throwIO e)
+ fetchReq req
+
+
+------------------------------------------------------------------------------
+post :: String
+ -> L.ByteString
+ -> [(CI ByteString, ByteString)]
+ -> IO (L.ByteString)
+post url body hdrs = do
+ req <- parseURL url `catch` (\(e::SomeException) -> do
+ debug $ "parseURL threw exception: " ++ show e
+ throwIO e)
+ fetchReq $ req { HTTP.requestBody = HTTP.RequestBodyLBS body
+ , HTTP.method = "POST"
+ , HTTP.requestHeaders = hdrs }
+
+
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
index f9904d7..4606fcd 100644
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -9,7 +9,6 @@ import Control.Concurrent.MVar
import Control.Monad
import Prelude hiding (catch)
import Network (withSocketsDo)
-import qualified Network.HTTP.Enumerator as HTTP
import Test.Framework (defaultMain, testGroup)
import System.Environment
import Snap.Http.Server.Config
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
https://mailman-mail5.webfaction.com/listinfo/snap
