This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 67dfe16a125db2df4ad1edaa02132b113c5a6fa1 (commit)
from 78ac4fbfe0611f31fc6524b535fc4848f9218386 (commit)
Summary of changes:
snap-server.cabal | 7 ++-
src/Snap/Internal/Http/Server/Date.hs | 42 +++++++-----
src/Snap/Internal/Http/Server/SimpleBackend.hs | 90 +++++++++++++++++++++---
src/System/FastLogger.hs | 3 +-
test/snap-server-testsuite.cabal | 20 ++++--
test/suite/Snap/Internal/Http/Parser/Tests.hs | 8 ++-
6 files changed, 132 insertions(+), 38 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 67dfe16a125db2df4ad1edaa02132b113c5a6fa1
Author: Gregory Collins <[email protected]>
Date: Thu May 27 21:53:24 2010 -0400
Add timeout table to simplebackend
diff --git a/snap-server.cabal b/snap-server.cabal
index 4e5d1aa..a7f9d7b 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -111,12 +111,17 @@ Library
unix-compat,
vector >= 0.6 && <0.7
+ if !os(windows)
+ build-depends: unix
+
if flag(libev)
build-depends: hlibev >= 0.2.3
other-modules: Snap.Internal.Http.Server.LibevBackend
cpp-options: -DLIBEV
else
- build-depends: network-bytestring >= 0.1.2 && < 0.2
+ build-depends: network-bytestring >= 0.1.2 && < 0.2,
+ PSQueue >= 1.1 && <1.2
+
other-modules: Snap.Internal.Http.Server.SimpleBackend
if os(linux)
diff --git a/src/Snap/Internal/Http/Server/Date.hs
b/src/Snap/Internal/Http/Server/Date.hs
index 548ead1..17a2abe 100644
--- a/src/Snap/Internal/Http/Server/Date.hs
+++ b/src/Snap/Internal/Http/Server/Date.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
module Snap.Internal.Http.Server.Date
( getDateString
@@ -9,15 +10,17 @@ import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import Data.ByteString.Internal (c2w)
-import qualified Data.ByteString as B
import Data.IORef
-import Data.Time.Clock
-import Data.Time.LocalTime
-import Data.Time.Format
+import Foreign.C.Types
import System.IO.Unsafe
-import System.Locale
+#ifndef WIN32
+import System.Posix.Time
+#else
+import Data.Time.Clock.POSIX
+#endif
+
+import Snap.Internal.Http.Types (formatHttpTime, formatLogTime)
-- Here comes a dirty hack. We don't want to be wasting context switches
-- building date strings, so we're only going to compute one every two
@@ -31,7 +34,7 @@ import System.Locale
data DateState = DateState {
_cachedDateString :: !(IORef ByteString)
, _cachedLogString :: !(IORef ByteString)
- , _cachedDate :: !(IORef UTCTime)
+ , _cachedDate :: !(IORef CTime)
, _valueIsOld :: !(IORef Bool)
, _morePlease :: !(MVar ())
, _dataAvailable :: !(MVar ())
@@ -57,16 +60,21 @@ dateState = unsafePerformIO $ do
return d
-fetchTime :: IO (ByteString,ByteString,UTCTime)
+#ifdef WIN32
+epochTime :: IO CTime
+epochTime = do
+ t <- getPOSIXTime
+ return $ realToFrac t
+#endif
+
+
+fetchTime :: IO (ByteString,ByteString,CTime)
fetchTime = do
- now <- getCurrentTime
- zt <- liftM zonedTimeToLocalTime getZonedTime
- return (t1 now, t2 zt, now)
- where
- t1 now = B.pack $ map c2w $
- formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" now
- t2 now = B.pack $ map c2w $
- formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" now
+ now <- epochTime
+ t1 <- formatHttpTime now
+ t2 <- formatLogTime now
+ return (t1, t2, now)
+
dateThread :: DateState -> IO ()
dateThread ds@(DateState dateString logString time valueIsOld morePlease
@@ -108,7 +116,7 @@ getLogDateString = block $ do
readIORef $ _cachedLogString dateState
-getCurrentDateTime :: IO UTCTime
+getCurrentDateTime :: IO CTime
getCurrentDateTime = block $ do
ensureFreshDate
readIORef $ _cachedDate dateState
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index 1e3fae3..d13b26f 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -33,8 +34,11 @@ import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString as B
import Data.Iteratee.WrappedByteString
+import qualified Data.PSQueue as PSQ
+import Data.PSQueue (PSQ)
import Data.Typeable
import Foreign hiding (new)
+import Foreign.C.Types (CTime)
import GHC.Conc (labelThread, forkOnIO)
import Network.Socket
import qualified Network.Socket.ByteString as SB
@@ -42,6 +46,7 @@ import qualified Network.Socket.SendFile as SF
import Prelude hiding (catch)
------------------------------------------------------------------------------
import Snap.Internal.Debug
+import Snap.Internal.Http.Server.Date
import Snap.Iteratee
@@ -54,14 +59,18 @@ instance Show BackendTerminatedException where
instance Exception BackendTerminatedException
data Backend = Backend
- { _acceptSocket :: Socket }
+ { _acceptSocket :: Socket
+ , _timeoutTable :: MVar (PSQ ThreadId CTime)
+ , _timeoutThread :: MVar ThreadId }
data Connection = Connection
- { _socket :: Socket
+ { _backend :: Backend
+ , _socket :: Socket
, _remoteAddr :: ByteString
, _remotePort :: Int
, _localAddr :: ByteString
- , _localPort :: Int }
+ , _localPort :: Int
+ , _connTid :: MVar ThreadId }
{-# INLINE name #-}
name :: ByteString
@@ -91,13 +100,56 @@ new :: Socket -- ^ value you got from bindIt
-> IO Backend
new sock _ = do
debug $ "Backend.new: listening"
- return $ Backend sock
+
+ mv <- newMVar PSQ.empty
+ t <- newEmptyMVar
+
+ let b = Backend sock mv t
+
+ tid <- forkIO $ timeoutThread b
+ putMVar t tid
+
+ return b
+
+
+timeoutThread :: Backend -> IO ()
+timeoutThread backend = loop
+ where
+ loop = do
+ killTooOld
+ threadDelay (5000000)
+ loop
+
+
+ killTooOld = modifyMVar_ tmvar $ \table -> do
+ now <- getCurrentDateTime
+ !t' <- killOlderThan now table
+ return t'
+
+
+ -- timeout = 60 seconds
+ tIMEOUT = 60
+
+ killOlderThan now !table = do
+ let mmin = PSQ.findMin table
+ maybe (return table)
+ (\m -> if now - PSQ.prio m > tIMEOUT
+ then do
+ killThread $ PSQ.key m
+ killOlderThan now $ PSQ.deleteMin table
+ else return table)
+ mmin
+
+ tmvar = _timeoutTable backend
stop :: Backend -> IO ()
-stop (Backend s) = do
+stop (Backend s _ t) = do
debug $ "Backend.stop"
sClose s
+
+ -- kill timeout thread and current thread
+ readMVar t >>= killThread
myThreadId >>= killThread
@@ -111,8 +163,9 @@ instance Exception AddressNotSupportedException
withConnection :: Backend -> Int -> (Connection -> IO ()) -> IO ()
-withConnection (Backend asock) cpu proc = do
+withConnection backend cpu proc = do
debug $ "Backend.withConnection: calling accept()"
+ let asock = _acceptSocket backend
(sock,addr) <- accept asock
let fd = fdSocket sock
@@ -136,18 +189,27 @@ withConnection (Backend asock) cpu proc = do
return (fromIntegral p, B.pack $ map c2w h')
x -> throwIO $ AddressNotSupportedException $ show x
- let c = Connection sock host port lhost lport
+ tmvar <- newEmptyMVar
- forkOnIO cpu $ do
+ let c = Connection backend sock host port lhost lport tmvar
+
+ tid <- forkOnIO cpu $ do
labelMe $ "connHndl " ++ show fd
bracket (return c)
- (\_ -> do
+ (\_ -> block $ do
debug "sClose sock"
+ thr <- readMVar tmvar
+
+ -- remove thread from timeout table
+ modifyMVar_ (_timeoutTable backend) $
+ return . PSQ.delete thr
eatException $ shutdown sock ShutdownBoth
eatException $ sClose sock
)
proc
+ putMVar tmvar tid
+ tickleTimeout c
return ()
@@ -203,7 +265,14 @@ instance Exception TimeoutException
tickleTimeout :: Connection -> IO ()
-tickleTimeout = const $ return ()
+tickleTimeout conn = modifyMVar_ ttmvar $ \t -> do
+ now <- getCurrentDateTime
+ tid <- readMVar $ _connTid conn
+ let !t' = PSQ.insert tid now t
+ return t'
+
+ where
+ ttmvar = _timeoutTable $ _backend conn
timeoutRecv :: Connection -> Int -> IO ByteString
@@ -216,6 +285,7 @@ timeoutSend :: Connection -> ByteString -> IO ()
timeoutSend conn s = do
let sock = _socket conn
SB.sendAll sock s
+ tickleTimeout conn
bLOCKSIZE :: Int
diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs
index f65e382..4c98675 100644
--- a/src/System/FastLogger.hs
+++ b/src/System/FastLogger.hs
@@ -23,7 +23,6 @@ import qualified Data.DList as D
import Data.IORef
import Data.Maybe
import Data.Serialize.Put
-import Data.Time.Clock
import Prelude hiding (catch, show)
import qualified Prelude
import System.IO
@@ -176,7 +175,7 @@ loggingThread (Logger queue notifier filePath _) = do
t <- getCurrentDateTime
old <- readIORef lastOpened
- if diffUTCTime t old > 900
+ if t-old > 900
then do
closeIt h
openIt >>= writeIORef href
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index 19c119a..05cf076 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -15,7 +15,7 @@ Executable testsuite
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.0.2 && < 0.9,
- attoparsec-iteratee >= 0.1 && <0.2,
+ attoparsec-iteratee >= 0.1.1 && <0.2,
base >= 4 && < 5,
binary >= 0.5 && < 0.6,
bytestring,
@@ -41,13 +41,18 @@ Executable testsuite
time,
transformers,
vector >= 0.6.0.1 && < 0.7
-
+
+ if !os(windows)
+ build-depends: unix
+
if flag(libev)
build-depends: hlibev >= 0.2.1
other-modules: Snap.Internal.Http.Server.LibevBackend
cpp-options: -DLIBEV
else
- build-depends: network-bytestring >= 0.1.2 && < 0.2
+ build-depends: network-bytestring >= 0.1.2 && < 0.2,
+ PSQueue >= 1.1 && <1.2
+
other-modules: Snap.Internal.Http.Server.SimpleBackend
ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
@@ -62,7 +67,7 @@ Executable pongserver
QuickCheck >= 2,
array >= 0.3 && <0.4,
attoparsec >= 0.8.0.2 && < 0.9,
- attoparsec-iteratee >= 0.1 && <0.2,
+ attoparsec-iteratee >= 0.1.1 && <0.2,
base >= 4 && < 5,
bytestring,
bytestring-nums >= 0.3.1 && < 0.4,
@@ -87,12 +92,17 @@ Executable pongserver
unix-compat,
vector >= 0.6.0.1 && < 0.7
+ if !os(windows)
+ build-depends: unix
+
if flag(libev)
build-depends: hlibev >= 0.2.1
other-modules: Snap.Internal.Http.Server.LibevBackend
cpp-options: -DLIBEV
else
- build-depends: network-bytestring >= 0.1.2 && < 0.2
+ build-depends: network-bytestring >= 0.1.2 && < 0.2,
+ PSQueue >= 1.1 && <1.2
+
other-modules: Snap.Internal.Http.Server.SimpleBackend
if os(linux)
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index c287669..fb352e1 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -16,6 +16,7 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
import qualified Data.Map as Map
+import Data.Maybe (isNothing)
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
@@ -62,17 +63,18 @@ testP2I = testCase "parserToIteratee" $ do
assertEqual "should be foo" "foo" l
+
forceErr :: SomeException -> IO ()
forceErr e = f `seq` (return ())
where
!f = show e
+
testNull :: Test
testNull = testCase "short parse" $ do
- f <- E.try $ run (parseRequest)
+ f <- run (parseRequest)
+ assertBool "should be Nothing" $ isNothing f
- case f of (Left e) -> forceErr e
- (Right x) -> assertFailure $ "expected exception, got " ++ show x
testPartial :: Test
testPartial = testCase "partial parse" $ do
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
