From 685411e25a1d29ff43810799d6522cbffcdb554e Mon Sep 17 00:00:00 2001
From: Bas van Dijk <v.dijk.bas@gmail.com>
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

