diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.4.0.2 +version: 0.4.1 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: This is the first developer prerelease of the Snap framework. Snap is a @@ -111,14 +111,14 @@ bytestring-nums, containers, directory-tree, - enumerator == 0.4.*, + enumerator >= 0.4.7 && <0.5, filepath, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl == 2.0.*, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale, - snap-core >= 0.4.0.2 && <0.5, + snap-core >= 0.4.1 && <0.5, template-haskell, time, transformers, diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -784,7 +784,7 @@ where f h = if null cookies then h - else Map.insert "Set-Cookie" cookies h + else Map.insertWith (flip (++)) "Set-Cookie" cookies h cookies = fmap cookieToBS . Map.elems $ rspCookies r diff --git a/src/Snap/Internal/Http/Server/Backend.hs b/src/Snap/Internal/Http/Server/Backend.hs --- a/src/Snap/Internal/Http/Server/Backend.hs +++ b/src/Snap/Internal/Http/Server/Backend.hs @@ -92,6 +92,5 @@ data NetworkSession = NetworkSession { _socket :: CInt , _session :: Ptr Word - , _recvBuffer :: Ptr CChar - , _recvLen :: CSize + , _recvLen :: Int } diff --git a/src/Snap/Internal/Http/Server/GnuTLS.hs b/src/Snap/Internal/Http/Server/GnuTLS.hs --- a/src/Snap/Internal/Http/Server/GnuTLS.hs +++ b/src/Snap/Internal/Http/Server/GnuTLS.hs @@ -24,13 +24,14 @@ 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.Unsafe (unsafeUseAsCStringLen) import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BI import Foreign import qualified Network.Socket as Socket #endif @@ -148,8 +149,7 @@ gnutls_certificate_send_x509_rdn_sequence session 1 gnutls_session_enable_compatibility_mode session - buffer <- mallocBytes $ fromIntegral recvSize - let s = NetworkSession socket (castPtr session) buffer $ + let s = NetworkSession socket (castPtr session) $ fromIntegral recvSize gnutls_transport_set_ptr session $ intPtrToPtr $ fromIntegral $ socket @@ -162,10 +162,9 @@ ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () -endSession (NetworkSession _ session buffer _) = do +endSession (NetworkSession _ session _) = do throwErrorIf "TLS bye" $ gnutls_bye (castPtr session) 1 `finally` do gnutls_deinit $ castPtr session - free buffer ------------------------------------------------------------------------------ @@ -182,7 +181,7 @@ ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () send tickleTimeout onBlock (NetworkSession { _session = session}) bs = - unsafeUseAsCStringLen bs $ uncurry loop + BI.unsafeUseAsCStringLen bs $ uncurry loop where loop ptr len = do sent <- gnutls_record_send (castPtr session) ptr $ fromIntegral len @@ -198,30 +197,29 @@ ------------------------------------------------------------------------------ --- | 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 recvBuf recvLen) = loop +recv onBlock (NetworkSession _ session recvLen) = do + fp <- BI.mallocByteString recvLen + sz <- withForeignPtr fp loop + if (sz :: Int) <= 0 + then return Nothing + else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz + where - loop = do - size <- gnutls_record_recv (castPtr session) recvBuf recvLen + 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 Nothing - | x > 0 -> liftM Just $ B.packCStringLen (recvBuf, x) - | isIntrCode x -> loop - | isAgainCode x -> onBlock >> loop + x | x >= 0 -> return x + | isIntrCode x -> loop recvBuf + | isAgainCode x -> onBlock >> loop recvBuf | otherwise -> (throwError "TLS recv" $ fromIntegral size') - >> return Nothing ------------------------------------------------------------------------------ -throwError :: String -> ReturnCode -> IO () +throwError :: String -> ReturnCode -> IO a throwError prefix rc = gnutls_strerror rc >>= peekCString >>= throwIO . GnuTLSException . (prefix'++) diff --git a/src/Snap/Internal/Http/Server/HttpPort.hs b/src/Snap/Internal/Http/Server/HttpPort.hs --- a/src/Snap/Internal/Http/Server/HttpPort.hs +++ b/src/Snap/Internal/Http/Server/HttpPort.hs @@ -22,8 +22,8 @@ #ifdef PORTABLE import qualified Network.Socket.ByteString as SB #else -import Control.Monad (liftM) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BI #endif import Snap.Internal.Debug @@ -56,14 +56,13 @@ ------------------------------------------------------------------------------ createSession :: Int -> CInt -> IO () -> IO NetworkSession -createSession buffSize s _ = do - buffer <- mallocBytes $ fromIntegral buffSize - return $ NetworkSession s nullPtr buffer $ fromIntegral buffSize +createSession buffSize s _ = + return $ NetworkSession s nullPtr $ fromIntegral buffSize ------------------------------------------------------------------------------ endSession :: NetworkSession -> IO () -endSession (NetworkSession {_recvBuffer = buff}) = free buff +endSession _ = return () #ifdef PORTABLE @@ -84,24 +83,27 @@ ------------------------------------------------------------------------------ recv :: IO () -> NetworkSession -> IO (Maybe ByteString) -recv onBlock (NetworkSession s _ buff buffSize) = do - sz <- throwErrnoIfMinus1RetryMayBlock - "recv" - (c_read s buff buffSize) - onBlock +recv onBlock (NetworkSession s _ buffSize) = do + fp <- BI.mallocByteString $ fromEnum buffSize + sz <- withForeignPtr fp $ \p -> + throwErrnoIfMinus1RetryMayBlock + "recv" + (c_read s p $ toEnum buffSize) + onBlock + if sz == 0 - then return Nothing - else liftM Just $ B.packCStringLen (buff, fromIntegral sz) + then return Nothing + else return $ Just $ BI.fromForeignPtr fp 0 $ fromEnum sz ------------------------------------------------------------------------------ send :: IO () -> IO () -> NetworkSession -> ByteString -> IO () -send tickleTimeout onBlock (NetworkSession s _ _ _) bs = - unsafeUseAsCStringLen bs $ uncurry loop +send tickleTimeout onBlock (NetworkSession s _ _) bs = + BI.unsafeUseAsCStringLen bs $ uncurry loop where loop ptr len = do sent <- throwErrnoIfMinus1RetryMayBlock "send" - (c_write s ptr $ fromIntegral len) + (c_write s ptr $ toEnum len) onBlock let sent' = fromIntegral sent diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -35,10 +35,10 @@ containers, directory, directory-tree, - enumerator == 0.4.*, + 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, @@ -46,7 +46,7 @@ old-locale, parallel > 2, process, - snap-core >= 0.4 && <0.5, + snap-core >= 0.4.1 && <0.5, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, @@ -96,7 +96,7 @@ cereal >= 0.3 && < 0.4, containers, directory-tree, - enumerator == 0.4.*, + enumerator >= 0.4.7 && <0.5, filepath, haskell98, HUnit >= 1.2 && < 2, @@ -106,7 +106,7 @@ MonadCatchIO-transformers >= 0.2.1 && < 0.3, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, - snap-core >= 0.4 && <0.5, + snap-core >= 0.4.1 && <0.5, template-haskell, time, transformers, @@ -173,7 +173,7 @@ bytestring-nums >= 0.3.1 && < 0.4, containers, directory-tree, - enumerator == 0.4.*, + enumerator >= 0.4.7 && <0.5, filepath, haskell98, HUnit >= 1.2 && < 2, @@ -183,7 +183,7 @@ network == 2.3.*, old-locale, parallel > 2, - snap-core >= 0.4 && <0.5, + snap-core >= 0.4.1 && <0.5, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, @@ -221,5 +221,5 @@ 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 --- a/test/suite/Test/Blackbox.hs +++ b/test/suite/Test/Blackbox.hs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- 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 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 @@ ------------------------------------------------------------------------------ doPong :: Bool -> Int -> IO ByteString doPong ssl port = do - let uri = (if ssl then "https" else "http") - ++ "://127.0.0.1:" ++ show port ++ "/pong" + 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 + 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 @@ ------------------------------------------------------------------------------ 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 = [ "--"