diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.9.4.1 +version: 0.9.4.2 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -61,6 +61,10 @@ Description: Enable https support using the HsOpenSSL library. Default: False +Flag debug + Description: Enable support for debugging. + Default: False + Manual: True Library hs-source-dirs: src @@ -82,7 +86,8 @@ Snap.Internal.Http.Server.HttpPort, Snap.Internal.Http.Server.SimpleBackend, Snap.Internal.Http.Server.TimeoutManager, - Snap.Internal.Http.Server.TLS + Snap.Internal.Http.Server.TLS, + Control.Concurrent.Extended build-depends: attoparsec >= 0.10 && < 0.12, @@ -151,6 +156,8 @@ else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + if flag(debug) + cpp-options: -DLABEL_THREADS source-repository head type: git diff --git a/src/Control/Concurrent/Extended.hs b/src/Control/Concurrent/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Extended.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | Handy functions that should really be merged into +-- Control.Concurrent itself. +module Control.Concurrent.Extended + ( forkIOLabeledBs + , forkIOLabeledWithUnmaskBs + , forkOnLabeledBs + , forkOnLabeledWithUnmaskBs + ) where + +------------------------------------------------------------------------------ +import Control.Concurrent (forkIO, forkOn, forkIOWithUnmask, forkOnWithUnmask) +import Control.Exception (mask, mask_) +import qualified Data.ByteString as B +import GHC.Conc.Sync (ThreadId (..)) + +#ifdef LABEL_THREADS +import qualified Data.ByteString.Unsafe as BU +import GHC.Base (labelThread#) +import Foreign.C.String (CString) +import GHC.IO (IO (..)) +import GHC.Ptr (Ptr (..)) +#endif +------------------------------------------------------------------------------ +-- | Sparks off a new thread using 'forkIO' to run the given IO +-- computation, but first labels the thread with the given label +-- (using 'labelThreadBs'). +-- +-- The implementation makes sure that asynchronous exceptions are +-- masked until the given computation is executed. This ensures the +-- thread will always be labeled which guarantees you can always +-- easily find it in the GHC event log. +-- +-- Note that the given computation is executed in the masked state of +-- the calling thread. +-- +-- Returns the 'ThreadId' of the newly created thread. +forkIOLabeledBs :: B.ByteString -- ^ Latin-1 encoded label + -> IO () + -> IO ThreadId +forkIOLabeledBs label m = + mask $ \restore -> forkIO $ do + labelMe label + restore m + + +------------------------------------------------------------------------------ +-- | Like 'forkIOLabeledBs', but lets you specify on which capability +-- (think CPU) the thread should run. +forkOnLabeledBs :: B.ByteString -- ^ Latin-1 encoded label + -> Int -- ^ Capability + -> IO () + -> IO ThreadId +forkOnLabeledBs label cap m = + mask $ \restore -> forkOn cap $ do + labelMe label + restore m + + +------------------------------------------------------------------------------ +-- | Sparks off a new thread using 'forkIOWithUnmask' to run the given +-- IO computation, but first labels the thread with the given label +-- (using 'labelThreadBs'). +-- +-- The implementation makes sure that asynchronous exceptions are +-- masked until the given computation is executed. This ensures the +-- thread will always be labeled which guarantees you can always +-- easily find it in the GHC event log. +-- +-- Like 'forkIOWithUnmask', the given computation is given a function +-- to unmask asynchronous exceptions. See the documentation of that +-- function for the motivation. +-- +-- Returns the 'ThreadId' of the newly created thread. +forkIOLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label + -> ((forall a. IO a -> IO a) -> IO ()) + -> IO ThreadId +forkIOLabeledWithUnmaskBs label m = + mask_ $ forkIOWithUnmask $ \unmask -> do + labelMe label + m unmask + + +------------------------------------------------------------------------------ +-- | Like 'forkIOLabeledWithUnmaskBs', but lets you specify on which +-- capability (think CPU) the thread should run. +forkOnLabeledWithUnmaskBs :: B.ByteString -- ^ Latin-1 encoded label + -> Int -- ^ Capability + -> ((forall a. IO a -> IO a) -> IO ()) + -> IO ThreadId +forkOnLabeledWithUnmaskBs label cap m = + mask_ $ forkOnWithUnmask cap $ \unmask -> do + labelMe label + m unmask + + +------------------------------------------------------------------------------ +-- | Label the current thread. +{-# INLINE labelMe #-} +labelMe :: B.ByteString -> IO () +#if defined(LABEL_THREADS) +labelMe label = do + tid <- myThreadId + labelThreadBs tid label + + +------------------------------------------------------------------------------ +-- | Like 'labelThread' but uses a Latin-1 encoded 'ByteString' +-- instead of a 'String'. +-- +-- Note that if you terminate the ByteString with a '\0' this function +-- will use a more efficient implementation which avoids copying the +-- ByteString. +labelThreadBs :: ThreadId -> B.ByteString -> IO () +labelThreadBs tid bs + | n == 0 = return () + | B.index bs (n - 1) == 0 = BU.unsafeUseAsCString bs $ labelThreadCString tid + | otherwise = B.useAsCString bs $ labelThreadCString tid + where + n = B.length bs + + +------------------------------------------------------------------------------ +-- | Like 'labelThread' but uses a 'CString' instead of a 'String' +labelThreadCString :: ThreadId -> CString -> IO () +labelThreadCString (ThreadId t) (Ptr p) = + IO $ \s -> case labelThread# t p s of + s1 -> (# s1, () #) +#elif defined(TESTSUITE) +labelMe !_ = return $! () +#else +labelMe _label = return $! () +#endif + 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} @@ -15,38 +14,40 @@ ------------------------------------------------------------------------------ import Control.Monad.Trans -import Control.Concurrent hiding (yield) +import Control.Concurrent hiding (yield) +import Control.Concurrent.Extended (forkOnLabeledWithUnmaskBs) import Control.Exception import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import Data.ByteString.Internal (c2w) -import Data.Maybe -import Foreign hiding (new) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as SC +import Data.ByteString.Internal (c2w) +import Foreign hiding (new) import Foreign.C #if MIN_VERSION_base(4,4,0) -import GHC.Conc (labelThread, forkOn) +import GHC.Conc (forkOn, labelThread) #else -import GHC.Conc (labelThread, forkOnIO) +import GHC.Conc (forkOnIO, + labelThread) #endif import Network.Socket #if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) +import Prelude hiding (catch) #endif ------------------------------------------------------------------------------ import Snap.Internal.Debug +import Snap.Internal.Http.Server.Address +import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.Date -import qualified Snap.Internal.Http.Server.TimeoutManager as TM +import qualified Snap.Internal.Http.Server.ListenHelpers as Listen import Snap.Internal.Http.Server.TimeoutManager (TimeoutManager) -import Snap.Internal.Http.Server.Backend -import Snap.Internal.Http.Server.Address -import qualified Snap.Internal.Http.Server.ListenHelpers as Listen -import Snap.Iteratee hiding (map) +import qualified Snap.Internal.Http.Server.TimeoutManager as TM +import Snap.Iteratee hiding (map) #if defined(HAS_SENDFILE) -import qualified System.SendFile as SF import System.Posix.IO -import System.Posix.Types (Fd(..)) +import System.Posix.Types (Fd (..)) +import qualified System.SendFile as SF #endif @@ -63,10 +64,10 @@ -- * A TimeoutManager -- * An mvar to signal when the timeout thread is shutdown data EventLoopCpu = EventLoopCpu - { _boundCpu :: Int - , _acceptThreads :: [ThreadId] - , _timeoutManager :: TimeoutManager - , _exitMVar :: !(MVar ()) + { _boundCpu :: Int + , _acceptThreads :: [ThreadId] + , _timeoutManager :: TimeoutManager + , _exitMVar :: !(MVar ()) } @@ -96,14 +97,20 @@ newLoop defaultTimeout sockets handler elog cpu = do tmgr <- TM.initialize defaultTimeout getCurrentDateTime exit <- newEmptyMVar - accThreads <- forM sockets $ \p -> forkOn cpu $ - acceptThread defaultTimeout handler tmgr elog cpu p exit + accThreads <- forM sockets $ \p -> do + let label = S.concat + [ "snap-server: ", SC.pack (show p) + , " on capability: ", SC.pack (show cpu) + ] + forkOnLabeledWithUnmaskBs label cpu $ \unmask -> + acceptThread defaultTimeout handler tmgr elog cpu p unmask + `finally` (tryPutMVar exit () >> return ()) return $! EventLoopCpu cpu accThreads tmgr exit ------------------------------------------------------------------------------ stopLoop :: EventLoopCpu -> IO () -stopLoop loop = mask $ \_ -> do +stopLoop loop = mask_ $ do TM.stop $ _timeoutManager loop Prelude.mapM_ killThread $ _acceptThreads loop @@ -115,25 +122,31 @@ -> (S.ByteString -> IO ()) -> Int -> ListenSocket - -> MVar () + -> (forall a. IO a -> IO a) -> IO () -acceptThread defaultTimeout handler tmgr elog cpu sock exitMVar = - loop `finally` (tryPutMVar exitMVar () >> return ()) +acceptThread defaultTimeout handler tmgr elog cpu sock unmask = loop where + loop = do + unmask (forever acceptAndFork) `catches` acceptHandler + loop + acceptAndFork = do debug $ "acceptThread: calling accept() on socket " ++ show sock (s,addr) <- accept $ Listen.listenSocket sock setSocketOption s NoDelay 1 debug $ "acceptThread: accepted connection from remote: " ++ show addr - _ <- forkOn cpu (go s addr `catches` cleanup) + let label = S.concat + [ "snap-server: connection from: " + , SC.pack (show addr) + , " on socket: " + , SC.pack (show (fdSocket s)) + , "\0" + ] + _ <- forkOnLabeledWithUnmaskBs label cpu $ \unmask' -> + unmask' (runSession defaultTimeout handler tmgr sock s addr) + `catches` cleanup return () - loop = do - acceptAndFork `catches` acceptHandler - loop - - go = runSession defaultTimeout handler tmgr sock - acceptHandler = [ Handler $ \(e :: AsyncException) -> throwIO e , Handler $ \(e :: SomeException) -> do @@ -147,7 +160,13 @@ cleanup = [ - Handler $ \(_ :: AsyncException) -> return () + Handler $ \(e :: AsyncException) -> + case e of + ThreadKilled -> return () + UserInterrupt -> return () + _ -> throwIO e -- This ensures all other asynchronous exceptions + -- (StackOverflow and HeapOverflow) are logged to + -- stderr by forkIO. , Handler $ \(e :: SomeException) -> elog $ S.concat [ "SimpleBackend.acceptThread: " , S.pack . map c2w $ show e] @@ -166,7 +185,6 @@ curId <- myThreadId debug $ "Backend.withConnection: running session: " ++ show addr - labelThread curId $ "connHndl " ++ show fd (rport,rhost) <- getAddress addr (lport,lhost) <- getSocketName sock >>= getAddress @@ -179,7 +197,7 @@ bracket (Listen.createSession lsock 8192 fd (threadWaitRead $ fromIntegral fd)) - (\session -> mask $ \_ -> do + (\session -> mask_ $ do debug "thread killed, closing socket" -- cancel thread timeout diff --git a/src/Snap/Internal/Http/Server/TimeoutManager.hs b/src/Snap/Internal/Http/Server/TimeoutManager.hs --- a/src/Snap/Internal/Http/Server/TimeoutManager.hs +++ b/src/Snap/Internal/Http/Server/TimeoutManager.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} module Snap.Internal.Http.Server.TimeoutManager ( TimeoutManager @@ -14,6 +16,7 @@ ------------------------------------------------------------------------------ import Control.Concurrent +import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception import Control.Monad import Data.IORef @@ -116,7 +119,8 @@ let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr - thr <- forkIO $ managerThread tm + thr <- forkIOLabeledWithUnmaskBs "snap-server: timeout manager" $ + managerThread tm putMVar mthr thr return tm @@ -196,8 +200,8 @@ ------------------------------------------------------------------------------ -managerThread :: TimeoutManager -> IO () -managerThread tm = loop `finally` (readIORef connections >>= destroyAll) +managerThread :: TimeoutManager -> (forall a. IO a -> IO a) -> IO () +managerThread tm unmask = unmask loop `finally` (readIORef connections >>= destroyAll) where -------------------------------------------------------------------------- connections = _connections tm diff --git a/src/System/FastLogger.hs b/src/System/FastLogger.hs --- a/src/System/FastLogger.hs +++ b/src/System/FastLogger.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger @@ -18,18 +19,20 @@ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 import Control.Concurrent +import Control.Concurrent.Extended (forkIOLabeledWithUnmaskBs) import Control.Exception -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L -import Data.ByteString.Internal (c2w) +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.Lazy.Char8 as L import Data.Int import Data.IORef import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T #if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) +import Prelude hiding (catch) #endif import System.IO @@ -74,8 +77,10 @@ let lg = Logger q dw fp th errAction - tid <- forkIO $ loggingThread lg - putMVar th tid + mask_ $ do + tid <- forkIOLabeledWithUnmaskBs "snap-server: logging" $ + loggingThread lg + putMVar th tid return lg @@ -155,8 +160,8 @@ ------------------------------------------------------------------------------ -loggingThread :: Logger -> IO () -loggingThread (Logger queue notifier filePath _ errAct) = do +loggingThread :: Logger -> (forall a. IO a -> IO a) -> IO () +loggingThread (Logger queue notifier filePath _ errAct) unmask = do initialize >>= go where @@ -167,7 +172,7 @@ if filePath == "stderr" then return stderr else openFile filePath AppendMode `catch` - \(e::SomeException) -> do + \(e::IOException) -> do logInternalError $ "Can't open log file \"" ++ filePath ++ "\".\n" logInternalError $ "Exception: " ++ show e ++ "\n" @@ -176,14 +181,13 @@ "FIX THIS**\n\n" return stderr - closeIt h = if h == stdout || h == stderr - then return () - else hClose h + closeIt h = unless (h == stdout || h == stderr) $ + hClose h logInternalError = errAct . T.encodeUtf8 . T.pack go (href, lastOpened) = - (loop (href, lastOpened)) + (unmask $ forever $ waitFlushDelay (href, lastOpened)) `catches` [ Handler $ \(_::AsyncException) -> killit (href, lastOpened) , Handler $ \(e::SomeException) -> do @@ -213,7 +217,7 @@ let !msgs = toLazyByteString dl h <- readIORef href (do L.hPut h msgs - hFlush h) `catch` \(e::SomeException) -> do + hFlush h) `catch` \(e::IOException) -> do logInternalError $ "got exception writing to log " ++ filePath ++ ": " ++ show e ++ "\n" logInternalError $ "writing log entries to stderr.\n" @@ -223,15 +227,13 @@ t <- getCurrentDateTime old <- readIORef lastOpened - if t-old > 900 - then do - closeIt h - openIt >>= writeIORef href - writeIORef lastOpened t - else return () + when (t-old > 900) $ do + closeIt h + mask_ $ openIt >>= writeIORef href + writeIORef lastOpened t - loop !d = do + waitFlushDelay !d = do -- wait on the notification mvar _ <- takeMVar notifier @@ -240,7 +242,6 @@ -- at least five seconds between log dumps threadDelay 5000000 - loop d ------------------------------------------------------------------------------ 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,6 +28,7 @@ bytestring, conduit >= 0.5 && <0.6, containers, + cryptocipher >= 0.3.7 && <0.4, directory, directory-tree, enumerator >= 0.4.15 && <0.5, @@ -74,6 +75,7 @@ if flag(portable) || os(windows) cpp-options: -DPORTABLE + cpp-options: -DTESTSUITE ghc-prof-options: -prof -auto-all ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded