Add garbageCollector, which frees notused connections from pool.

Portnov [2009-07-04 20:08:26]
Add garbageCollector, which frees notused connections from pool.
Filename
Framework/Http/HTTPServer.hs
Framework/Pool.hs
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index 6093aba..91b4872 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -87,6 +87,8 @@ serveHttp :: Int              -- ^ TCP port number
 serveHttp port hap conf = do
     dbPool <- emptyPool 10
     cPool <- emptyPool 10
-    installHandler sigINT (CatchOnce (freePools dbPool cPool)) Nothing
+    garbageCollector dbPool disconnect'
+    garbageCollector cPool cDisconnect
+--     installHandler sigINT (CatchOnce (freePools dbPool cPool)) Nothing
     initServer port (httpWorker (hap {dbpool=dbPool, cpool=cPool}) conf)

diff --git a/Framework/Pool.hs b/Framework/Pool.hs
index 6d9411c..7728a32 100644
--- a/Framework/Pool.hs
+++ b/Framework/Pool.hs
@@ -3,8 +3,10 @@ module Framework.Pool
     (Pool, MPool,
      emptyPool,
      acquire, free,
-     freeAll ) where
+     freeAll,
+     garbageCollector ) where

+import Control.Concurrent
 import Control.Concurrent.MVar

 data PoolItem a = NotConnected | Busy a | Free a
@@ -56,3 +58,21 @@ freeAll mpool f = withMVar mpool (mapM_ $ free' f)
     where free' _ NotConnected = return ()
           free' f (Busy res) = f res
           free' f (Free res) = f res
+
+garbageCollector :: MPool a
+                 -> (a -> IO ())
+                 -> IO ()
+garbageCollector mpool f = do
+    forkIO $ every 10000000 $ collect mpool
+    return ()
+    where
+      every ms action = do
+--           print "GC called"
+          action
+          threadDelay ms
+          every ms action
+      collect var = modifyMVar_ var (mapM $ freeGarbage)
+      freeGarbage (Free res) = do
+          f res
+          return NotConnected
+      freeGarbage x = return x
ViewGit