From 685411e25a1d29ff43810799d6522cbffcdb554e Mon Sep 17 00:00:00 2001 From: Bas van Dijk Date: Tue, 23 Mar 2010 11:58:42 +0100 Subject: [PATCH 1/2] Fixed major space-leak in Network.Salvia.Impl.Server Previously when a request handler was forked an association from its threadId to an status MVar was inserted in the threadmanager Map. Unfortunately this association was not deleted from the Map when the request handler terminated. This resulted in a major O(n) space-leak where n = the number of requests made. This patch fixes it by replacing threadmanager by Control.Concurrent.Thread from concurrent-extra and manually deleting the threadIds when the request handler terminates. --- salvia.cabal | 4 +- src/Network/Salvia/Impl/Server.hs | 109 +++++++++++++++++++++++++------------ 2 files changed, 76 insertions(+), 37 deletions(-) diff --git a/salvia.cabal b/salvia.cabal index f7341b4..e990817 100644 --- a/salvia.cabal +++ b/salvia.cabal @@ -1,6 +1,6 @@ Name: salvia Version: 1.0.0 -Description: +Description: Salvia is a feature rich modular web server and web application framework that can be used to write dynamic websites in Haskell. From the lower level protocol code up to the high level application code, everything is written as @@ -49,7 +49,7 @@ Library network >= 2.2.1.7 && < 2.3, old-locale ==1.0.*, process ==1.0.*, - threadmanager ==0.1.3, + concurrent-extra == 0.4.*, pureMD5 ==1.0.*, random ==1.0.*, safe ==0.2.*, diff --git a/src/Network/Salvia/Impl/Server.hs b/src/Network/Salvia/Impl/Server.hs index 4bd24ac..cabc9fb 100644 --- a/src/Network/Salvia/Impl/Server.hs +++ b/src/Network/Salvia/Impl/Server.hs @@ -1,10 +1,14 @@ module Network.Salvia.Impl.Server (start) where -import Control.Concurrent.ThreadManager +import Control.Concurrent (myThreadId) +import Control.Concurrent.Thread (ThreadId, forkIO, wait_, threadId) +import Control.Concurrent.MVar (newMVar, modifyMVar_, readMVar) +import Control.Exception (finally) import Control.Monad.State +import Data.Functor ((<$)) import Network.Protocol.Http hiding (accept, hostname) import Network.Salvia.Impl.Config -import Network.Salvia.Impl.Context +import Network.Salvia.Impl.Context import Network.Salvia.Impl.Handler import Network.Socket import System.IO @@ -25,37 +29,72 @@ handler. -} start :: Config -> Handler p () -> p -> IO () -start conf handler payload = - do tm <- make - forM_ (listenOn conf) $ \(SockAddrInet port addr) -> - fork tm $ - do inet_ntoa addr >>= \a -> - putStrLn ("starting listening server on: " ++ a ++ ":" ++ show port) - s <- socket AF_INET Stream 0 - setSocketOption s ReuseAddr 1 - let sAddr = SockAddrInet port addr - bindSocket s sAddr - listen s (backlog conf) - forever $ - do (sck, cAddr) <- accept s - fork tm $ - do hndl <- socketToHandle sck ReadWriteMode - _ <- runHandler handler - Context - { _cServerHost = hostname conf - , _cAdminMail = adminMail conf - , _cListenOn = listenOn conf - , _cPayload = payload - , _cRequest = emptyRequest - , _cResponse = emptyResponse - , _cRawRequest = emptyRequest - , _cRawResponse = emptyResponse - , _cSocket = sck - , _cHandle = hndl - , _cClientAddr = cAddr - , _cServerAddr = sAddr - , _cQueue = [] - } - return () - waitForAll tm +start conf handler payload = forM (listenOn conf) (forkIO . listener) >>= waitAll + where + listener (SockAddrInet6 _ _ _ _) = error $ funcName ++ ": IPv6 sockets are not supported!" + listener (SockAddrUnix _) = error $ funcName ++ ": Unix sockets are not supported!" + listener (SockAddrInet port addr) = do + inet_ntoa addr >>= \a -> + putStrLn ("starting listening server on: " ++ a ++ ":" ++ show port) + s <- socket AF_INET Stream 0 + setSocketOption s ReuseAddr 1 + bindSocket s sAddr + listen s (backlog conf) + handlersTidsMVar <- newMVar [] + forever (acceptHandle handlersTidsMVar s) `finally` (readMVar handlersTidsMVar >>= waitAll) + where + sAddr = SockAddrInet port addr + acceptHandle handlersTidsMVar s = do + a <- accept s + modifyMVar_ handlersTidsMVar $ \handlersTids -> + fmap (:handlersTids) $ forkIO $ + handle a `finally` deleteMyTid handlersTidsMVar + + handle (sck, cAddr) = do + hndl <- socketToHandle sck ReadWriteMode + void $ runHandler handler Context + { _cServerHost = hostname conf + , _cAdminMail = adminMail conf + , _cListenOn = listenOn conf + , _cPayload = payload + , _cRequest = emptyRequest + , _cResponse = emptyResponse + , _cRawRequest = emptyRequest + , _cRawResponse = emptyResponse + , _cSocket = sck + , _cHandle = hndl + , _cClientAddr = cAddr + , _cServerAddr = sAddr + , _cQueue = [] + } + + deleteMyTid handlersTidsMVar = do + myTid <- myThreadId + modifyMVar_ handlersTidsMVar $ \handlersTids -> + return $! deleteWhen' ((myTid ==) . threadId) handlersTids + +funcName :: String +funcName = "Network.Salvia.Impl.Server.start" + +-- | Block until all threads identified by the given @ThreadId@s are terminated. +waitAll :: [ThreadId ()] -> IO () +waitAll = mapM_ wait_ + +{-| Strictly delete the first element of the list for which the predicate holds. + +Note that this function has the following strictness properties: + +@deleteWhen' (== 2) (1:2:3:undefined) = 1:3:undefined@ +@deleteWhen' (== 3) (1:2:3:undefined) = undefined@ +-} +deleteWhen' :: (a -> Bool) -> [a] -> [a] +deleteWhen' p = deleteWhen'_p + where + deleteWhen'_p [] = [] + deleteWhen'_p (x:xs) + | p x = xs + | otherwise = (x:) $! deleteWhen'_p xs + +void :: Functor f => f a -> f () +void = (() <$) -- 1.6.4.4