diff --git a/Blog/Blog b/Blog/Blog
index 0ee7675..7712ae1 100755
Binary files a/Blog/Blog and b/Blog/Blog differ
diff --git a/Blog/Config.hs b/Blog/Config.hs
index c84c5fa..fb81163 100644
--- a/Blog/Config.hs
+++ b/Blog/Config.hs
@@ -11,8 +11,8 @@ params = HP { docdir = "static",
dbPath = "host=rtfm-server password=31415",
-- cacheDriver = "memcached",
-- cachePath = "rtfm-server:11211",
--- cacheDriver = "fake",
- cacheDriver = "filesystem",
+ cacheDriver = "fake",
+-- cacheDriver = "filesystem",
cachePath = "tmp/",
sessionsDriver = "files",
sessionsPath = "tmp/sessions/"
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index 1074da6..dff02e9 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -5,6 +5,7 @@ module Framework.Http.HTTPServer
serveStatic) where
import Prelude hiding (catch,print,putStr,putStrLn,readFile)
+import Control.Concurrent.MVar
import System.IO hiding (print,hPutStr,hPutStrLn,readFile,putStrLn)
import System.IO.UTF8
import Codec.Binary.UTF8.String
@@ -52,18 +53,20 @@ serveStatic' ac resource =
choose "" = basedir++"/index.html"
choose x = basedir ++"/"++x
-httpWorker :: StaticConfig -> URLConf -> Request -> IO Response
-httpWorker hap conf req@(Request {reqURI = URI {uriPath}}) = do
+httpWorker :: MVar Pool -> StaticConfig -> URLConf -> Request -> IO Response
+httpWorker pool hap conf req@(Request {reqURI = URI {uriPath}}) = do
let s = unEscapeString $ reqBody req
-- putStrLn $ "Request body: "++show s
-- putStrLn $ "deUTF:"++(decodeString s)
-- putStrLn $ "Serving "++uriPath
- resp <- runURLConf hap req (tail uriPath) conf
+ resp <- runURLConf (hap {dbpool = pool}) req (tail uriPath) conf
responseMiddlewares resp
defaultURLConf :: URLConf
defaultURLConf = Function serveStatic
serveHttp :: Int -> StaticConfig -> URLConf -> IO ()
-serveHttp port hap conf = initServer port (httpWorker hap conf)
+serveHttp port hap conf = do
+ pool <- newMVar $ replicate 10 NotConnected
+ initServer port (httpWorker pool hap conf)
diff --git a/Framework/Storage.hs b/Framework/Storage.hs
index 7c6d4ba..b2fea1c 100644
--- a/Framework/Storage.hs
+++ b/Framework/Storage.hs
@@ -10,6 +10,7 @@ module Framework.Storage
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
@@ -25,13 +26,32 @@ connect :: String -- ^ DB backend
connect "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file)
connect "psql" str = DBC `fmap` (PostgreSQL.connectPostgreSQL str)
--- | Connect to DB, get parameters from "StaticConfig"
-connect' :: StaticConfig -> IO DBConnection
-connect' (HP {dbDriver, dbPath}) = connect dbDriver dbPath
+-- | Connect to DB, get parameters from "ActionConfig"
+connect' :: MVar Pool -> StaticConfig -> IO (Int,DBConnection)
+-- connect' (HP {dbDriver, dbPath}) = connect dbDriver dbPath
+connect' var hp = do
+ modifyMVar var (findConnection hp)
+
+findConnection :: StaticConfig -> Pool -> IO (Pool, (Int,DBConnection))
+findConnection hp pool = findConnection' [] 0 hp pool
+ where
+ findConnection' xs i _ ((Free dbc):ps) = return (xs++(Busy dbc):ps, (i,dbc))
+ findConnection' xs i hp (NotConnected:ps) = do
+ dbc <- connect (dbDriver hp) (dbPath hp)
+ return (xs++(Busy dbc):ps, (i,dbc))
+ findConnection' xs i hp (p:ps) = findConnection' (xs++[p]) (i+1) hp ps
+ findConnection' xs i hp [] = do
+ dbc <- connect (dbDriver hp) (dbPath hp)
+ return (xs++[Busy dbc], (i+1,dbc))
-- | Disconnect from DB
-disconnect :: DBConnection -> IO ()
-disconnect (DBC conn) = D.disconnect conn
+disconnect :: ActionConfig -> Int -> DBConnection -> IO ()
+disconnect ac n dbc = modifyMVar_ (dbpool $ httpParams ac) (freeConnection n dbc)
+
+freeConnection :: Int -> DBConnection -> Pool -> IO Pool
+freeConnection i dbc pool = return $ (take i pool)++[Free dbc]++(drop (i+1) pool)
+
+-- D.disconnect conn
-- | Generic query. Lazy.
query :: DBConnection
diff --git a/Framework/Types.hs b/Framework/Types.hs
index a3a386e..2e70a57 100644
--- a/Framework/Types.hs
+++ b/Framework/Types.hs
@@ -6,6 +6,7 @@ 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
@@ -22,6 +23,13 @@ data DBConnection = forall c. D.IConnection c => DBC c
instance Show DBConnection where
show _ = "<DB connection>"
+data PoolItem = NotConnected | Busy DBConnection | Free DBConnection
+
+type Pool = [PoolItem]
+
+instance Show (MVar Pool) where
+ show _ = "<DB pool>"
+
-------------------------------------------------------------------------------------------
data StaticConfig = HP {
@@ -32,7 +40,8 @@ data StaticConfig = HP {
cacheDriver :: String,
cachePath :: String,
sessionsDriver :: String,
- sessionsPath :: String
+ sessionsPath :: String,
+ dbpool :: MVar Pool
}
deriving (Show)
@@ -45,7 +54,8 @@ data ActionConfig = ActionConfig {
sessionMap :: SessionMap, -- ^ Contains session variables
sessionsBackend :: SessionsConnection, -- ^ Connection to sessions backend
cacheBackend :: CacheConnection, -- ^ Connection to cache backend
- cookiesExp :: String -- ^ Cookies expiration date
+ cookiesExp :: String, -- ^ Cookies expiration date
+ dbpoolIndex :: Int
}
deriving (Show)
diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs
index cb36b93..13b5df3 100644
--- a/Framework/Wrapper.hs
+++ b/Framework/Wrapper.hs
@@ -14,7 +14,7 @@ import Framework.Utils
mkActionConfig :: StaticConfig -> Request -> IO (ActionConfig,Bool)
mkActionConfig hp rq = do
ed <- expirationDate
- conn <- Storage.connect' hp
+ (i,conn) <- Storage.connect' (dbpool hp) hp
sb <- Sessions.initSessions (sessionsDriver hp) (sessionsPath hp)
sess <- Sessions.session sb rq
let (sid,mm,addSession) = case sess of
@@ -29,13 +29,14 @@ mkActionConfig hp rq = do
sessionMap = mm,
sessionsBackend = sb,
cacheBackend = cc,
- cookiesExp = ed
+ cookiesExp = ed,
+ dbpoolIndex = i
}
return (conf,addSession)
acFree :: ActionConfig -> IO ()
acFree ac = do
- Storage.disconnect (dbconnection ac)
+ Storage.disconnect ac (dbpoolIndex ac) (dbconnection ac)
Cache.cFree (cacheBackend ac)
Sessions.sFree (sessionsBackend ac)