diff --git a/README.SNAP.md b/README.SNAP.md
--- a/README.SNAP.md
+++ b/README.SNAP.md
@@ -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
diff --git a/snap-server.cabal b/snap-server.cabal
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -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 .
+ 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 .
.
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
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -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")
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -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
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -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
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs b/src/Snap/Internal/Http/Server/LibevBackend.hs
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -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 ()
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs b/src/Snap/Internal/Http/Server/SimpleBackend.hs
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -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
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server/TimeoutManager.hs b/src/Snap/Internal/Http/Server/TimeoutManager.hs
new file mode 100644
--- /dev/null
+++ b/src/Snap/Internal/Http/Server/TimeoutManager.hs
@@ -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
diff --git a/src/Snap/Internal/Http/Server/TimeoutTable.hs b/src/Snap/Internal/Http/Server/TimeoutTable.hs
deleted file mode 100644
--- a/src/Snap/Internal/Http/Server/TimeoutTable.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Snap.Internal.Http.Server.TimeoutTable
- ( TimeoutTable
- , new
- , null
- , insert
- , delete
- , killAll
- , killOlderThan
- , waitForActivity
- )
-where
-
-
-------------------------------------------------------------------------------
-import Control.Concurrent
-import Control.Monad
-import Data.Bits
-import qualified Data.PSQueue as PSQ
-import Data.PSQueue (PSQ)
-import qualified Data.Vector as V
-import Data.Vector (Vector)
-import Data.Word
-import Foreign.C.Types (CTime)
-import GHC.Conc (numCapabilities)
-import Prelude hiding (null)
-------------------------------------------------------------------------------
-import Data.Concurrent.HashMap (nextHighestPowerOf2)
-
-
-------------------------------------------------------------------------------
-type TT = PSQ ThreadId CTime
-
-
-------------------------------------------------------------------------------
-data TimeoutTable = TimeoutTable {
- _maps :: !(Vector (MVar TT))
- , _activity :: !(MVar ())
-}
-
-
-------------------------------------------------------------------------------
-defaultNumberOfLocks :: Word
-defaultNumberOfLocks = nextHighestPowerOf2 $ toEnum $ 8 * numCapabilities
-
-
-------------------------------------------------------------------------------
-hashToBucket :: Word -> Word
-hashToBucket x = x .&. (defaultNumberOfLocks-1)
-
-
-------------------------------------------------------------------------------
-new :: IO TimeoutTable
-new = do
- vector <- V.replicateM (fromEnum defaultNumberOfLocks) (newMVar PSQ.empty)
- act <- newEmptyMVar
- return $ TimeoutTable vector act
-
-
-------------------------------------------------------------------------------
-null :: TimeoutTable -> IO Bool
-null (TimeoutTable maps _) = do
- nulls <- V.mapM (\mv -> withMVar mv $ return . PSQ.null) maps
- return $ V.and nulls
-
-
-------------------------------------------------------------------------------
-insert :: Word -> ThreadId -> CTime -> TimeoutTable -> IO ()
-insert thash tid time (TimeoutTable maps act) = do
- modifyMVar_ psqMv $ \psq -> do
- let !psq' = PSQ.insert tid time psq
- return $! psq'
-
- _ <- tryPutMVar act ()
- return ()
-
- where
- bucket = hashToBucket thash
- psqMv = V.unsafeIndex maps $ fromEnum bucket
-
-
-------------------------------------------------------------------------------
-delete :: Word -> ThreadId -> TimeoutTable -> IO ()
-delete thash tid (TimeoutTable maps act) = do
- modifyMVar_ psqMv $ \psq -> do
- let !psq' = PSQ.delete tid psq
- return $! psq'
-
- _ <- tryPutMVar act ()
- return ()
-
- where
- bucket = hashToBucket thash
- psqMv = V.unsafeIndex maps $ fromEnum bucket
-
-
-------------------------------------------------------------------------------
-killAll :: TimeoutTable -> IO ()
-killAll (TimeoutTable maps _) = do
- V.mapM_ k maps
-
- where
- k psqMV = modifyMVar_ psqMV $ \psq -> do
- mapM_ killThread $ PSQ.keys psq
- return PSQ.empty
-
-
-------------------------------------------------------------------------------
-killOlderThan :: CTime -> TimeoutTable -> IO ()
-killOlderThan time (TimeoutTable maps _) = do
- V.mapM_ processPSQ maps
-
- where
- processPSQ psqMV = modifyMVar_ psqMV $ \psq -> do
- let (psq', threads) = findOlder psq []
- mapM_ killThread threads
- return psq'
-
- findOlder psq l =
- let mmin = PSQ.findMin psq
- in maybe (psq,l)
- (\m -> if PSQ.prio m <= time
- then findOlder (PSQ.deleteMin psq) ((PSQ.key m):l)
- else (psq,l))
- mmin
-
-
-------------------------------------------------------------------------------
-waitForActivity :: TimeoutTable -> IO ()
-waitForActivity t@(TimeoutTable _ act) = do
- takeMVar act
- b <- null t
-
- -- if the table is not empty, put the activity mvar back
- unless b $ (tryPutMVar act () >> return ())
-
- threadDelay 2500000
diff --git a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
--- a/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
+++ b/test/benchmark/Snap/Internal/Http/Parser/Benchmark.hs
@@ -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
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -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.*,
diff --git a/test/suite/Data/Concurrent/HashMap/Tests.hs b/test/suite/Data/Concurrent/HashMap/Tests.hs
deleted file mode 100644
--- a/test/suite/Data/Concurrent/HashMap/Tests.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PackageImports #-}
-
-module Data.Concurrent.HashMap.Tests
- ( tests ) where
-
-import Data.ByteString.Char8 (ByteString)
-import Data.List
-import Data.Word
-import Test.Framework
-import Test.Framework.Providers.QuickCheck2
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
-
-import qualified Data.Concurrent.HashMap as H
-import Snap.Test.Common ()
-
-tests :: [Test]
-tests = [ testFromTo
- , testLookup
- , testDeletes
- , testUpdate
- ]
-
-
--- make sure we generate two strings which hash to the same bucket.
-bogoHash :: ByteString -> Word
-bogoHash "qqq" = 12345
-bogoHash "zzz" = 12345
-bogoHash x = H.hashBS x
-
-
-testFromTo :: Test
-testFromTo = testProperty "HashMap/fromList/toList" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(Int,Int)] -> PropertyM IO ()
- prop l = do
- ht <- run $ H.fromList H.hashInt l
- l' <- run $ H.toList ht
-
- let s1 = sort l
- let s2 = sort l'
-
- assert $ s1 == s2
-
-
-testDeletes :: Test
-testDeletes = testProperty "HashMap/deletes" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let l = [("qqq","QQQ"),("zzz","ZZZ")] ++ l'
- let h = head l'
-
- ht <- run $ H.fromList bogoHash l
- v1 <- run $ H.lookup "qqq" ht
- v2 <- run $ H.lookup "zzz" ht
-
- run $ H.delete "qqq" ht
- v3 <- run $ H.lookup "qqq" ht
- v4 <- run $ H.lookup "zzz" ht
-
- run $ H.delete (fst h) ht
- run $ H.delete (fst h) ht
-
- v5 <- run $ H.lookup (fst h) ht
-
- assert $ v1 == Just "QQQ"
- assert $ v2 == Just "ZZZ"
- assert $ v3 == Nothing
- assert $ v4 == Just "ZZZ"
- assert $ v5 == Nothing
-
-
-testLookup :: Test
-testLookup = testProperty "HashMap/lookup" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let h = head l'
- let l = filter ((/= (fst h)) . fst) $ tail l'
-
- ht <- run $ H.fromList H.hashBS (h:l)
-
- v1 <- run $ H.lookup (fst h) ht
- run $ H.delete (fst h) ht
- v2 <- run $ H.lookup (fst h) ht
-
- assert $ v1 == (Just $ snd h)
- assert $ v2 == Nothing
-
-
-testUpdate :: Test
-testUpdate = testProperty "HashMap/update" $
- monadicIO $ forAllM arbitrary prop
- where
- prop :: [(ByteString,ByteString)] -> PropertyM IO ()
- prop l' = do
- pre (not $ null l')
- let h = head l'
- let l = filter ((/= (fst h)) . fst) $ tail l'
-
- ht <- run $ H.fromList H.hashBS (h:l)
- e1 <- run $ H.update (fst h) "qqq" ht
- v1 <- run $ H.lookup (fst h) ht
- run $ H.delete (fst h) ht
- v2 <- run $ H.lookup (fst h) ht
- e2 <- run $ H.update (fst h) "zzz" ht
- v3 <- run $ H.lookup (fst h) ht
-
- assert e1
- assert $ v1 == Just "qqq"
- assert $ v2 == Nothing
- assert $ not e2
- assert $ v3 == Just "zzz"
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -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
diff --git a/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs b/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Snap/Internal/Http/Server/TimeoutManager/Tests.hs
@@ -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)
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -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")
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -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)