snap-server 0.2.7.2 → 0.2.8
raw patch · 9 files changed
+311/−85 lines, 9 filesdep +murmur-hashdep ~hlibevdep ~snap-core
Dependencies added: murmur-hash
Dependency ranges changed: hlibev, snap-core
Files
- snap-server.cabal +7/−3
- src/Data/HashMap/Concurrent.hs +238/−0
- src/Snap/Internal/Http/Server.hs +4/−3
- src/Snap/Internal/Http/Server/LibevBackend.hs +14/−71
- test/snap-server-testsuite.cabal +4/−2
- test/suite/Data/HashMap/Concurrent/Tests.hs +31/−0
- test/suite/Snap/Internal/Http/Server/Tests.hs +8/−3
- test/suite/Snap/Test/Common.hs +0/−1
- test/suite/TestSuite.hs +5/−2
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.2.7.2+version: 0.2.8 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@@ -66,7 +66,9 @@ test/runTestsAndCoverage.sh, test/snap-server-testsuite.cabal, test/suite/Paths_snap_server.hs,+ test/suite/Data/HashMap/Concurrent/Tests.hs, test/suite/Snap/Internal/Http/Parser/Tests.hs,+ test/suite/Snap/Internal/Http/Parser/Tests.hs, test/suite/Snap/Internal/Http/Server/Tests.hs, test/suite/Snap/Test/Common.hs, test/suite/TestSuite.hs@@ -91,6 +93,7 @@ System.FastLogger other-modules:+ Data.HashMap.Concurrent, Paths_snap_server, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, @@ -111,9 +114,10 @@ filepath, iteratee >= 0.3.1 && <0.4, monads-fd,+ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale,- snap-core >= 0.2.7 && <0.3,+ snap-core >= 0.2.8 && <0.2.9, time, transformers, unix-compat,@@ -125,7 +129,7 @@ build-depends: unix if flag(libev)- build-depends: hlibev >= 0.2.3+ build-depends: hlibev >= 0.2.5 && < 0.3 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else
+ src/Data/HashMap/Concurrent.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}++module Data.HashMap.Concurrent+ ( HashMap+ , new+ , new'+ , null+ , insert+ , delete+ , lookup+ , update+ , fromList+ , toList+ , hashString+ , hashBS+ , hashInt ) 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# )+import Data.Word (Word32, Word64)+#else+import Data.Word+#endif++whichHash :: (a -> Word32) -> (a -> Word64) -> a -> Word+whichHash as32 as64 x = if bitSize (undefined :: Word) == 32+ then fromIntegral $ as32 x+ else fromIntegral $ as64 x+++hashString :: String -> Word+hashString = whichHash hashString32 hashString64+ where+ hashString32 s = Murmur.asWord32 $ Murmur.hash32 s+ hashString64 s = Murmur.asWord64 $ Murmur.hash64 s+{-# INLINE hashString #-}+++hashInt :: Int -> Word+hashInt = whichHash h32 h64+ where+ h32 x = Murmur.asWord32 $ Murmur.hash32 x+ h64 x = Murmur.asWord64 $ Murmur.hash64 x+{-# INLINE hashInt #-}+++hashBS :: B.ByteString -> Word+hashBS = whichHash h32 h64+ where+ h32 !s = Murmur.asWord32 $ B.foldl' f32 (Murmur.hash32 ([] :: [Int])) s+ h64 !s = Murmur.asWord64 $ B.foldl' f64 (Murmur.hash64 ([] :: [Int])) s++ f32 !h !c = Murmur.hash32AddInt (fromEnum c) h+ f64 !h !c = Murmur.hash64AddInt (fromEnum c) h+{-# 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 [] = []+ del (x:xs) = if fst x == key then xs else x:(del xs)+++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
src/Snap/Internal/Http/Server.hs view
@@ -20,6 +20,7 @@ import qualified Data.ByteString.Nums.Careless.Int as Cvt import Data.Int import Data.IORef+import Data.Iteratee.WrappedByteString (unWrap) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (fromJust, catMaybes, fromMaybe)@@ -428,10 +429,10 @@ let (SomeEnumerator enum) = senum let i = joinI $ takeNoMoreThan maximumPOSTBodySize stream2stream iter <- liftIO $ enum i- body <- lift iter- let newParams = parseUrlEncoded $ strictize $ fromWrap body+ body <- liftM unWrap $ lift iter+ let newParams = parseUrlEncoded body liftIO $ writeIORef (rqBody req)- (SomeEnumerator $ return . I.joinI . I.take 0)+ (SomeEnumerator $ enumBS body) return $ req { rqParams = rqParams req `mappend` newParams }
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -41,13 +41,8 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString as B-import Data.DList (DList)-import qualified Data.DList as D import Data.IORef import Data.Iteratee.WrappedByteString-import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set import Data.Typeable import Foreign hiding (new) import Foreign.C.Error@@ -58,6 +53,10 @@ import Prelude hiding (catch) import System.Timeout ------------------------------------------------------------------------------++-- FIXME: should be HashSet, make that later.+import qualified Data.HashMap.Concurrent as H+import Data.HashMap.Concurrent (HashMap) import Snap.Iteratee import Snap.Internal.Debug import Snap.Internal.Http.Server.Date@@ -81,11 +80,7 @@ , _asyncObj :: !EvAsyncPtr , _killCb :: !(FunPtr AsyncCallback) , _killObj :: !EvAsyncPtr- , _connectionThreads :: !(MVar (Set ThreadId))- , _connThreadEdits :: !(IORef (DList (Set ThreadId -> Set ThreadId)))- , _connThreadId :: !(MVar ThreadId)- , _connThreadIsDone :: !(MVar ())- , _threadActivity :: !(MVar ())+ , _connectionThreads :: !(HashMap ThreadId ()) , _backendCPU :: !Int } @@ -219,11 +214,7 @@ evIoStart lp accIO -- thread set stuff- connThreadMVar <- newEmptyMVar- connSet <- newMVar Set.empty- editsRef <- newIORef D.empty- connThreadDone <- newEmptyMVar- threadActivity <- newMVar ()+ connSet <- H.new (H.hashString . show) let b = Backend sock sockFd@@ -238,17 +229,10 @@ killCB killObj connSet- editsRef- connThreadMVar- connThreadDone- threadActivity cpu forkOnIO cpu $ loopThread b - conntid <- forkOnIO cpu $ connTableSeqThread b- putMVar connThreadMVar conntid- debug $ "Backend.new: loop spawned" return b @@ -357,8 +341,8 @@ where threadSet = _connectionThreads backend wait = do- threads <- readMVar threadSet- if (Set.null threads)+ b <- H.null threadSet+ if b then return () else threadDelay (seconds 1) >> wait @@ -399,15 +383,6 @@ evTimerAgain loop tmr -addThreadSetEdit :: Backend -> (Set ThreadId -> Set ThreadId) -> IO ()-addThreadSetEdit backend edit = do- atomicModifyIORef (_connThreadEdits backend) $ \els ->- (D.snoc els edit, ())-- tryPutMVar (_threadActivity backend) ()- return ()-- freeConnection :: Connection -> IO () freeConnection conn = ignoreException $ do withMVar loopLock $ \_ -> block $ do@@ -431,8 +406,8 @@ tid <- readMVar $ _connThread conn - -- schedule the removal of the thread id from the backend set- addThreadSetEdit backend (Set.delete tid)+ -- removal the thread id from the backend set+ H.delete tid $ _connectionThreads backend -- wake up the event loop so it can be apprised of the changes evAsyncSend loop asyncObj@@ -456,46 +431,14 @@ ignoreException = handle (\(_::SomeException) -> return ()) -connTableSeqThread :: Backend -> IO ()-connTableSeqThread backend = loop `finally` putMVar threadDone ()- where- threadDone = _connThreadIsDone backend- editsRef = _connThreadEdits backend- table = _connectionThreads backend- activity = _threadActivity backend-- loop = do- takeMVar activity-- -- grab the edits- edits <- atomicModifyIORef editsRef $ \t -> (D.empty, D.toList t)-- -- apply the edits- modifyMVar_ table $ \t -> block $ do- let !t' = List.foldl' (flip ($)) t edits- return t'-- -- zzz- threadDelay 1000000- loop-- freeBackend :: Backend -> IO () freeBackend backend = ignoreException $ block $ do -- note: we only get here after an unloop - readMVar (_connThreadId backend) >>= killThread- takeMVar $ _connThreadIsDone backend - -- read edits and obtain final thread table- threads <- withMVar (_connectionThreads backend) $ \table -> do- edits <- liftM D.toList $- readIORef (_connThreadEdits backend)-- let !t = List.foldl' (flip ($)) table edits- return $ Set.toList t-- mapM_ killThread threads+ -- kill everything in thread table+ tset <- H.toList $ _connectionThreads backend+ mapM_ (killThread . fst) tset debug $ "Backend.freeBackend: all threads killed" debug $ "Backend.freeBackend: destroying resources"@@ -622,7 +565,7 @@ tid <- forkOnIO cpu $ threadProc conn - addThreadSetEdit backend (Set.insert tid)+ H.update tid () (_connectionThreads backend) putMVar thrmv tid
test/snap-server-testsuite.cabal view
@@ -34,6 +34,7 @@ HTTP >= 4000.0.9 && < 4001, HUnit >= 1.2 && < 2, monads-fd,+ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, old-locale,@@ -51,7 +52,7 @@ build-depends: unix if flag(libev)- build-depends: hlibev >= 0.2.1+ build-depends: hlibev >= 0.2.5 && < 0.3 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else@@ -91,6 +92,7 @@ old-locale, parallel > 2, iteratee >= 0.3.1 && < 0.4,+ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, snap-core >= 0.2.7 && <0.3,@@ -105,7 +107,7 @@ build-depends: unix if flag(libev)- build-depends: hlibev >= 0.2.1+ build-depends: hlibev >= 0.2.5 && < 0.3 other-modules: Snap.Internal.Http.Server.LibevBackend cpp-options: -DLIBEV else
+ test/suite/Data/HashMap/Concurrent/Tests.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}++module Data.HashMap.Concurrent.Tests+ ( tests ) where++import Data.List+import Test.Framework +import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.QuickCheck.Monadic++import qualified Data.HashMap.Concurrent as H++tests :: [Test]+tests = [ testFromTo ]+++testFromTo :: Test+testFromTo = testProperty "HashMap/fromList/toList" $+ monadicIO $ forAllM arbitrary prop+ where+ prop l = do+ ht <- run $ H.fromList H.hashInt (l :: [(Int,Int)])+ l' <- run $ H.toList ht++ let s1 = sort l+ let s2 = sort l'++ assert $ s1 == s2
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -266,10 +266,13 @@ (rqParam "postparam2" req) (Just ["2"]) - -- if we're www-form-encoded then we will have read the body already- assertEqual "parse body" "" body+ -- make sure the post body is still emitted+ assertEqual "parse body" (LC.fromChunks [samplePostBody3]) body +samplePostBody3 :: ByteString+samplePostBody3 = "postparam1=1&postparam2=2"+ sampleRequest3 :: ByteString sampleRequest3 = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"@@ -279,7 +282,9 @@ , "Multiheader: 2\r\n" , "X-Random-Other-Header: foo\r\n bar\r\n" , "\r\n"- , "postparam1=1&postparam2=2" ]+ , samplePostBody3 ]++ rsm :: ServerMonad a -> Iteratee IO a
test/suite/Snap/Test/Common.hs view
@@ -7,7 +7,6 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w) import Test.QuickCheck-import Test.QuickCheck.Gen instance Arbitrary S.ByteString where
test/suite/TestSuite.hs view
@@ -2,12 +2,15 @@ import Test.Framework (defaultMain, testGroup) +import qualified Data.HashMap.Concurrent.Tests import qualified Snap.Internal.Http.Parser.Tests import qualified Snap.Internal.Http.Server.Tests+ main :: IO () main = defaultMain tests- where tests = [- testGroup "Snap.Internal.Http.Parser.Tests"+ where tests = [ testGroup "Data.HashMap.Concurrent.Tests"+ Data.HashMap.Concurrent.Tests.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