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 0a4102ab961911136a683471d6dea9ac110734a3 (commit)
from 2722cbf1584150dbc99ba692ccfa933be4a1d909 (commit)
Summary of changes:
snap-server.cabal | 7 +-
src/Data/Concurrent/HashMap.hs | 237 ------------------------
src/Data/Concurrent/HashMap/Internal.hs | 16 --
src/Snap/Internal/Http/Server/SimpleBackend.hs | 72 ++------
src/Snap/Internal/Http/Server/TimeoutTable.hs | 139 --------------
test/snap-server-testsuite.cabal | 3 -
test/suite/Data/Concurrent/HashMap/Tests.hs | 121 ------------
test/suite/TestSuite.hs | 8 +-
8 files changed, 23 insertions(+), 580 deletions(-)
delete mode 100644 src/Data/Concurrent/HashMap.hs
delete mode 100644 src/Data/Concurrent/HashMap/Internal.hs
delete mode 100644 src/Snap/Internal/Http/Server/TimeoutTable.hs
delete mode 100644 test/suite/Data/Concurrent/HashMap/Tests.hs
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 0a4102ab961911136a683471d6dea9ac110734a3
Author: Gregory Collins <[email protected]>
Date: Sun Mar 20 18:54:56 2011 +0100
Replace TimeoutTable with TimeoutManager, which should be significantly
faster under load.
diff --git a/snap-server.cabal b/snap-server.cabal
index f04e383..a175ccd 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -53,9 +53,9 @@ extra-source-files:
test/pongserver/Main.hs,
test/runTestsAndCoverage.sh,
test/snap-server-testsuite.cabal,
- test/suite/Data/Concurrent/HashMap/Tests.hs,
test/suite/Snap/Internal/Http/Parser/Tests.hs,
test/suite/Snap/Internal/Http/Server/Tests.hs,
+ test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs,
test/suite/Test/Blackbox.hs,
test/suite/TestSuite.hs,
test/testserver/Main.hs,
@@ -85,8 +85,6 @@ Library
System.FastLogger
other-modules:
- Data.Concurrent.HashMap,
- Data.Concurrent.HashMap.Internal,
Paths_snap_server,
Snap.Internal.Http.Parser,
Snap.Internal.Http.Server,
@@ -95,7 +93,7 @@ Library
Snap.Internal.Http.Server.ListenHelpers,
Snap.Internal.Http.Server.GnuTLS,
Snap.Internal.Http.Server.HttpPort,
- Snap.Internal.Http.Server.TimeoutTable,
+ Snap.Internal.Http.Server.TimeoutManager,
Snap.Internal.Http.Server.SimpleBackend,
Snap.Internal.Http.Server.LibevBackend
@@ -115,7 +113,6 @@ Library
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.2 && <0.5,
diff --git a/src/Data/Concurrent/HashMap.hs b/src/Data/Concurrent/HashMap.hs
deleted file mode 100644
index 1c649cc..0000000
--- a/src/Data/Concurrent/HashMap.hs
+++ /dev/null
@@ -1,237 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Data.Concurrent.HashMap
- ( HashMap
- , new
- , new'
- , null
- , insert
- , delete
- , lookup
- , update
- , fromList
- , toList
- , hashString
- , hashBS
- , hashInt
- , nextHighestPowerOf2 ) where
-
-------------------------------------------------------------------------------
-
-import Control.Concurrent.MVar
-import Control.Monad
-import Data.Bits
-import qualified Data.ByteString as B
-import qualified Data.Digest.Murmur32 as Murmur
-import qualified Data.Digest.Murmur64 as Murmur
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IM
-import Data.Maybe
-import qualified Data.Vector as V
-import Data.Vector (Vector)
-import GHC.Conc (numCapabilities)
-import Prelude hiding (lookup, null)
-import qualified Prelude
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#else
-import Data.Word
-#endif
-
-import Data.Concurrent.HashMap.Internal
-
-
-hashString :: String -> Word
-hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
- [| Murmur.asWord64 . Murmur.hash64 |])
-{-# INLINE hashString #-}
-
-
-hashInt :: Int -> Word
-hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]
- [| Murmur.asWord64 . Murmur.hash64 |])
-{-# INLINE hashInt #-}
-
-
-hashBS :: B.ByteString -> Word
-hashBS =
- $(let h32 = [| \s -> s `seq`
- Murmur.asWord32 $
- B.foldl' (\h c -> h `seq` c `seq`
- Murmur.hash32AddInt (fromEnum c) h)
- (Murmur.hash32 ([] :: [Int]))
- s
- |]
- h64 = [| \s -> s `seq`
- Murmur.asWord64 $
- B.foldl' (\h c -> h `seq` c `seq`
- Murmur.hash64AddInt (fromEnum c) h)
- (Murmur.hash64 ([] :: [Int]))
- s
- |]
- in whichHash h32 h64)
-{-# INLINE hashBS #-}
-
-
-data HashMap k v = HM {
- _hash :: !(k -> Word)
- , _hashToBucket :: !(Word -> Word)
- , _maps :: !(Vector (MVar (Submap k v)))
-}
-
-
-
-null :: HashMap k v -> IO Bool
-null ht = liftM V.and $ V.mapM f $ _maps ht
-
- where
- f mv = withMVar mv (return . IM.null)
-
-
-new' :: Eq k =>
- Int -- ^ number of locks to use
- -> (k -> Word) -- ^ hash function
- -> IO (HashMap k v)
-new' numLocks hashFunc = do
- vector <- V.replicateM (fromEnum n) (newMVar IM.empty)
- return $! HM hf bh vector
-
- where
- hf !x = hashFunc x
- bh !x = x .&. (n-1)
- !n = nextHighestPowerOf2 $ toEnum numLocks
-
-
-new :: Eq k =>
- (k -> Word) -- ^ hash function
- -> IO (HashMap k v)
-new = new' defaultNumberOfLocks
-
-
-insert :: k -> v -> HashMap k v -> IO ()
-insert key value ht =
- modifyMVar_ submap $ \m ->
- return $! insSubmap hashcode key value m
-
- where
- hashcode = _hash ht key
- bucket = _hashToBucket ht hashcode
- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
-
-
-delete :: (Eq k) => k -> HashMap k v -> IO ()
-delete key ht =
- modifyMVar_ submap $ \m ->
- return $! delSubmap hashcode key m
- where
- hashcode = _hash ht key
- bucket = _hashToBucket ht hashcode
- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
-
-
-lookup :: (Eq k) => k -> HashMap k v -> IO (Maybe v)
-lookup key ht =
- withMVar submap $ \m ->
- return $! lookupSubmap hashcode key m
- where
- hashcode = _hash ht key
- bucket = _hashToBucket ht hashcode
- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
-
-
-update :: (Eq k) => k -> v -> HashMap k v -> IO Bool
-update key value ht =
- modifyMVar submap $ \m ->
- return $! updateSubmap hashcode key value m
- where
- hashcode = _hash ht key
- bucket = _hashToBucket ht hashcode
- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)
-
-
-toList :: HashMap k v -> IO [(k,v)]
-toList ht = liftM (concat . V.toList) $ V.mapM f $ _maps ht
- where
- f m = withMVar m $ \sm -> return $ concat $ IM.elems sm
-
-
-fromList :: (Eq k) => (k -> Word) -> [(k,v)] -> IO (HashMap k v)
-fromList hf xs = do
- ht <- new hf
- mapM_ (\(k,v) -> insert k v ht) xs
- return $! ht
-
-
-------------------------------------------------------------------------------
--- helper functions
-------------------------------------------------------------------------------
-
--- nicked this technique from Data.IntMap
-
-shiftRL :: Word -> Int -> Word
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-#else
-shiftRL x i = shiftR x i
-#endif
-
-
-type Submap k v = IntMap [(k,v)]
-
-
-nextHighestPowerOf2 :: Word -> Word
-nextHighestPowerOf2 w = highestBitMask (w-1) + 1
-
-
-highestBitMask :: Word -> Word
-highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of
- x1 -> case (x1 .|. shiftRL x1 2) of
- x2 -> case (x2 .|. shiftRL x2 4) of
- x3 -> case (x3 .|. shiftRL x3 8) of
- x4 -> case (x4 .|. shiftRL x4 16) of
- x5 -> x5 .|. shiftRL x5 32
-
-
-
-insSubmap :: Word -> k -> v -> Submap k v -> Submap k v
-insSubmap hashcode key value m = let !x = f m in x
- where
- f = IM.insertWith (++) (fromIntegral hashcode) [(key,value)]
-
-
-delSubmap :: (Eq k) => Word -> k -> Submap k v -> Submap k v
-delSubmap hashcode key m =
- let !z = IM.update f (fromIntegral hashcode) m in z
-
- where
- f l = let l' = del l in if Prelude.null l' then Nothing else Just l'
-
- del = filter ((/= key) . fst)
-
-
-lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v
-lookupSubmap hashcode key m = maybe Nothing (Prelude.lookup key) mbBucket
- where
- mbBucket = IM.lookup (fromIntegral hashcode) m
-
-
-updateSubmap :: (Eq k) => Word -> k -> v -> Submap k v -> (Submap k v, Bool)
-updateSubmap hashcode key value m = (m'', b)
- where
- oldV = lookupSubmap hashcode key m
- m' = maybe m (const $ delSubmap hashcode key m) oldV
- m'' = insSubmap hashcode key value m'
- b = isJust oldV
-
-
-defaultNumberOfLocks :: Int
-defaultNumberOfLocks = 8 * numCapabilities
diff --git a/src/Data/Concurrent/HashMap/Internal.hs
b/src/Data/Concurrent/HashMap/Internal.hs
deleted file mode 100644
index 3ff3f6b..0000000
--- a/src/Data/Concurrent/HashMap/Internal.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Data.Concurrent.HashMap.Internal where
-
-import Data.Bits
-import Data.Word
-import Language.Haskell.TH
-
-
-whichHash :: ExpQ -> ExpQ -> Q Exp
-whichHash as32 as64 = if bitSize (undefined :: Word) == 32
- then [| \x -> fromIntegral $ $as32 x |]
- else [| \x -> fromIntegral $ $as64 x |]
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 721830f..9348800 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -23,18 +23,16 @@ import qualified Data.ByteString as S
import Data.ByteString.Internal (c2w)
import Data.Maybe
import Data.Typeable
-import Data.Word
import Foreign hiding (new)
import Foreign.C
import GHC.Conc (labelThread, forkOnIO)
import Network.Socket
import Prelude hiding (catch)
------------------------------------------------------------------------------
-import Data.Concurrent.HashMap (hashString)
import Snap.Internal.Debug
import Snap.Internal.Http.Server.Date
-import qualified Snap.Internal.Http.Server.TimeoutTable as TT
-import Snap.Internal.Http.Server.TimeoutTable (TimeoutTable)
+import qualified Snap.Internal.Http.Server.TimeoutManager as TM
+import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager)
import Snap.Internal.Http.Server.Backend
import qualified Snap.Internal.Http.Server.ListenHelpers as Listen
import Snap.Iteratee hiding (map)
@@ -49,14 +47,12 @@ import System.Posix.Types (Fd(..))
------------------------------------------------------------------------------
-- | For each cpu, we store:
-- * A list of accept threads, one per port.
--- * One timeout table and one timeout thread.
--- These timeout the session threads.
+-- * A TimeoutManager
-- * An mvar to signal when the timeout thread is shutdown
data EventLoopCpu = EventLoopCpu
{ _boundCpu :: Int
, _acceptThreads :: [ThreadId]
- , _timeoutTable :: TimeoutTable
- , _timeoutThread :: ThreadId
+ , _timeoutManager :: TimeoutManager
, _exitMVar :: !(MVar ())
}
@@ -84,31 +80,30 @@ newLoop :: Int
-> Int
-> IO EventLoopCpu
newLoop defaultTimeout sockets handler elog cpu = do
- tt <- TT.new
+ tmgr <- TM.initialize defaultTimeout getCurrentDateTime
exit <- newEmptyMVar
accThreads <- forM sockets $ \p -> forkOnIO cpu $
- acceptThread defaultTimeout handler tt elog cpu p
- tid <- forkOnIO cpu $ timeoutThread tt exit
+ acceptThread defaultTimeout handler tmgr elog cpu p
- return $ EventLoopCpu cpu accThreads tt tid exit
+ return $ EventLoopCpu cpu accThreads tmgr exit
------------------------------------------------------------------------------
stopLoop :: EventLoopCpu -> IO ()
stopLoop loop = block $ do
+ TM.stop $ _timeoutManager loop
Prelude.mapM_ killThread $ _acceptThreads loop
- killThread $ _timeoutThread loop
------------------------------------------------------------------------------
acceptThread :: Int
-> SessionHandler
- -> TimeoutTable
+ -> TimeoutManager
-> (S.ByteString -> IO ())
-> Int
-> ListenSocket
-> IO ()
-acceptThread defaultTimeout handler tt elog cpu sock = loop
+acceptThread defaultTimeout handler tmgr elog cpu sock = loop
where
loop = do
debug $ "acceptThread: calling accept() on socket " ++ show sock
@@ -117,7 +112,7 @@ acceptThread defaultTimeout handler tt elog cpu sock = loop
_ <- forkOnIO cpu (go s addr `catches` cleanup)
loop
- go = runSession defaultTimeout handler tt sock
+ go = runSession defaultTimeout handler tmgr sock
cleanup =
[
@@ -129,30 +124,6 @@ acceptThread defaultTimeout handler tt elog cpu sock = loop
------------------------------------------------------------------------------
-timeoutThread :: TimeoutTable -> MVar () -> IO ()
-timeoutThread table exitMVar = do
- go `catch` (\(_::SomeException) -> killAll)
- putMVar exitMVar ()
-
- where
- go = do
- debug "timeoutThread: waiting for activity on thread table"
- TT.waitForActivity table
- debug "timeoutThread: woke up, killing old connections"
- killTooOld
- go
-
-
- killTooOld = do
- now <- getCurrentDateTime
- TT.killOlderThan now table
-
- killAll = do
- debug "Backend.timeoutThread: shutdown, killing all connections"
- TT.killAll table
-
-
-------------------------------------------------------------------------------
data AddressNotSupportedException = AddressNotSupportedException String
deriving (Typeable)
@@ -165,11 +136,11 @@ instance Exception AddressNotSupportedException
------------------------------------------------------------------------------
runSession :: Int
-> SessionHandler
- -> TimeoutTable
+ -> TimeoutManager
-> ListenSocket
-> Socket
-> SockAddr -> IO ()
-runSession defaultTimeout handler tt lsock sock addr = do
+runSession defaultTimeout handler tmgr lsock sock addr = do
let fd = fdSocket sock
curId <- myThreadId
@@ -193,18 +164,17 @@ runSession defaultTimeout handler tt lsock sock addr = do
x -> throwIO $ AddressNotSupportedException $ show x
let sinfo = SessionInfo lhost lport rhost rport $ Listen.isSecure lsock
- let curHash = hashString $ show curId
- let timeout = tickleTimeout tt curId curHash
- timeout defaultTimeout
+ timeoutHandle <- TM.register (killThread curId) tmgr
+ let timeout = TM.tickle timeoutHandle
bracket (Listen.createSession lsock 8192 fd
(threadWaitRead $ fromIntegral fd))
(\session -> block $ do
debug "thread killed, closing socket"
- -- remove thread from timeout table
- TT.delete curHash curId tt
+ -- cancel thread timeout
+ TM.cancel timeoutHandle
eatException $ Listen.endSession lsock session
eatException $ shutdown sock ShutdownBoth
@@ -264,14 +234,6 @@ sendFile _ _ _ writeEnd fp start sz = do
------------------------------------------------------------------------------
-tickleTimeout :: TimeoutTable -> ThreadId -> Word -> Int -> IO ()
-tickleTimeout table tid thash tm = do
- debug "Backend.tickleTimeout"
- now <- getCurrentDateTime
- TT.insert thash tid (now + toEnum tm) table
-
-
-------------------------------------------------------------------------------
enumerate :: (MonadIO m)
=> ListenSocket
-> NetworkSession
diff --git a/src/Snap/Internal/Http/Server/TimeoutTable.hs
b/src/Snap/Internal/Http/Server/TimeoutTable.hs
deleted file mode 100644
index 699fefd..0000000
--- a/src/Snap/Internal/Http/Server/TimeoutTable.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Snap.Internal.Http.Server.TimeoutTable
- ( TimeoutTable
- , new
- , null
- , insert
- , delete
- , killAll
- , killOlderThan
- , waitForActivity
- )
-where
-
-
-------------------------------------------------------------------------------
-import Control.Concurrent
-import Control.Monad
-import Data.Bits
-import qualified Data.PSQueue as PSQ
-import Data.PSQueue (PSQ)
-import qualified Data.Vector as V
-import Data.Vector (Vector)
-import Data.Word
-import Foreign.C.Types (CTime)
-import GHC.Conc (numCapabilities)
-import Prelude hiding (null)
-------------------------------------------------------------------------------
-import Data.Concurrent.HashMap (nextHighestPowerOf2)
-
-
-------------------------------------------------------------------------------
-type TT = PSQ ThreadId CTime
-
-
-------------------------------------------------------------------------------
-data TimeoutTable = TimeoutTable {
- _maps :: !(Vector (MVar TT))
- , _activity :: !(MVar ())
-}
-
-
-------------------------------------------------------------------------------
-defaultNumberOfLocks :: Word
-defaultNumberOfLocks = nextHighestPowerOf2 $ toEnum $ 8 * numCapabilities
-
-
-------------------------------------------------------------------------------
-hashToBucket :: Word -> Word
-hashToBucket x = x .&. (defaultNumberOfLocks-1)
-
-
-------------------------------------------------------------------------------
-new :: IO TimeoutTable
-new = do
- vector <- V.replicateM (fromEnum defaultNumberOfLocks) (newMVar PSQ.empty)
- act <- newEmptyMVar
- return $ TimeoutTable vector act
-
-
-------------------------------------------------------------------------------
-null :: TimeoutTable -> IO Bool
-null (TimeoutTable maps _) = do
- nulls <- V.mapM (\mv -> withMVar mv $ return . PSQ.null) maps
- return $ V.and nulls
-
-
-------------------------------------------------------------------------------
-insert :: Word -> ThreadId -> CTime -> TimeoutTable -> IO ()
-insert thash tid time (TimeoutTable maps act) = do
- modifyMVar_ psqMv $ \psq -> do
- let !psq' = PSQ.insert tid time psq
- return $! psq'
-
- _ <- tryPutMVar act ()
- return ()
-
- where
- bucket = hashToBucket thash
- psqMv = V.unsafeIndex maps $ fromEnum bucket
-
-
-------------------------------------------------------------------------------
-delete :: Word -> ThreadId -> TimeoutTable -> IO ()
-delete thash tid (TimeoutTable maps act) = do
- modifyMVar_ psqMv $ \psq -> do
- let !psq' = PSQ.delete tid psq
- return $! psq'
-
- _ <- tryPutMVar act ()
- return ()
-
- where
- bucket = hashToBucket thash
- psqMv = V.unsafeIndex maps $ fromEnum bucket
-
-
-------------------------------------------------------------------------------
-killAll :: TimeoutTable -> IO ()
-killAll (TimeoutTable maps _) = do
- V.mapM_ k maps
-
- where
- k psqMV = modifyMVar_ psqMV $ \psq -> do
- mapM_ killThread $ PSQ.keys psq
- return PSQ.empty
-
-
-------------------------------------------------------------------------------
-killOlderThan :: CTime -> TimeoutTable -> IO ()
-killOlderThan time (TimeoutTable maps _) = do
- V.mapM_ processPSQ maps
-
- where
- processPSQ psqMV = modifyMVar_ psqMV $ \psq -> do
- let (psq', threads) = findOlder psq []
- mapM_ killThread threads
- return psq'
-
- findOlder psq l =
- let mmin = PSQ.findMin psq
- in maybe (psq,l)
- (\m -> if PSQ.prio m <= time
- then findOlder (PSQ.deleteMin psq) ((PSQ.key m):l)
- else (psq,l))
- mmin
-
-
-------------------------------------------------------------------------------
-waitForActivity :: TimeoutTable -> IO ()
-waitForActivity t@(TimeoutTable _ act) = do
- takeMVar act
- b <- null t
-
- -- if the table is not empty, put the activity mvar back
- unless b $ (tryPutMVar act () >> return ())
-
- threadDelay 2500000
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 07a4bb9..2c3cd9f 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -41,7 +41,6 @@ Executable testsuite
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,
network == 2.3.*,
old-locale,
parallel > 2,
@@ -104,7 +103,6 @@ Executable pongserver
old-locale,
parallel > 2,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
- murmur-hash >= 0.1 && < 0.2,
network == 2.3.*,
snap-core >= 0.4.1 && <0.5,
template-haskell,
@@ -179,7 +177,6 @@ Executable testserver
HUnit >= 1.2 && < 2,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
monads-fd >= 0.1.0.4 && <0.2,
- murmur-hash >= 0.1 && < 0.2,
network == 2.3.*,
old-locale,
parallel > 2,
diff --git a/test/suite/Data/Concurrent/HashMap/Tests.hs
b/test/suite/Data/Concurrent/HashMap/Tests.hs
deleted file mode 100644
index a0fefaf..0000000
--- a/test/suite/Data/Concurrent/HashMap/Tests.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PackageImports #-}
-
-module Data.Concurrent.HashMap.Tests
- ( tests ) where
-
-import Data.ByteString.Char8 (ByteString)
-import Data.List
-import Data.Word
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
-
-import qualified Data.Concurrent.HashMap as H
-import Snap.Test.Common ()
-
-tests :: [Test]
-tests = [ testFromTo
- , testLookup
- , testDeletes
- , testUpdate
- ]
-
-
--- make sure we generate two strings which hash to the same bucket.
-bogoHash :: ByteString -> Word
-bogoHash "qqq" = 12345
-bogoHash "zzz" = 12345
-bogoHash x = H.hashBS x
-
-
-testFromTo :: Test
-testFromTo = testProperty "HashMap/fromList/toList" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(Int,Int)] -> PropertyM IO ()
- prop l = do
- ht <- run $ H.fromList H.hashInt l
- l' <- run $ H.toList ht
-
- let s1 = sort l
- let s2 = sort l'
-
- assert $ s1 == s2
-
-
-testDeletes :: Test
-testDeletes = testProperty "HashMap/deletes" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let l = [("qqq","QQQ"),("zzz","ZZZ")] ++ l'
- let h = head l'
-
- ht <- run $ H.fromList bogoHash l
- v1 <- run $ H.lookup "qqq" ht
- v2 <- run $ H.lookup "zzz" ht
-
- run $ H.delete "qqq" ht
- v3 <- run $ H.lookup "qqq" ht
- v4 <- run $ H.lookup "zzz" ht
-
- run $ H.delete (fst h) ht
- run $ H.delete (fst h) ht
-
- v5 <- run $ H.lookup (fst h) ht
-
- assert $ v1 == Just "QQQ"
- assert $ v2 == Just "ZZZ"
- assert $ v3 == Nothing
- assert $ v4 == Just "ZZZ"
- assert $ v5 == Nothing
-
-
-testLookup :: Test
-testLookup = testProperty "HashMap/lookup" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let h = head l'
- let l = filter ((/= (fst h)) . fst) $ tail l'
-
- ht <- run $ H.fromList H.hashBS (h:l)
-
- v1 <- run $ H.lookup (fst h) ht
- run $ H.delete (fst h) ht
- v2 <- run $ H.lookup (fst h) ht
-
- assert $ v1 == (Just $ snd h)
- assert $ v2 == Nothing
-
-
-testUpdate :: Test
-testUpdate = testProperty "HashMap/update" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let h = head l'
- let l = filter ((/= (fst h)) . fst) $ tail l'
-
- ht <- run $ H.fromList H.hashBS (h:l)
- e1 <- run $ H.update (fst h) "qqq" ht
- v1 <- run $ H.lookup (fst h) ht
- run $ H.delete (fst h) ht
- v2 <- run $ H.lookup (fst h) ht
- e2 <- run $ H.update (fst h) "zzz" ht
- v3 <- run $ H.lookup (fst h) ht
-
- assert e1
- assert $ v1 == Just "qqq"
- assert $ v2 == Nothing
- assert $ not e2
- assert $ v3 == Just "zzz"
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
index a56bece..c2a4a08 100644
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -11,9 +11,9 @@ import Test.Framework (defaultMain, testGroup)
import Snap.Http.Server.Config
-import qualified Data.Concurrent.HashMap.Tests
import qualified Snap.Internal.Http.Parser.Tests
import qualified Snap.Internal.Http.Server.Tests
+import qualified Snap.Internal.Http.Server.TimeoutManager.Tests
import qualified Test.Blackbox
ports :: [Int]
@@ -45,12 +45,12 @@ main = HTTP.withHttpEnumerator $ do
mapM_ takeMVar $ map snd tinfos
where tests =
- [ testGroup "Data.Concurrent.HashMap.Tests"
- Data.Concurrent.HashMap.Tests.tests
- , testGroup "Snap.Internal.Http.Parser.Tests"
+ [ testGroup "Snap.Internal.Http.Parser.Tests"
Snap.Internal.Http.Parser.Tests.tests
, testGroup "Snap.Internal.Http.Server.Tests"
Snap.Internal.Http.Server.Tests.tests
+ , testGroup "Snap.Internal.Http.Server.TimeoutManager.Tests"
+ Snap.Internal.Http.Server.TimeoutManager.Tests.tests
]
blackbox (port, sslport, b) =
[ testGroup ("Test.Blackbox " ++ backendName)
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
