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 1efd1adf160e64e34202288cc1dd153c75ea8949 (commit)
from ce2dda1290fddfb62a5fd8be498e5b40219786f7 (commit)
Summary of changes:
src/Snap/Internal/Http/Server/GnuTLS.hs | 13 ++++---------
test/snap-server-testsuite.cabal | 4 ++--
test/suite/Test/Blackbox.hs | 31 ++++++++++++++++++++++++-------
3 files changed, 30 insertions(+), 18 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 1efd1adf160e64e34202288cc1dd153c75ea8949
Author: Gregory Collins <[email protected]>
Date: Sat Feb 26 15:30:06 2011 +0100
Fix SSL error by constraining size return type to 'Int'
diff --git a/src/Snap/Internal/Http/Server/GnuTLS.hs
b/src/Snap/Internal/Http/Server/GnuTLS.hs
index a8ace90..66ad393 100644
--- a/src/Snap/Internal/Http/Server/GnuTLS.hs
+++ b/src/Snap/Internal/Http/Server/GnuTLS.hs
@@ -24,10 +24,10 @@ import Data.ByteString (ByteString)
import Data.Dynamic
import Foreign.C
+import Snap.Internal.Debug
import Snap.Internal.Http.Server.Backend
#ifdef GNUTLS
-import Control.Monad (liftM)
import qualified Data.ByteString as B
import Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Internal as BI
@@ -197,24 +197,19 @@ send tickleTimeout onBlock (NetworkSession { _session =
session}) bs =
------------------------------------------------------------------------------
--- | I originally wrote recv to use mallocBytes and unsafePackCStringFinalizer
--- to achieve zero-copy. The downside to that method is we might waste memory
--- if a malicious adversary only sends us a few bytes, since the entire buffer
--- won't be freed until the ByteString is collected. Thus I use
--- packCStringLen which makes a copy. Perhaps in the future the recv function
--- could be changed to use unsafePackCStringFinalizer if the buffer is at
--- least 3/4 full and packCStringLen otherwise or something like that
recv :: IO b -> NetworkSession -> IO (Maybe ByteString)
recv onBlock (NetworkSession _ session recvLen) = do
fp <- BI.mallocByteString recvLen
sz <- withForeignPtr fp loop
- if sz <= 0
+ if (sz :: Int) <= 0
then return Nothing
else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz
where
loop recvBuf = do
+ debug $ "TLS: calling record_recv with recvLen=" ++ show recvLen
size <- gnutls_record_recv (castPtr session) recvBuf $ toEnum recvLen
+ debug $ "TLS: record_recv returned with size=" ++ show size
let size' = fromIntegral size
case size' of
x | x >= 0 -> return x
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 6be7965..1d24ddc 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -38,7 +38,7 @@ Executable testsuite
enumerator >= 0.4.7 && <0.5,
filepath,
haskell98,
- http-enumerator >= 0.2.1.5 && <0.3,
+ http-enumerator >= 0.3.1 && <0.4,
HUnit >= 1.2 && < 2,
monads-fd >= 0.1.0.4 && <0.2,
murmur-hash >= 0.1 && < 0.2,
@@ -221,5 +221,5 @@ Executable benchmark
build-depends:
base >= 4 && < 5,
network == 2.3.*,
- http-enumerator >= 0.2.1.3 && <0.3,
+ http-enumerator >= 0.3.1 && <0.4,
criterion >= 0.5 && <0.6
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 1d0e934..c19b5f1 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -9,7 +9,7 @@ module Test.Blackbox
--------------------------------------------------------------------------------
import Control.Concurrent
-import Control.Exception (SomeException, catch)
+import Control.Exception (SomeException, catch, throwIO)
import Control.Monad
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as S
@@ -17,18 +17,22 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Int
import Data.List
+import Data.Monoid
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.Options
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
import Test.QuickCheck
+import qualified Test.QuickCheck.Property as QC
import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic hiding (run, assert)
------------------------------------------------------------------------------
+import Snap.Internal.Debug
import Snap.Http.Server
import Snap.Test.Common
import Test.Common.Rot13
@@ -93,10 +97,15 @@ startTestServer port sslport backend = do
------------------------------------------------------------------------------
doPong :: Bool -> Int -> IO ByteString
doPong ssl port = do
- let uri = (if ssl then "https" else "http")
- ++ "://127.0.0.1:" ++ show port ++ "/pong"
-
- rsp <- HTTP.simpleHttp uri
+ debug "getting URI"
+ let !uri = (if ssl then "https" else "http")
+ ++ "://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)
+ debug $ "response was " ++ show rsp
return $ S.concat $ L.toChunks rsp
@@ -149,9 +158,17 @@ 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
+testFileUpload ssl port name =
+ plusTestOptions testOptions $
+ testProperty (name ++ "/blackbox/upload") $
+ QC.mapSize (if ssl then min 100 else id) $
+ monadicIO $
+ forAllM arbitrary prop
where
+ testOptions = if ssl
+ then mempty { topt_maximum_generated_tests = Just 100 }
+ else mempty
+
boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl"
prefix = [ "--"
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
