snap-server 0.2.9 → 0.2.10
raw patch · 6 files changed
+130/−35 lines, 6 filesdep +template-haskelldep ~attoparsecdep ~snap-corenew-uploader
Dependencies added: template-haskell
Dependency ranges changed: attoparsec, snap-core
Files
- snap-server.cabal +4/−3
- src/Data/HashMap/Concurrent.hs +23/−23
- src/Snap/Internal/Http/Server.hs +3/−3
- test/runTestsAndCoverage.sh +3/−0
- test/snap-server-testsuite.cabal +4/−3
- test/suite/Data/HashMap/Concurrent/Tests.hs +93/−3
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.2.9+version: 0.2.10 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@@ -101,7 +101,7 @@ build-depends: array >= 0.2 && <0.4,- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, bytestring,@@ -117,7 +117,8 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale,- snap-core >= 0.2.9 && <0.3,+ snap-core >= 0.2.10 && <0.3,+ template-haskell, time, transformers, unix-compat,
src/Data/HashMap/Concurrent.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} module Data.HashMap.Concurrent ( HashMap@@ -35,44 +36,44 @@ 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+import Data.HashMap.Concurrent.Internal hashString :: String -> Word-hashString = whichHash hashString32 hashString64- where- hashString32 s = Murmur.asWord32 $ Murmur.hash32 s- hashString64 s = Murmur.asWord64 $ Murmur.hash64 s+hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]+ [| Murmur.asWord64 . Murmur.hash64 |]) {-# INLINE hashString #-} hashInt :: Int -> Word-hashInt = whichHash h32 h64- where- h32 x = Murmur.asWord32 $ Murmur.hash32 x- h64 x = Murmur.asWord64 $ Murmur.hash64 x+hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |]+ [| Murmur.asWord64 . Murmur.hash64 |]) {-# 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+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 #-} @@ -215,8 +216,7 @@ 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)+ del = filter ((/= key) . fst) lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v
src/Snap/Internal/Http/Server.hs view
@@ -120,15 +120,15 @@ bracket (spawn n) (\xs -> do logE elog "Server.httpServe: SHUTDOWN"- mapM_ (Backend.stop . fst) xs+ Prelude.mapM_ (Backend.stop . fst) xs logE elog "Server.httpServe: BACKEND STOPPED") (runAll alog elog) -------------------------------------------------------------------------- runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do- mapM_ f $ xs `zip` [0..]- mapM_ (takeMVar . snd) xs+ Prelude.mapM_ f $ xs `zip` [0..]+ Prelude.mapM_ (takeMVar . snd) xs where f ((backend,mvar),cpu) = forkOnIO cpu $ do labelMe $ map w2c $ S.unpack $
test/runTestsAndCoverage.sh view
@@ -25,6 +25,9 @@ EXCLUDES='Main Data.CIByteString+Data.HashMap.Concurrent.Internal+Data.HashMap.Concurrent.Tests+Paths_snap_server Snap.Internal.Http.Parser.Tests Snap.Internal.Http.Server.Tests Snap.Internal.Http.Types.Tests
test/snap-server-testsuite.cabal view
@@ -19,7 +19,7 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4,- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, binary >= 0.5 && < 0.6,@@ -75,7 +75,7 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4,- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, bytestring,@@ -149,7 +149,7 @@ build-depends: QuickCheck >= 2, array >= 0.3 && <0.4,- attoparsec >= 0.8.0.2 && < 0.9,+ attoparsec >= 0.8.1 && < 0.9, attoparsec-iteratee >= 0.1.1 && <0.2, base >= 4 && < 5, bytestring,@@ -170,6 +170,7 @@ network == 2.2.1.7, network-bytestring >= 0.1.2 && < 0.2, snap-core >= 0.2.9 && <0.3,+ template-haskell, time, transformers, unix-compat,
test/suite/Data/HashMap/Concurrent/Tests.hs view
@@ -5,27 +5,117 @@ module Data.HashMap.Concurrent.Tests ( tests ) where +import Data.ByteString.Char8 (ByteString) import Data.List-import Test.Framework +import Data.Word+import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import Test.QuickCheck.Monadic import qualified Data.HashMap.Concurrent as H+import Snap.Test.Common () tests :: [Test]-tests = [ testFromTo ]+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 :: [(Int,Int)])+ 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"