snap-server 0.9.4.1 → 0.9.4.2
raw patch · 6 files changed
+238/−68 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- snap-server.cabal +9/−2
- src/Control/Concurrent/Extended.hs +138/−0
- src/Snap/Internal/Http/Server/SimpleBackend.hs +55/−37
- src/Snap/Internal/Http/Server/TimeoutManager.hs +8/−4
- src/System/FastLogger.hs +26/−25
- test/snap-server-testsuite.cabal +2/−0
snap-server.cabal view
@@ -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
+ src/Control/Concurrent/Extended.hs view
@@ -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+
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -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
src/Snap/Internal/Http/Server/TimeoutManager.hs view
@@ -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
src/System/FastLogger.hs view
@@ -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 ------------------------------------------------------------------------------
test/snap-server-testsuite.cabal view
@@ -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