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 350f0d2fd10857560dc6af48353d5a3c589d4829 (commit)
from 0628a7fadbef0eadd6bbef6ae4b862bf37f57f48 (commit)
Summary of changes:
src/Snap/Internal/Http/Server/LibevBackend.hs | 8 ++-
test/common/Snap/Test/Common.hs | 27 ++++++++++-
test/snap-server-testsuite.cabal | 2 +
test/suite/Test/Blackbox.hs | 62 ++++++++++++++++---------
4 files changed, 72 insertions(+), 27 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 350f0d2fd10857560dc6af48353d5a3c589d4829
Author: Gregory Collins <[email protected]>
Date: Fri Sep 10 17:29:08 2010 -0400
Add test for slowloris attack/timeouts
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index 088051a..d173908 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -370,15 +370,17 @@ timerCallback loop tmr ioref tmv _ _ _ = do
now <- getCurrentDateTime
whenToDie <- readIORef ioref
- if whenToDie < now
+ if whenToDie <= now
then do
debug "Backend.timerCallback: killing thread"
tid <- readMVar tmv
throwTo tid TimeoutException
else do
- evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now)
- evTimerAgain loop tmr
+ debug $ "Backend.timerCallback: now=" ++ show now
+ ++ ", whenToDie=" ++ show whenToDie
+ evTimerSetRepeat tmr $ fromRational . toRational $ (whenToDie - now)
+ evTimerAgain loop tmr
freeConnection :: Connection -> IO ()
diff --git a/test/common/Snap/Test/Common.hs b/test/common/Snap/Test/Common.hs
index 14fc25e..a8bbc0e 100644
--- a/test/common/Snap/Test/Common.hs
+++ b/test/common/Snap/Test/Common.hs
@@ -1,18 +1,23 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Test.Common where
+import Control.Exception (SomeException)
import Control.Monad
+import Control.Monad.CatchIO
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
-import Data.Iteratee.WrappedByteString
-import Data.Word
+import Prelude hiding (catch)
import Test.QuickCheck
+import System.Timeout
import Snap.Internal.Iteratee.Debug ()
+import System.IO
+
instance Arbitrary S.ByteString where
arbitrary = liftM (S.pack . map c2w) arbitrary
@@ -22,3 +27,21 @@ instance Arbitrary L.ByteString where
chunks <- replicateM n arbitrary
return $ L.fromChunks chunks
+
+
+expectExceptionBeforeTimeout :: IO a -- ^ action to run
+ -> Int -- ^ number of seconds to expect
+ -- exception by
+ -> IO Bool
+expectExceptionBeforeTimeout act nsecs = do
+ x <- timeout (nsecs * (10::Int)^(6::Int)) f
+ case x of
+ Nothing -> return False
+ (Just y) -> return y
+
+ where
+ f = (act >> return False) `catch` \(e::SomeException) -> do
+ if show e == "<<timeout>>"
+ then return False
+ else return True
+
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 2af0a6c..e53088b 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -94,6 +94,7 @@ Executable pongserver
old-locale,
parallel > 2,
iteratee >= 0.3.1 && < 0.4,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
@@ -166,6 +167,7 @@ Executable testserver
haskell98,
HTTP >= 4000.0.9 && < 4001,
HUnit >= 1.2 && < 2,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
monads-fd,
murmur-hash >= 0.1 && < 0.2,
network == 2.2.1.7,
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index e85784b..9ad2a96 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -8,28 +8,16 @@ module Test.Blackbox
import Control.Concurrent
-import Control.Exception (try, SomeException)
import Control.Monad
-import "monads-fd" Control.Monad.Trans
+import Control.Monad.CatchIO
import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as LC
-import Data.ByteString (ByteString)
-import Data.ByteString.Internal (c2w, w2c)
-import Data.Char
import Data.Int
-import Data.IORef
-import Data.Iteratee.WrappedByteString
-import qualified Data.Map as Map
import Data.Maybe (fromJust)
-import Data.Monoid
-import Data.Time.Calendar
-import Data.Time.Clock
-import Data.Word
-import qualified Network.URI as URI
import qualified Network.HTTP as HTTP
+import qualified Network.URI as URI
+import Network.Socket
+import qualified Network.Socket.ByteString as N
import Prelude hiding (take)
-import qualified Prelude
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
@@ -39,18 +27,17 @@ import qualified Test.QuickCheck.Monadic as QC
import Test.QuickCheck.Monadic hiding (run, assert)
import Snap.Http.Server
-import Snap.Iteratee
-import Snap.Test.Common ()
-import Snap.Types
+import Snap.Test.Common
import Test.Common.Rot13
import Test.Common.TestHandler
tests :: Int -> [Test]
-tests port = [ testPong port
- , testEcho port
- , testRot13 port ]
+tests port = [ testPong port
+ , testEcho port
+ , testRot13 port
+ , testSlowLoris port ]
startTestServer :: IO (ThreadId,Int)
@@ -120,6 +107,37 @@ testRot13 port = testProperty "blackbox/rot13" $
QC.assert $ txt == rot13 doc
+testSlowLoris :: Int -> Test
+testSlowLoris port = testCase "blackbox/slowloris" $ do
+ addr <- liftM (addrAddress . Prelude.head) $
+ getAddrInfo (Just myHints)
+ (Just "127.0.0.1")
+ (Just $ show port)
+
+ sock <- socket AF_INET Stream defaultProtocol
+ connect sock addr
+
+ go sock `finally` sClose sock
+
+ where
+ myHints = defaultHints { addrFlags = [ AI_NUMERICHOST ] }
+
+ go sock = do
+ N.sendAll sock "POST /echo HTTP/1.1\r\n"
+ N.sendAll sock "Host: 127.0.0.1\r\n"
+ N.sendAll sock "Content-Length: 2500000\r\n"
+ N.sendAll sock "Connection: close\r\n\r\n"
+
+ b <- expectExceptionBeforeTimeout (loris sock) 60
+
+ assertBool "didn't catch slow loris attack" b
+
+ loris sock = do
+ N.sendAll sock "."
+ threadDelay 2000000
+ loris sock
+
+
------------------------------------------------------------------------------
waitabit :: IO ()
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
