packages feed

snap-server 0.4.0.2 → 0.4.1

raw patch · 7 files changed

+75/−59 lines, 7 filesdep ~enumeratordep ~snap-core

Dependency ranges changed: enumerator, snap-core

Files

snap-server.cabal view
@@ -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,
src/Snap/Internal/Http/Server.hs view
@@ -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
src/Snap/Internal/Http/Server/Backend.hs view
@@ -92,6 +92,5 @@ data NetworkSession = NetworkSession   { _socket     :: CInt   , _session    :: Ptr Word-  , _recvBuffer :: Ptr CChar-  , _recvLen    :: CSize+  , _recvLen    :: Int   }
src/Snap/Internal/Http/Server/GnuTLS.hs view
@@ -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'++)
src/Snap/Internal/Http/Server/HttpPort.hs view
@@ -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
test/snap-server-testsuite.cabal view
@@ -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
test/suite/Test/Blackbox.hs view
@@ -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 = [ "--"