snap-server 0.2.10.2 → 0.2.11
raw patch · 15 files changed
+599/−416 lines, 15 filesdep ~snap-core
Dependency ranges changed: snap-core
Files
- snap-server.cabal +9/−7
- src/Data/Concurrent/HashMap.hs +238/−0
- src/Data/Concurrent/HashMap/Internal.hs +16/−0
- src/Data/HashMap/Concurrent.hs +0/−238
- src/Data/HashMap/Concurrent/Internal.hs +0/−16
- src/Snap/Internal/Http/Server.hs +38/−6
- src/Snap/Internal/Http/Server/Date.hs +43/−21
- src/Snap/Internal/Http/Server/LibevBackend.hs +3/−3
- test/suite/Data/Concurrent/HashMap/Tests.hs +121/−0
- test/suite/Data/HashMap/Concurrent/Tests.hs +0/−121
- test/suite/Snap/Internal/Http/Server/Tests.hs +57/−1
- test/suite/TestSuite.hs +3/−3
- test/testserver/Main.hs +61/−0
- test/testserver/Paths_snap_server.hs +9/−0
- test/testserver/static/hello.txt +1/−0
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.2.10.2+version: 0.2.11 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,12 +66,14 @@ 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/Data/Concurrent/HashMap/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+ test/suite/TestSuite.hs,+ test/testserver/Main.hs,+ test/testserver/Paths_snap_server.hs,+ test/testserver/static/hello.txt Flag libev@@ -88,13 +90,13 @@ hs-source-dirs: src exposed-modules:- Data.HashMap.Concurrent, Snap.Http.Server, Snap.Http.Server.Config, System.FastLogger other-modules:- Data.HashMap.Concurrent.Internal,+ Data.Concurrent.HashMap,+ Data.Concurrent.HashMap.Internal, Paths_snap_server, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, @@ -118,7 +120,7 @@ murmur-hash >= 0.1 && < 0.2, network == 2.2.1.*, old-locale,- snap-core >= 0.2.10 && <0.3,+ snap-core >= 0.2.11 && <0.3, template-haskell, time, transformers,
+ src/Data/Concurrent/HashMap.hs view
@@ -0,0 +1,238 @@+{-# 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 ) 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
+ src/Data/Concurrent/HashMap/Internal.hs view
@@ -0,0 +1,16 @@+{-# 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 |]
− src/Data/HashMap/Concurrent.hs
@@ -1,238 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}--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# )-#else-import Data.Word-#endif--import Data.HashMap.Concurrent.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
− src/Data/HashMap/Concurrent/Internal.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.HashMap.Concurrent.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 |]
src/Snap/Internal/Http/Server.hs view
@@ -127,8 +127,10 @@ -------------------------------------------------------------------------- runAll alog elog xs = {-# SCC "httpServe/runAll" #-} do- Prelude.mapM_ f $ xs `zip` [0..]- Prelude.mapM_ (takeMVar . snd) xs+ tids <- Prelude.mapM f $ xs `zip` [0..]+ Prelude.mapM_ (takeMVar . snd) xs `catch` \ (e::SomeException) -> do+ mapM killThread tids+ throwIO e where f ((backend,mvar),cpu) = forkOnIO cpu $ do labelMe $ map w2c $ S.unpack $@@ -352,6 +354,10 @@ Prelude.show (rqMethod req) ++ " " ++ SC.unpack (rqURI req) ++ " " ++ Prelude.show (rqVersion req)++ -- check for Expect: 100-continue+ checkExpect100Continue req writeEnd+ logerr <- gets _logError (req',rspOrig) <- lift $ handler logerr req @@ -395,6 +401,29 @@ ------------------------------------------------------------------------------+checkExpect100Continue :: Request+ -> Iteratee IO ()+ -> ServerMonad ()+checkExpect100Continue req writeEnd = do+ let mbEx = getHeaders "Expect" req++ maybe (return ())+ (\l -> if elem "100-continue" l then go else return ())+ mbEx++ where+ go = do+ let (major,minor) = rqVersion req+ let hl = [ "HTTP/"+ , bsshow major+ , "."+ , bsshow minor+ , " 100 Continue\r\n\r\n" ] + iter <- liftIO $ enumBS (S.concat hl) writeEnd+ liftIO $ run iter+++------------------------------------------------------------------------------ receiveRequest :: ServerMonad (Maybe Request) receiveRequest = do mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift parseRequest@@ -703,10 +732,6 @@ --------------------------------------------------------------------------- bsshow = l2s . show--- -------------------------------------------------------------------------- mkHeaderString :: Response -> ByteString mkHeaderString r = {-# SCC "mkHeaderString" #-}@@ -765,3 +790,10 @@ ------------------------------------------------------------------------------ toBS :: String -> ByteString toBS = S.pack . map c2w+++--------------------------------------------------------------------------+bsshow :: (Show a) => a -> ByteString+bsshow = l2s . show++
src/Snap/Internal/Http/Server/Date.hs view
@@ -11,6 +11,7 @@ import Control.Monad import Data.ByteString (ByteString) import Data.IORef+import Data.Maybe import Foreign.C.Types import System.IO.Unsafe @@ -31,16 +32,18 @@ -- running the computation on a timer. We'll allow client traffic to trigger -- the process. +------------------------------------------------------------------------------ data DateState = DateState { _cachedDateString :: !(IORef ByteString) , _cachedLogString :: !(IORef ByteString) , _cachedDate :: !(IORef CTime) , _valueIsOld :: !(IORef Bool) , _morePlease :: !(MVar ())- , _dataAvailable :: !(MVar ()) , _dateThread :: !(MVar ThreadId) } ++------------------------------------------------------------------------------ dateState :: DateState dateState = unsafePerformIO $ do (s1,s2,date) <- fetchTime@@ -50,9 +53,8 @@ ov <- newIORef False th <- newEmptyMVar mp <- newMVar ()- da <- newMVar () - let d = DateState bs1 bs2 dt ov mp da th+ let d = DateState bs1 bs2 dt ov mp th t <- forkIO $ dateThread d putMVar th t@@ -61,6 +63,7 @@ #ifdef PORTABLE+------------------------------------------------------------------------------ epochTime :: IO CTime epochTime = do t <- getPOSIXTime@@ -68,6 +71,7 @@ #endif +------------------------------------------------------------------------------ fetchTime :: IO (ByteString,ByteString,CTime) fetchTime = do now <- epochTime@@ -76,48 +80,66 @@ return (t1, t2, now) -dateThread :: DateState -> IO ()-dateThread ds@(DateState dateString logString time valueIsOld morePlease- dataAvailable _) = do- -- a lot of effort to make sure we don't deadlock- takeMVar morePlease-+------------------------------------------------------------------------------+updateState :: DateState -> IO ()+updateState (DateState dateString logString time valueIsOld _ _) = do (s1,s2,now) <- fetchTime atomicModifyIORef dateString $ const (s1,())- atomicModifyIORef logString $ const (s2,())- atomicModifyIORef time $ const (now,())-+ atomicModifyIORef logString $ const (s2,())+ atomicModifyIORef time $ const (now,()) writeIORef valueIsOld False- tryPutMVar dataAvailable () - threadDelay 2000000+ -- force values in the iorefs to prevent thunk buildup+ !_ <- readIORef dateString+ !_ <- readIORef logString+ !_ <- readIORef time - takeMVar dataAvailable- writeIORef valueIsOld True+ return () - dateThread ds +------------------------------------------------------------------------------+dateThread :: DateState -> IO ()+dateThread ds@(DateState _ _ _ valueIsOld morePlease _) = loop+ where+ loop = do+ b <- tryTakeMVar morePlease+ when (isNothing b) $ do+ writeIORef valueIsOld True+ takeMVar morePlease++ updateState ds+ threadDelay 2000000+ loop+++------------------------------------------------------------------------------ ensureFreshDate :: IO () ensureFreshDate = block $ do old <- readIORef $ _valueIsOld dateState- when old $ do- tryPutMVar (_morePlease dateState) ()- readMVar $ _dataAvailable dateState+ tryPutMVar (_morePlease dateState) () + -- if the value is not fresh we will tickle the date thread but also fetch+ -- the new value immediately; we used to block but we'll do a little extra+ -- work to avoid a delay+ when old $ updateState dateState+++------------------------------------------------------------------------------ getDateString :: IO ByteString getDateString = block $ do ensureFreshDate readIORef $ _cachedDateString dateState +------------------------------------------------------------------------------ getLogDateString :: IO ByteString getLogDateString = block $ do ensureFreshDate readIORef $ _cachedLogString dateState +------------------------------------------------------------------------------ getCurrentDateTime :: IO CTime getCurrentDateTime = block $ do ensureFreshDate readIORef $ _cachedDate dateState-
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -55,8 +55,8 @@ ------------------------------------------------------------------------------ -- FIXME: should be HashSet, make that later.-import qualified Data.HashMap.Concurrent as H-import Data.HashMap.Concurrent (HashMap)+import qualified Data.Concurrent.HashMap as H+import Data.Concurrent.HashMap (HashMap) import Snap.Iteratee import Snap.Internal.Debug import Snap.Internal.Http.Server.Date@@ -436,7 +436,7 @@ -- kill everything in thread table tset <- H.toList $ _connectionThreads backend- mapM_ (killThread . fst) tset+ Prelude.mapM_ (killThread . fst) tset debug $ "Backend.freeBackend: all threads killed" debug $ "Backend.freeBackend: destroying resources"
+ test/suite/Data/Concurrent/HashMap/Tests.hs view
@@ -0,0 +1,121 @@+{-# 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"
− test/suite/Data/HashMap/Concurrent/Tests.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module Data.HashMap.Concurrent.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.HashMap.Concurrent 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"
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -50,6 +50,7 @@ , testHttpResponse4 , testHttp1 , testHttp2+ , testHttp100 , testPartialParse , testMethodParsing , testServerStartupShutdown@@ -72,6 +73,17 @@ , "\r\n" , "0123456789" ] +sampleRequestExpectContinue :: ByteString+sampleRequestExpectContinue =+ S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"+ , "Host: www.zabble.com:7777\r\n"+ , "Content-Length: 10\r\n"+ , "Expect: 100-continue\r\n"+ , "X-Random-Other-Header: foo\r\n bar\r\n"+ , "Cookie: foo=\"bar\\\"\"\r\n"+ , "\r\n"+ , "0123456789" ]+ sampleRequest1_0 :: ByteString sampleRequest1_0 = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.0\r\n"@@ -84,7 +96,7 @@ testMethodParsing :: Test testMethodParsing =- testCase "method parsing" $ mapM_ testOneMethod ms+ testCase "method parsing" $ Prelude.mapM_ testOneMethod ms where ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ] @@ -591,6 +603,50 @@ _ -> False assertBool "connection: close" ok++++testHttp100 :: Test+testHttp100 = testCase "Expect: 100-continue" $ do+ let enumBody = enumBS sampleRequestExpectContinue++ ref <- newIORef ""++ let (iter,onSendFile) = mkIter ref++ runHTTP "localhost"+ "127.0.0.1"+ 80+ "127.0.0.1"+ 58384+ Nothing+ Nothing+ enumBody+ iter+ onSendFile+ (return ())+ echoServer2++ s <- readIORef ref++ let lns = LC.lines s++ let ok = case lns of+ ([ "HTTP/1.1 100 Continue\r"+ , "\r"+ , "HTTP/1.1 200 OK\r"+ , "Content-Length: 10\r"+ , d1+ , s1+ , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r"+ , "\r"+ , "0123456789" ]) -> (("Date" `L.isPrefixOf` d1) &&+ ("Server" `L.isPrefixOf` s1))++ _ -> False++ assertBool "100 Continue" ok+
test/suite/TestSuite.hs view
@@ -2,14 +2,14 @@ import Test.Framework (defaultMain, testGroup) -import qualified Data.HashMap.Concurrent.Tests+import qualified Data.Concurrent.HashMap.Tests import qualified Snap.Internal.Http.Parser.Tests import qualified Snap.Internal.Http.Server.Tests main :: IO () main = defaultMain tests- where tests = [ testGroup "Data.HashMap.Concurrent.Tests"- Data.HashMap.Concurrent.Tests.tests+ where tests = [ testGroup "Data.Concurrent.HashMap.Tests"+ Data.Concurrent.HashMap.Tests.tests , testGroup "Snap.Internal.Http.Parser.Tests" Snap.Internal.Http.Parser.Tests.tests , testGroup "Snap.Internal.Http.Server.Tests"
+ test/testserver/Main.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent++import Snap.Iteratee+import Snap.Types+import Snap.Http.Server+import Snap.Util.FileServe++{-++/pong+/fileserve+/echo+pipelined POST requests+slowloris attack / timeout test++-}++pongHandler :: Snap ()+pongHandler = modifyResponse $ setResponseBody (enumBS "PONG") .+ setContentType "text/plain" .+ setContentLength 4++echoHandler :: Snap ()+echoHandler = do+ req <- getRequest+ writeBS $ rqPathInfo req++responseHandler = do+ code <- getParam "code"+ case code of+ Nothing -> undefined+ Just code -> f code+ where+ f "300" = undefined+ f "304" = undefined++handlers :: Snap ()+handlers =+ route [ ("pong", pongHandler)+ , ("echo", echoHandler)+ , ("fileserve", fileServe "static")+ , ("respcode/:code", responseHandler)+ ]++main :: IO ()+main = do+ m <- newEmptyMVar++ forkIO $ go m+ takeMVar m++ return ()++ where+ go m = do+ httpServe "*" 3000 "localhost" Nothing Nothing handlers + putMVar m ()+
+ test/testserver/Paths_snap_server.hs view
@@ -0,0 +1,9 @@+module Paths_snap_server (+ version+ ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,0,0], versionTags = ["unknown"]}+
+ test/testserver/static/hello.txt view
@@ -0,0 +1,1 @@+hello world