From e0f512cf991c12d8aa4f283dc1f0759d3c1f71b5 Mon Sep 17 00:00:00 2001
From: Portnov <portnov@portnov-laptop.(none)>
Date: Sun, 5 Jul 2009 02:08:26 +0600
Subject: [PATCH] Add garbageCollector, which frees notused connections from pool.

---
 Framework/Http/HTTPServer.hs |    4 +++-
 Framework/Pool.hs            |   22 +++++++++++++++++++++-
 2 files changed, 24 insertions(+), 2 deletions(-)

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
-- 
1.7.2.3