diff --git a/Blog/Blog b/Blog/Blog
index d268d24..c781c57 100755
Binary files a/Blog/Blog and b/Blog/Blog differ
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 00cca7a..8fcdac9 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -42,10 +42,11 @@ allposts conf = do
lastComments <- querySQL' conf ((table commentModel) `order` (Desceding "dt") `limit` (0,10)) [] commentModel
let code = httpGetVar' (request conf) "code" ""
let message = maybe "" id $ lookup code messagecodes
- let html = render "blogposts.html" $ M.fromList [("posts", C posts),
- ("comments", C lastComments),
- ("message", C message),
- ("pager", C pagerHtml)]
+ let html = render "blogposts.html" $
+ M.fromList [("posts", C posts),
+ ("comments", C lastComments),
+ ("message", C message),
+ ("pager", C pagerHtml)]
cPut (cacheBackend conf) key html
return $ ok html
where key = "allposts" ++ (httpGetVar' (request conf) "page" "1")
diff --git a/Framework/Cache.hs b/Framework/Cache.hs
index dcf284a..e3e6938 100644
--- a/Framework/Cache.hs
+++ b/Framework/Cache.hs
@@ -4,7 +4,7 @@ module Framework.Cache
initCache,
cGet,cPut,cUnset,
cached,
- cFree,
+ cFree, cDisconnect,
Serializable (..),
CacheConnection
) where
@@ -100,9 +100,12 @@ cUnset (CConnection b) name = cunset b name
cFree :: MPool CacheConnection -> Int -> CacheConnection -> IO ()
cFree mpool n conn = free mpool n conn
-showC Nothing = "Nothing"
-showC (Just x) = s++" ("++(show $ length s)++")"
- where s = toString x
+cDisconnect :: CacheConnection -> IO ()
+cDisconnect (CConnection b) = cfree b
+
+-- showC Nothing = "Nothing"
+-- showC (Just x) = s++" ("++(show $ length s)++")"
+-- where s = toString x
-- | cached cConnection name key function argument
-- Executes given function with given argument, caching the result
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index e337ddc..d4b4187 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -5,7 +5,8 @@ module Framework.Http.HTTPServer
serveStatic) where
import Prelude hiding (catch,print,putStr,putStrLn,readFile)
-import Control.Concurrent.MVar
+import System.Posix.Signals
+import System.Exit
import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn)
import System.IO.UTF8
import Codec.Binary.UTF8.String
@@ -14,6 +15,8 @@ import Control.Exception
import Network.Shed.Httpd
import Network.URI
+import Framework.Cache
+import Framework.Storage
import Framework.Pool
import Framework.Types
import Framework.Urls
@@ -66,9 +69,17 @@ httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do
defaultURLConf :: URLConf
defaultURLConf = Function serveStatic
+-- freePools :: MPool DBConnection -> MPool CacheConnection -> IO ()
+freePools dbPool cPool = do
+ print "Disconnecting from DB and cache"
+ freeAll dbPool disconnect'
+ freeAll cPool cDisconnect
+ exitWith ExitSuccess
+
serveHttp :: Int -> StaticConfig -> URLConf -> IO ()
serveHttp port hap conf = do
dbPool <- emptyPool 10
cPool <- emptyPool 10
+ 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 a4c039d..00052d9 100644
--- a/Framework/Pool.hs
+++ b/Framework/Pool.hs
@@ -2,7 +2,8 @@
module Framework.Pool
(Pool, MPool,
emptyPool,
- acquire, free) where
+ acquire, free,
+ freeAll ) where
import Control.Concurrent.MVar
@@ -38,3 +39,9 @@ free var n res = modifyMVar_ var (freeConnection n res)
freeConnection :: Int -> a -> Pool a -> IO (Pool a)
freeConnection i res pool = return $ (take i pool)++[Free res]++(drop (i+1) pool)
+
+freeAll :: MPool a -> (a -> IO ()) -> IO ()
+freeAll mpool f = withMVar mpool (mapM_ $ free' f)
+ where free' _ NotConnected = return ()
+ free' f (Busy res) = f res
+ free' f (Free res) = f res
diff --git a/Framework/Storage.hs b/Framework/Storage.hs
index 94aef3f..96f9336 100644
--- a/Framework/Storage.hs
+++ b/Framework/Storage.hs
@@ -4,13 +4,12 @@ module Framework.Storage
(DBConnection,
connect, connect',
commit,
- disconnect,
+ disconnect, disconnect',
query, query', queryR, queryR'
)
where
-import Control.Concurrent.MVar
import qualified Database.HDBC.Sqlite3 as Sqlite3
import qualified Database.HDBC.MySQL as MySQL
import qualified Database.HDBC.PostgreSQL as PostgreSQL
@@ -35,6 +34,9 @@ connect' var hp = acquire var hp (\c -> connect (dbDriver c) (dbPath c))
disconnect :: ActionConfig -> Int -> DBConnection -> IO ()
disconnect ac n dbc = free (dbpool $ httpParams ac) n dbc
+disconnect' :: DBConnection -> IO ()
+disconnect' (DBC conn) = D.disconnect conn
+
-- | Generic query. Lazy.
query :: DBConnection
-> String -- ^ SQL
diff --git a/Framework/Types.hs b/Framework/Types.hs
index bfa0f28..ab7d5e4 100644
--- a/Framework/Types.hs
+++ b/Framework/Types.hs
@@ -6,7 +6,6 @@ import Network.Shed.Httpd
import Data.List
import qualified Data.Map as M
import qualified Database.HDBC as D
-import Control.Concurrent.MVar
import Framework.Http.SessionTypes
import Framework.CacheTypes