snap-server 0.4.1 → 0.4.2
raw patch · 16 files changed
+625/−534 lines, 16 filesdep ~blaze-builderdep ~snap-core
Dependency ranges changed: blaze-builder, snap-core
Files
- README.SNAP.md +1/−1
- snap-server.cabal +10/−11
- src/Snap/Http/Server/Config.hs +29/−20
- src/Snap/Internal/Http/Parser.hs +128/−82
- src/Snap/Internal/Http/Server.hs +54/−18
- src/Snap/Internal/Http/Server/LibevBackend.hs +9/−13
- src/Snap/Internal/Http/Server/SimpleBackend.hs +19/−55
- src/Snap/Internal/Http/Server/TimeoutManager.hs +170/−0
- src/Snap/Internal/Http/Server/TimeoutTable.hs +0/−139
- test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs +15/−40
- test/snap-server-testsuite.cabal +13/−4
- test/suite/Data/Concurrent/HashMap/Tests.hs +0/−121
- test/suite/Snap/Internal/Http/Server/Tests.hs +52/−5
- test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs +76/−0
- test/suite/Test/Blackbox.hs +19/−11
- test/suite/TestSuite.hs +30/−14
README.SNAP.md view
@@ -9,7 +9,7 @@ Snap Status and Features ------------------------ -This developer prerelease contains only the Snap core system, namely:+The Snap core system consists of: * a high-speed HTTP server, with an optional high-concurrency backend using the [libev](http://software.schmorp.de/pkg/libev.html) library
snap-server.cabal view
@@ -1,11 +1,10 @@ name: snap-server-version: 0.4.1+version: 0.4.2 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- simple and fast web development framework and server written in Haskell. For- more information or to download the latest version, you can visit the Snap- project website at <http://snapframework.com/>.+ Snap is a simple and fast web development framework and server written in+ Haskell. For more information or to download the latest version, you can+ visit the Snap project website at <http://snapframework.com/>. . The Snap HTTP server is a high performance, epoll-enabled, iteratee-based web server library written in Haskell. Together with the @snap-core@ library upon@@ -53,9 +52,9 @@ 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,9 +84,9 @@ System.FastLogger other-modules:+ Paths_snap_server, Data.Concurrent.HashMap, Data.Concurrent.HashMap.Internal,- Paths_snap_server, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, Snap.Internal.Http.Server.Date,@@ -95,7 +94,7 @@ 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 @@ -105,7 +104,7 @@ attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, binary >=0.5 && <0.6,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums,@@ -118,7 +117,7 @@ murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale,- snap-core >= 0.4.1 && <0.5,+ snap-core >= 0.4.2 && <0.5, template-haskell, time, transformers,@@ -138,7 +137,7 @@ cpp-options: -DLIBEV if flag(gnutls)- extra-libraries: gnutls+ extra-libraries: gnutls gcrypt cpp-options: -DGNUTLS c-sources: src/Snap/Internal/Http/Server/gnutls_helpers.c
src/Snap/Http/Server/Config.hs view
@@ -54,6 +54,7 @@ import Prelude hiding (catch) import Snap.Types import Snap.Iteratee ((>==>), enumBuilder)+import Snap.Internal.Debug (debug) import System.Console.GetOpt import System.Environment hiding (getEnv) #ifndef PORTABLE@@ -192,29 +193,37 @@ -- defaultConfig :: MonadSnap m => Config m a defaultConfig = Config- { hostname = Just "localhost"- , listen = []- , accessLog = Just $ Just "log/access.log"- , errorLog = Just $ Just "log/error.log"- , locale = Just "en_US"- , backend = Nothing- , compression = Just True- , verbose = Just True- , errorHandler = Just $ \e -> do- let err = U.fromString $ show e- msg = mappend "A web handler threw an exception. Details:\n" err- finishWith $ setContentType "text/plain; charset=utf-8"- . setContentLength (fromIntegral $ B.length msg)- . setResponseStatus 500 "Internal Server Error"- . modifyResponseBody- (>==> enumBuilder (fromByteString msg))- $ emptyResponse+ { hostname = Just "localhost"+ , listen = []+ , accessLog = Just $ Just "log/access.log"+ , errorLog = Just $ Just "log/error.log"+ , locale = Just "en_US"+ , backend = Nothing+ , compression = Just True+ , verbose = Just True+ , errorHandler = Just defaultErrorHandler , defaultTimeout = Just 60- , other = Nothing+ , other = Nothing } ------------------------------------------------------------------------------+defaultErrorHandler :: MonadSnap m => SomeException -> m ()+defaultErrorHandler e = do+ debug "Snap.Http.Server.Config errorHandler: got exception:"+ debug $ show e+ logError msg+ finishWith $ setContentType "text/plain; charset=utf-8"+ . setContentLength (fromIntegral $ B.length msg)+ . setResponseStatus 500 "Internal Server Error"+ . modifyResponseBody+ (>==> enumBuilder (fromByteString msg))+ $ emptyResponse+ where + err = U.fromString $ show e+ msg = mappend "A web handler threw an exception. Details:\n" err++------------------------------------------------------------------------------ -- | Completes a partial 'Config' by filling in the unspecified values with -- the default values from 'defaultConfig'. Also, if no listeners are -- specified, adds a http listener on 0.0.0.0:8000@@ -355,10 +364,10 @@ (ReqArg (\s -> Just $ mempty { sslport = Just $ read s}) "PORT") $ "ssl port to listen on" ++ defaultO sslport , Option [] ["ssl-cert"]- (ReqArg (\s -> Just $ mempty { sslcert = Just $ read s}) "PATH")+ (ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH") $ "path to ssl certificate in PEM format" ++ defaultO sslcert , Option [] ["ssl-key"]- (ReqArg (\s -> Just $ mempty { sslkey = Just $ read s}) "PATH")+ (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey , Option [] ["access-log"] (ReqArg (Just . setConfig setAccessLog . Just) "PATH")
src/Snap/Internal/Http/Parser.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-} module Snap.Internal.Http.Parser ( IRequest(..)+ , HttpParseException , parseRequest , readChunkedTransferEncoding , iterParser@@ -16,16 +18,17 @@ -------------------------------------------------------------------------------import Control.Applicative import Control.Arrow (second)+import Control.Exception import Control.Monad (liftM) import Control.Monad.Trans import Data.Attoparsec hiding (many, Result(..)) import Data.Attoparsec.Enumerator-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Unsafe as S+import Data.ByteString.Internal (w2c)+import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Nums.Careless.Hex as Cvt import Data.Char import Data.List (foldl')@@ -33,12 +36,13 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes)+import Data.Typeable import Prelude hiding (head, take, takeWhile) ---------------------------------------------------------------------------- import Snap.Internal.Http.Types import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug-import Snap.Internal.Parsing+import Snap.Internal.Parsing hiding (pHeaders) import Snap.Iteratee hiding (map, take) @@ -65,106 +69,148 @@ ------------------------------------------------------------------------------+data HttpParseException = HttpParseException String deriving (Typeable, Show)+instance Exception HttpParseException++------------------------------------------------------------------------------ parseRequest :: (Monad m) => Iteratee ByteString m (Maybe IRequest)-parseRequest = iterParser pRequest+parseRequest = do+ eof <- isEOF+ if eof+ then return Nothing+ else do+ line <- pLine+ if S.null line+ then parseRequest+ else do+ let (!mStr,!s) = bSp line+ let (!uri,!vStr) = bSp s + !method <- methodFromString mStr --------------------------------------------------------------------------------readChunkedTransferEncoding :: (MonadIO m) =>- Enumeratee ByteString ByteString m a-readChunkedTransferEncoding =- chunkParserToEnumeratee $- iterateeDebugWrapper "pGetTransferChunk" $- iterParser pGetTransferChunk+ let ver@(!_,!_) = pVer vStr + hdrs <- pHeaders+ return $ Just $ IRequest method uri ver hdrs --------------------------------------------------------------------------------chunkParserToEnumeratee :: (MonadIO m) =>- Iteratee ByteString m (Maybe ByteString)- -> Enumeratee ByteString ByteString m a-chunkParserToEnumeratee getChunk client = do- debug $ "chunkParserToEnumeratee: getting chunk"- mbB <- getChunk- debug $ "chunkParserToEnumeratee: getChunk was " ++ show mbB- mbX <- peek- debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX+ where+ pVer s = if S.isPrefixOf "HTTP/" s+ then let (a,b) = bDot $ S.drop 5 s+ in (read $ S.unpack a, read $ S.unpack b)+ else (1,0) + isSp = (== ' ')+ bSp = splitWith isSp+ isDot = (== '.')+ bDot = splitWith isDot - maybe finishIt sendBS mbB +------------------------------------------------------------------------------+pLine :: (Monad m) => Iteratee ByteString m ByteString+pLine = continue $ k S.empty where- whatWasReturn (Continue _) = "continue"- whatWasReturn (Yield _ z) = "yield, with remainder " ++ show z- whatWasReturn (Error e) = "error, with " ++ show e+ k _ EOF = throwError $+ HttpParseException "parse error: expected line ending in crlf"+ k !pre (Chunks xs) =+ if S.null b+ then continue $ k a+ else yield a (Chunks [S.drop 2 b])+ where+ (!a,!b) = S.breakSubstring "\r\n" s+ !s = S.append pre s'+ !s' = S.concat xs - sendBS s = do- step' <- lift $ runIteratee $ enumBS s client- debug $ "chunkParserToEnumeratee: after sending "- ++ show s ++ ", return was "- ++ whatWasReturn step'- mbX <- peek- debug $ "chunkParserToEnumeratee: .. and peek is " ++ show mbX- chunkParserToEnumeratee getChunk step' - finishIt = lift $ runIteratee $ enumEOF client+------------------------------------------------------------------------------+splitWith :: (Char -> Bool) -> ByteString -> (ByteString,ByteString)+splitWith !f !s = let (!a,!b) = S.break f s+ !b' = S.dropWhile f b+ in (a, b') --------------------------------------------------------------------------------- parse functions-------------------------------------------------------------------------------+pHeaders :: Monad m => Iteratee ByteString m [(ByteString,ByteString)]+pHeaders = do+ f <- go id+ return $! f []+ where+ go !dlistSoFar = {-# SCC "pHeaders/go" #-} do+ line <- pLine+ if S.null line+ then return dlistSoFar+ else do+ let (!k,!v) = pOne line+ vf <- pCont id+ let vs = vf []+ let !v' = S.concat (v:vs)+ go (dlistSoFar . ((k,v'):)) --- theft alert: many of these routines adapted from Johan Tibell's hyena--- package+ where+ pOne s = let (k,v) = splitWith (== ':') s+ in (trim k, trim v) + isCont c = c == ' ' || c == '\t' ---------------------------------------------------------------------------------- | Parser for the internal request data type.-pRequest :: Parser (Maybe IRequest)-pRequest = (Just <$> pRequest') <|>- (option "" crlf *> endOfInput *> pure Nothing)+ pCont !dlist = do+ mbS <- peek+ maybe (return dlist)+ (\s -> if S.null s+ then head >> pCont dlist+ else if isCont $ w2c $ S.unsafeHead s+ then procCont dlist+ else return dlist)+ mbS + procCont !dlist = do+ line <- pLine+ let !t = trim line+ pCont (dlist . (" ":) . (t:)) --------------------------------------------------------------------------------pRequest' :: Parser IRequest-pRequest' = IRequest- <$> (option "" crlf *> pMethod) <* sp- <*> pUri <* sp- <*> pVersion <* crlf- <*> pHeaders <* crlf - -- note: the optional crlf is at the beginning because some older browsers- -- send an extra crlf after a POST body+------------------------------------------------------------------------------+methodFromString :: (Monad m) => ByteString -> Iteratee ByteString m Method+methodFromString "GET" = return GET+methodFromString "POST" = return POST+methodFromString "HEAD" = return HEAD+methodFromString "PUT" = return PUT+methodFromString "DELETE" = return DELETE+methodFromString "TRACE" = return TRACE+methodFromString "OPTIONS" = return OPTIONS+methodFromString "CONNECT" = return CONNECT+methodFromString s = + throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'" --------------------------------------------------------------------------------- | Parser for the request method.-pMethod :: Parser Method-pMethod = (OPTIONS <$ string "OPTIONS")- <|> (GET <$ string "GET")- <|> (HEAD <$ string "HEAD")- <|> word8 (c2w 'P') *> ((POST <$ string "OST") <|>- (PUT <$ string "UT"))- <|> (DELETE <$ string "DELETE")- <|> (TRACE <$ string "TRACE")- <|> (CONNECT <$ string "CONNECT")+readChunkedTransferEncoding :: (MonadIO m) =>+ Enumeratee ByteString ByteString m a+readChunkedTransferEncoding =+ chunkParserToEnumeratee $+ iterateeDebugWrapper "pGetTransferChunk" $+ iterParser pGetTransferChunk --------------------------------------------------------------------------------- | Parser for the request URI.-pUri :: Parser ByteString-pUri = takeWhile (not . isSpace . w2c)+chunkParserToEnumeratee :: (MonadIO m) =>+ Iteratee ByteString m (Maybe ByteString)+ -> Enumeratee ByteString ByteString m a+chunkParserToEnumeratee getChunk client = do+ mbB <- getChunk+ maybe finishIt sendBS mbB + where+ sendBS s = do+ step <- lift $ runIteratee $ enumBS s client+ chunkParserToEnumeratee getChunk step ---------------------------------------------------------------------------------- | Parser for the request's HTTP protocol version.-pVersion :: Parser (Int, Int)-pVersion = string "HTTP/" *>- liftA2 (,) (digit' <* word8 (c2w '.')) digit'- where- digit' = fmap digitToInt digit+ finishIt = lift $ runIteratee $ enumEOF client ------------------------------------------------------------------------------+-- parse functions+------------------------------------------------------------------------------++------------------------------------------------------------------------------ pGetTransferChunk :: Parser (Maybe ByteString) pGetTransferChunk = do !hex <- liftM fromHex $ (takeWhile (isHexDigit . w2c))@@ -215,10 +261,10 @@ Map.empty decoded where- breakApart = (second (S.drop 1)) . S.break (== (c2w '='))+ breakApart = (second (S.drop 1)) . S.break (== '=') parts :: [(ByteString,ByteString)]- parts = map breakApart $ S.split (c2w '&') s+ parts = map breakApart $ S.split '&' s urldecode = parseToCompletion pUrlEscaped
src/Snap/Internal/Http/Server.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Snap.Internal.Http.Server where@@ -27,10 +28,11 @@ import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromJust, catMaybes, fromMaybe)+import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Monoid-import Data.Version import Data.Time+import Data.Typeable+import Data.Version import GHC.Conc import System.PosixCompat.Files hiding (setFileSize) import System.Posix.Types (FileOffset)@@ -88,6 +90,14 @@ ------------------------------------------------------------------------------+-- This exception will be thrown if we decided to terminate the request before+-- running the user handler.+data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException+ deriving (Show, Typeable)+instance Exception TerminatedBeforeHandlerException+++------------------------------------------------------------------------------ defaultEvType :: EventLoopType #ifdef LIBEV defaultEvType = EventLoopLibEv@@ -250,9 +260,12 @@ -> IO () runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile tickle =- go `catches` [ Handler $ \(e :: AsyncException) -> do+ go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do+ return ()+ , Handler $ \(e :: HttpParseException) -> do+ return ()+ , Handler $ \(e :: AsyncException) -> do throwIO e- , Handler $ \(e :: SomeException) -> logE elog $ S.concat [ logPrefix , bshow e ] ] @@ -310,7 +323,7 @@ let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd' liftIO $ debug "Server.httpSession: entered"- mreq <- receiveRequest+ mreq <- receiveRequest writeEnd liftIO $ debug "Server.httpSession: receiveRequest finished" -- successfully got a request, so restart timer@@ -408,8 +421,30 @@ -------------------------------------------------------------------------------receiveRequest :: ServerMonad (Maybe Request)-receiveRequest = do+return411 :: Request+ -> Iteratee ByteString IO ()+ -> ServerMonad a+return411 req writeEnd = do+ go+ liftIO $ throwIO $ TerminatedBeforeHandlerException++ where+ go = do+ let (major,minor) = rqVersion req+ let hl = mconcat [ fromByteString "HTTP/"+ , fromShow major+ , fromWord8 $ c2w '.'+ , fromShow minor+ , fromByteString " 411 Length Required\r\n\r\n"+ , fromByteString "411 Length Required\r\n" ]+ liftIO $ runIteratee+ ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)+ return ()+++------------------------------------------------------------------------------+receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request)+receiveRequest writeEnd = do debug "receiveRequest: entered" mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $ iterateeDebugWrapper "parseRequest" parseRequest@@ -469,15 +504,17 @@ joinI $ takeExactly len st' noContentLength :: Request -> ServerMonad ()- noContentLength rq = liftIO $ do+ noContentLength rq = do debug ("receiveRequest/setEnumerator: " ++ "request did NOT have content-length")++ when (rqMethod rq == POST || rqMethod rq == PUT) $+ return411 req writeEnd+ let enum = SomeEnumerator $- if rqMethod rq == POST || rqMethod rq == PUT- then returnI- else iterateeDebugWrapper "noContentLength" .- joinI . I.take 0- writeIORef (rqBody rq) enum+ iterateeDebugWrapper "noContentLength" .+ joinI . I.take 0+ liftIO $ writeIORef (rqBody rq) enum debug "receiveRequest/setEnumerator: body enumerator set" @@ -542,7 +579,6 @@ -- will override in "setEnumerator" enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")- return $ Request serverName serverPort
src/Snap/Internal/Http/Server/LibevBackend.hs view
@@ -112,10 +112,10 @@ [0..(cap-1)] debug "libevEventLoop: waiting for loop exit"- Prelude.mapM_ (takeMVar . _loopExit) backends `finally` do- debug "libevEventLoop: stopping all backends"- mapM stop backends- mapM Listen.closeSocket sockets+ ignoreException (Prelude.mapM_ (takeMVar . _loopExit) backends)+ debug "libevEventLoop: stopping all backends"+ ignoreException $ mapM stop backends+ ignoreException $ mapM Listen.closeSocket sockets ------------------------------------------------------------------------------@@ -382,11 +382,6 @@ -------------------------------------------------------------------------------ignoreException :: IO () -> IO ()-ignoreException = handle (\(_::SomeException) -> return ())--------------------------------------------------------------------------------- freeBackend :: Backend -> IO () freeBackend backend = ignoreException $ block $ do -- note: we only get here after an unloop, so we have the loop lock@@ -527,8 +522,8 @@ (\session -> block $ do debug "runSession: thread killed, closing socket" - eatException $ Listen.endSession lsock session- eatException $ freeConnection conn+ ignoreException $ Listen.endSession lsock session+ ignoreException $ freeConnection conn ) (\session -> do H.update tid conn (_connectionThreads backend) handler sinfo@@ -540,8 +535,9 @@ -------------------------------------------------------------------------------eatException :: IO a -> IO ()-eatException act = (act >> return ()) `catch` \(_::SomeException) -> return ()+ignoreException :: IO a -> IO ()+ignoreException act =+ (act >> return ()) `catch` \(_::SomeException) -> return () ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -23,18 +23,16 @@ 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 @@ ------------------------------------------------------------------------------ -- | 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,32 @@ -> 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 exit - 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+ -> MVar () -> IO ()-acceptThread defaultTimeout handler tt elog cpu sock = loop+acceptThread defaultTimeout handler tmgr elog cpu sock exitMVar =+ loop `finally` (tryPutMVar exitMVar () >> return ()) where loop = do debug $ "acceptThread: calling accept() on socket " ++ show sock@@ -117,7 +114,7 @@ _ <- forkOnIO cpu (go s addr `catches` cleanup) loop - go = runSession defaultTimeout handler tt sock+ go = runSession defaultTimeout handler tmgr sock cleanup = [@@ -129,30 +126,6 @@ -------------------------------------------------------------------------------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 +138,11 @@ ------------------------------------------------------------------------------ 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 +166,17 @@ 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@@ -261,14 +233,6 @@ run_ $ enumFilePartial fp (start,start+sz) step return () #endif----------------------------------------------------------------------------------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 ------------------------------------------------------------------------------
+ src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE BangPatterns #-}++module Snap.Internal.Http.Server.TimeoutManager+ ( TimeoutManager+ , TimeoutHandle+ , initialize+ , stop+ , register+ , tickle+ , cancel+ ) where++------------------------------------------------------------------------------+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.IORef+import Foreign.C.Types++------------------------------------------------------------------------------+data State = Deadline !CTime+ | Canceled+++------------------------------------------------------------------------------+data TimeoutHandle = TimeoutHandle {+ _killAction :: !(IO ())+ , _state :: !(IORef State)+ , _hGetTime :: !(IO CTime)+ }+++------------------------------------------------------------------------------+data TimeoutManager = TimeoutManager {+ _defaultTimeout :: !Int+ , _getTime :: !(IO CTime)+ , _connections :: !(IORef [TimeoutHandle])+ , _inactivity :: !(IORef Bool)+ , _morePlease :: !(MVar ())+ , _managerThread :: !(MVar ThreadId)+ }+++------------------------------------------------------------------------------+-- | Create a new TimeoutManager.+initialize :: Int -- ^ default timeout+ -> IO CTime -- ^ function to get current time+ -> IO TimeoutManager+initialize defaultTimeout getTime = do+ conns <- newIORef []+ inact <- newIORef False+ mp <- newEmptyMVar+ mthr <- newEmptyMVar++ let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr++ thr <- forkIO $ managerThread tm+ putMVar mthr thr+ return tm+++------------------------------------------------------------------------------+-- | Stop a TimeoutManager.+stop :: TimeoutManager -> IO ()+stop tm = readMVar (_managerThread tm) >>= killThread+++------------------------------------------------------------------------------+-- | Register a new connection with the TimeoutManager.+register :: IO () -- ^ action to run when the timeout deadline is+ -- exceeded.+ -> TimeoutManager -- ^ manager to register with.+ -> IO TimeoutHandle+register killAction tm = do+ now <- getTime+ let !state = Deadline $ now + toEnum defaultTimeout+ stateRef <- newIORef state++ let !h = TimeoutHandle killAction stateRef getTime+ atomicModifyIORef connections $ \x -> (h:x, ())++ inact <- readIORef inactivity+ when inact $ do+ -- wake up manager thread+ writeIORef inactivity False+ _ <- tryPutMVar morePlease ()+ return ()+ return h++ where+ getTime = _getTime tm+ inactivity = _inactivity tm+ morePlease = _morePlease tm+ connections = _connections tm+ defaultTimeout = _defaultTimeout tm+++------------------------------------------------------------------------------+-- | Tickle the timeout on a connection to be N seconds into the future.+tickle :: TimeoutHandle -> Int -> IO ()+tickle th n = do+ now <- getTime++ let state = Deadline $ now + toEnum n+ writeIORef stateRef state++ where+ getTime = _hGetTime th+ stateRef = _state th+++------------------------------------------------------------------------------+-- | Cancel a timeout.+cancel :: TimeoutHandle -> IO ()+cancel h = writeIORef (_state h) Canceled+++------------------------------------------------------------------------------+managerThread :: TimeoutManager -> IO ()+managerThread tm = loop `finally` (readIORef connections >>= destroyAll)+ where+ --------------------------------------------------------------------------+ connections = _connections tm+ getTime = _getTime tm+ inactivity = _inactivity tm+ morePlease = _morePlease tm+ waitABit = threadDelay 5000000++ --------------------------------------------------------------------------+ loop = do+ waitABit+ handles <- atomicModifyIORef connections (\x -> ([],x))++ if null handles+ then do+ -- we're inactive, go to sleep until we get new threads+ writeIORef inactivity True+ takeMVar morePlease+ else do+ now <- getTime+ dlist <- processHandles now handles id+ atomicModifyIORef connections (\x -> (dlist x, ()))++ loop++ --------------------------------------------------------------------------+ processHandles !now handles initDlist = go handles initDlist+ where+ go [] !dlist = return dlist++ go (x:xs) !dlist = do+ state <- readIORef $ _state x+ !dlist' <- case state of+ Canceled -> return dlist+ Deadline t -> if t <= now+ then do+ _killAction x+ return dlist+ else return (dlist . (x:))+ go xs dlist'++ --------------------------------------------------------------------------+ destroyAll = mapM_ diediedie++ --------------------------------------------------------------------------+ diediedie x = do+ state <- readIORef $ _state x+ case state of+ Canceled -> return ()+ _ -> _killAction x
− src/Snap/Internal/Http/Server/TimeoutTable.hs
@@ -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
test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs view
@@ -7,49 +7,24 @@ ( benchmarks ) where -import qualified Control.Exception as E-import "monads-fd" Control.Monad.Identity-import Criterion.Main hiding (run)-import Data.Attoparsec hiding (Result(..))-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy.Char8 as L-import Snap.Internal.Http.Parser-import Snap.Internal.Http.Parser.Data-import qualified Snap.Iteratee as SI-import Snap.Iteratee hiding (take)+import qualified Control.Exception as E+import Control.Monad.Identity+import Criterion.Main hiding (run)+import Data.Attoparsec hiding (Result(..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy.Char8 as L+import Snap.Internal.Http.Parser+import Snap.Internal.Http.Parser.Data+import qualified Snap.Iteratee as SI+import Snap.Iteratee hiding (take) -parseGet :: IO ()-parseGet = do- step <- runIteratee parseRequest- run_ $ enumBS parseGetData step+parseGet :: S.ByteString -> Identity ()+parseGet s = do+ !_ <- run_ $ enumBS s $$ parseRequest return () --- FIXME: writeChunkedTransferEncoding went away-{--parseChunked :: IO ()-parseChunked = do- sstep <- runIteratee stream2stream- c <- toChunked parseChunkedData- cstep <- runIteratee $ readChunkedTransferEncoding sstep- let i = enumBS c cstep- f <- run_ i- return ()---- utils-toChunked :: L.ByteString -> IO ByteString-toChunked lbs = do- sstep <- runIteratee stream2stream- cstep <- runIteratee $ joinI $ writeChunkedTransferEncoding sstep- run_ $ enumLBS lbs cstep--}- benchmarks = bgroup "parser"- [ bench "firefoxget" $ whnfIO parseGet--- , bench "readChunkedTransferEncoding" $ whnfIO parseChunked+ [ bench "firefoxget" $ whnf (runIdentity . parseGet) parseGetData ]---stream2stream :: (Monad m) => Iteratee ByteString m ByteString -stream2stream = liftM S.concat consume
test/snap-server-testsuite.cabal view
@@ -28,7 +28,7 @@ base >= 4 && < 5, base16-bytestring == 0.1.*, binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4,@@ -73,6 +73,7 @@ if flag(portable) || os(windows) cpp-options: -DPORTABLE + ghc-prof-options: -prof -auto-all ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind@@ -89,7 +90,7 @@ attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, base16-bytestring == 0.1.*,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4,@@ -101,10 +102,10 @@ haskell98, HUnit >= 1.2 && < 2, monads-fd >= 0.1.0.4 && <0.2,+ murmur-hash >= 0.1 && < 0.2, 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,@@ -167,7 +168,7 @@ attoparsec-enumerator >= 0.2.0.1 && < 0.3, base >= 4 && < 5, binary >= 0.5 && < 0.6,- blaze-builder >= 0.2.1.4 && <0.3,+ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4,@@ -213,11 +214,19 @@ ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind+ ghc-prof-options: -prof -auto-all Executable benchmark hs-source-dirs: benchmark common ../src main-is: Benchmark.hs++ ghc-options: -O2 -Wall -fwarn-tabs+ -funbox-strict-fields -threaded+ -fno-warn-unused-do-bind++ ghc-prof-options: -prof -auto-all+ build-depends: base >= 4 && < 5, network == 2.3.*,
− test/suite/Data/Concurrent/HashMap/Tests.hs
@@ -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"
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -71,6 +71,7 @@ , testHttp1 , testHttp2 , testHttp100+ , test411 , testExpectGarbage , testPartialParse , testMethodParsing@@ -112,6 +113,14 @@ , "\r\n" , "0123456789" ] +sampleRequest411 :: ByteString+sampleRequest411 =+ S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"+ , "Host: www.zabble.com:7777\r\n"+ , "X-Random-Other-Header: foo\r\n bar\r\n"+ , "Cookie: foo=\"bar\\\"\"\r\n"+ , "\r\n" ]+ sampleRequestExpectGarbage :: ByteString sampleRequestExpectGarbage = S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc HTTP/1.1\r\n"@@ -140,17 +149,20 @@ ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ] +dummyIter :: Iteratee ByteString IO ()+dummyIter = consume >> return () + mkRequest :: ByteString -> IO Request mkRequest s = do- step <- runIteratee $ liftM fromJust $ rsm receiveRequest+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumBS s step run_ iter testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString) testReceiveRequest = do- r <- liftM fromJust $ rsm receiveRequest+ r <- liftM fromJust $ rsm $ receiveRequest dummyIter se <- liftIO $ readIORef (rqBody r) let (SomeEnumerator e) = se it <- liftM e $ lift $ runIteratee copyingStream2Stream@@ -230,7 +242,7 @@ testOneMethod :: Method -> IO () testOneMethod m = do- step <- runIteratee $ liftM fromJust $ rsm receiveRequest+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumLBS txt step req <- run_ iter @@ -253,7 +265,7 @@ testPartialParse :: Test testPartialParse = testCase "server/short" $ do- step <- runIteratee $ liftM fromJust $ rsm receiveRequest+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter let iter = enumBS sampleShortRequest step expectException $ run_ iter@@ -261,7 +273,7 @@ methodTestText :: Method -> L.ByteString methodTestText m = L.concat [ (L.pack $ map c2w $ show m)- , " / HTTP/1.1\r\n\r\n" ]+ , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ] sampleRequest2 :: ByteString@@ -725,6 +737,41 @@ LC.putStrLn s assertBool "100 Continue" ok+++test411 :: Test+test411 = testCase "server/expect411" $ do+ let enumBody = enumBS sampleRequest411++ ref <- newIORef ""++ let (iter,onSendFile) = mkIter ref++ runHTTP 60+ Nothing+ Nothing+ echoServer2+ "localhost"+ (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)+ enumBody+ iter+ onSendFile+ (const $ return ())++ s <- readIORef ref++ let lns = LC.lines s++ let ok = case lns of+ ("HTTP/1.1 411 Length Required\r":_) -> True+ _ -> False++ when (not ok) $ do+ putStrLn "expect411 fail! got:"+ LC.putStrLn s++ assertBool "411 Length Required" ok+ testExpectGarbage :: Test
+ test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs view
@@ -0,0 +1,76 @@+module Snap.Internal.Http.Server.TimeoutManager.Tests+ ( tests ) where++import Control.Concurrent+import Data.IORef+import Data.Maybe+import System.PosixCompat.Time+import System.Timeout+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test, path)++import qualified Snap.Internal.Http.Server.TimeoutManager as TM++tests :: [Test]+tests = [ testOneTimeout+ , testOneTimeoutAfterInactivity+ , testCancel+ , testTickle ]+++testOneTimeout :: Test+testOneTimeout = testCase "timeout/oneTimeout" $ do+ mgr <- TM.initialize 3 epochTime+ oneTimeout mgr+++testOneTimeoutAfterInactivity :: Test+testOneTimeoutAfterInactivity =+ testCase "timeout/oneTimeoutAfterInactivity" $ do+ mgr <- TM.initialize 3 epochTime+ threadDelay $ 7 * seconds+ oneTimeout mgr++oneTimeout :: TM.TimeoutManager -> IO ()+oneTimeout mgr = do+ mv <- newEmptyMVar+ _ <- TM.register (putMVar mv ()) mgr+ m <- timeout (6*seconds) $ takeMVar mv+ assertBool "timeout fired" $ isJust m+ TM.stop mgr+++testTickle :: Test+testTickle = testCase "timeout/tickle" $ do+ mgr <- TM.initialize 8 epochTime+ ref <- newIORef (0 :: Int)+ h <- TM.register (writeIORef ref 1) mgr+ threadDelay $ 5 * seconds+ b0 <- readIORef ref+ assertEqual "b0" 0 b0+ TM.tickle h 8+ threadDelay $ 5 * seconds+ b1 <- readIORef ref+ assertEqual "b1" 0 b1+ threadDelay $ 8 * seconds+ b2 <- readIORef ref+ assertEqual "b2" 1 b2+ TM.stop mgr+++testCancel :: Test+testCancel = testCase "timeout/cancel" $ do+ mgr <- TM.initialize 3 epochTime+ ref <- newIORef (0 :: Int)+ h <- TM.register (writeIORef ref 1) mgr+ threadDelay $ 1 * seconds+ TM.cancel h+ threadDelay $ 5 * seconds+ b0 <- readIORef ref+ assertEqual "b0" 0 b0+ TM.stop mgr+++seconds :: Int+seconds = (10::Int) ^ (6::Int)
test/suite/Test/Blackbox.hs view
@@ -59,6 +59,13 @@ ------------------------------------------------------------------------------+slowTestOptions ssl =+ if ssl+ then mempty { topt_maximum_generated_tests = Just 75 }+ else mempty { topt_maximum_generated_tests = Just 300 }+++------------------------------------------------------------------------------ ssltests :: String -> Maybe Int -> [Test] ssltests name = maybe [] httpsTests where httpsTests port = map (\f -> f True port sslname) testFunctions@@ -89,7 +96,7 @@ (httpServe cfg' testHandler) `catch` \(_::SomeException) -> return () putMVar mvar ()- waitabit+ threadDelay $ 4*seconds return (tid,mvar) @@ -139,8 +146,11 @@ ------------------------------------------------------------------------------ testEcho :: Bool -> Int -> String -> Test-testEcho ssl port name = testProperty (name ++ "/blackbox/echo") $- monadicIO $ forAllM arbitrary prop+testEcho ssl port name =+ plusTestOptions (slowTestOptions ssl) $+ testProperty (name ++ "/blackbox/echo") $+ QC.mapSize (if ssl then min 100 else min 300) $+ monadicIO $ forAllM arbitrary prop where prop txt = do let uri = (if ssl then "https" else "http")@@ -159,16 +169,12 @@ ------------------------------------------------------------------------------ testFileUpload :: Bool -> Int -> String -> Test testFileUpload ssl port name = - plusTestOptions testOptions $+ plusTestOptions (slowTestOptions ssl) $ testProperty (name ++ "/blackbox/upload") $- QC.mapSize (if ssl then min 100 else id) $+ QC.mapSize (if ssl then min 100 else min 300) $ monadicIO $ forAllM arbitrary prop where- testOptions = if ssl- then mempty { topt_maximum_generated_tests = Just 100 }- else mempty- boundary = "boundary-jdsklfjdsalkfjadlskfjldskjfldskjfdsfjdsklfldksajfl" prefix = [ "--"@@ -238,8 +244,10 @@ ------------------------------------------------------------------------------ testRot13 :: Bool -> Int -> String -> Test-testRot13 ssl port name = testProperty (name ++ "/blackbox/rot13") $- monadicIO $ forAllM arbitrary prop+testRot13 ssl port name =+ plusTestOptions (slowTestOptions ssl) $+ testProperty (name ++ "/blackbox/rot13") $+ monadicIO $ forAllM arbitrary prop where prop txt = do let uri = (if ssl then "https" else "http")
test/suite/TestSuite.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -6,41 +7,54 @@ import Control.Concurrent (killThread) import Control.Concurrent.MVar import Control.Monad+import Prelude hiding (catch) import qualified Network.HTTP.Enumerator as HTTP import Test.Framework (defaultMain, testGroup)+import System.Environment 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]-ports = [8195..]+ports :: Int -> [Int]+ports sp = [sp..] #ifdef GNUTLS-sslports :: [Maybe Int]-sslports = map Just [8295..]+sslports :: Int -> [Maybe Int]+sslports sp = map Just [(sp + 100)..] #else-sslports :: [Maybe Int]-sslports = repeat Nothing+sslports :: Int -> [Maybe Int]+sslports _ = repeat Nothing #endif #ifdef LIBEV-backends :: [(Int,Maybe Int,ConfigBackend)]-backends = zip3 ports sslports [ConfigSimpleBackend, ConfigLibEvBackend]+backends :: Int -> [(Int,Maybe Int,ConfigBackend)]+backends sp = zip3 (ports sp)+ (sslports sp)+ [ConfigSimpleBackend, ConfigLibEvBackend] #else-backends :: [(Int,Maybe Int,ConfigBackend)]-backends = zip3 ports sslports [ConfigSimpleBackend]+backends :: Int -> [(Int,Maybe Int,ConfigBackend)]+backends sp = zip3 (ports sp)+ (sslports sp)+ [ConfigSimpleBackend] #endif +getStartPort :: IO Int+getStartPort = (liftM read (getEnv "STARTPORT") >>= evaluate)+ `catch` \(_::SomeException) -> return 8111++ main :: IO () main = HTTP.withHttpEnumerator $ do- tinfos <- forM backends $ \(port,sslport,b) ->+ sp <- getStartPort+ let bends = backends sp+ tinfos <- forM bends $ \(port,sslport,b) -> Test.Blackbox.startTestServer port sslport b - defaultMain (tests ++ concatMap blackbox backends) `finally` do+ defaultMain (tests ++ concatMap blackbox bends) `finally` do mapM_ killThread $ map fst tinfos mapM_ takeMVar $ map snd tinfos @@ -51,6 +65,8 @@ 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)