Add garbageCollector, which frees notused connections from pool.
Add garbageCollector, which frees notused connections from pool.
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