diff --git a/Blog/Blog b/Blog/Blog
index 7712ae1..d268d24 100755
Binary files a/Blog/Blog and b/Blog/Blog differ
diff --git a/Blog/Config.hs b/Blog/Config.hs
index fb81163..c84c5fa 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/Blog/Makefile b/Blog/Makefile
index c417379..3399fe3 100644
--- a/Blog/Makefile
+++ b/Blog/Makefile
@@ -1,4 +1,4 @@
-GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -threaded -i. -i../
+GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../
TEMPLATES=../Framework/TEngine/Templates.hs
all: Templates Blog
diff --git a/Framework/Cache.hs b/Framework/Cache.hs
index 437e0d8..dcf284a 100644
--- a/Framework/Cache.hs
+++ b/Framework/Cache.hs
@@ -21,6 +21,7 @@ import qualified Network.Memcache.Protocol as SMC
import Network.Memcache.Serializable (Serializable(..))
import Framework.Utils
+import Framework.Pool
import Framework.CacheTypes
-- $doc
@@ -74,12 +75,15 @@ instance CacheBackend FakeBackend where
cunset _ _ = return True
cfree _ = return ()
--- | Init cache backend. Backend type is given in first argument,
--- i.e. : initCache "memcached" "localhost:11211".
-initCache :: String -> String -> IO CacheConnection
-initCache "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend)
-initCache "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend)
-initCache "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend)
+initCache' :: String -> String -> IO CacheConnection
+initCache' "memcached" s = CConnection `fmap` (cinit s :: IO MemcacheBackend)
+initCache' "filesystem" s = CConnection `fmap` (cinit s :: IO FilesystemBackend)
+initCache' "fake" s = CConnection `fmap` (cinit s :: IO FakeBackend)
+
+-- | Init cache backend. Backend type is given in second argument,
+-- i.e. : initCache pool ("memcached", "localhost:11211").
+initCache :: MPool CacheConnection -> (String,String) -> IO (Int,CacheConnection)
+initCache mpool x = acquire mpool x (\(backend, s) -> initCache' backend s)
-- | Get data from cache (from given connection)
cGet :: (Serializable v) => CacheConnection -> String -> IO (Maybe v)
@@ -93,8 +97,8 @@ cUnset :: CacheConnection -> String -> IO Bool
cUnset (CConnection b) name = cunset b name
-- | Free cache backend
-cFree :: CacheConnection -> IO ()
-cFree (CConnection b) = cfree b
+cFree :: MPool CacheConnection -> Int -> CacheConnection -> IO ()
+cFree mpool n conn = free mpool n conn
showC Nothing = "Nothing"
showC (Just x) = s++" ("++(show $ length s)++")"
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index dff02e9..e337ddc 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -14,6 +14,7 @@ import Control.Exception
import Network.Shed.Httpd
import Network.URI
+import Framework.Pool
import Framework.Types
import Framework.Urls
import Framework.Utils
@@ -53,13 +54,13 @@ serveStatic' ac resource =
choose "" = basedir++"/index.html"
choose x = basedir ++"/"++x
-httpWorker :: MVar Pool -> StaticConfig -> URLConf -> Request -> IO Response
-httpWorker pool hap conf req@(Request {reqURI = URI {uriPath}}) = do
+httpWorker :: StaticConfig -> URLConf -> Request -> IO Response
+httpWorker 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 {dbpool = pool}) req (tail uriPath) conf
+ resp <- runURLConf hap req (tail uriPath) conf
responseMiddlewares resp
defaultURLConf :: URLConf
@@ -67,6 +68,7 @@ defaultURLConf = Function serveStatic
serveHttp :: Int -> StaticConfig -> URLConf -> IO ()
serveHttp port hap conf = do
- pool <- newMVar $ replicate 10 NotConnected
- initServer port (httpWorker pool hap conf)
+ dbPool <- emptyPool 10
+ cPool <- emptyPool 10
+ initServer port (httpWorker (hap {dbpool=dbPool, cpool=cPool}) conf)
diff --git a/Framework/Makefile b/Framework/Makefile
index f319f5e..8ff3645 100644
--- a/Framework/Makefile
+++ b/Framework/Makefile
@@ -1,4 +1,4 @@
-GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -threaded -i. -i../
+GHC=ghc $(GHCFLAGS) --make -O2 -optc-O3 -i. -i../
all: API.o
diff --git a/Framework/Pool.hs b/Framework/Pool.hs
new file mode 100644
index 0000000..a4c039d
--- /dev/null
+++ b/Framework/Pool.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+module Framework.Pool
+ (Pool, MPool,
+ emptyPool,
+ acquire, free) where
+
+import Control.Concurrent.MVar
+
+data PoolItem a = NotConnected | Busy a | Free a
+
+type Pool a = [PoolItem a]
+type MPool a = MVar (Pool a)
+
+instance Show (MPool a) where
+ show _ = "<Pool>"
+
+emptyPool :: Int -> IO (MPool a)
+emptyPool n = newMVar (replicate n NotConnected)
+
+acquire :: MPool a -> c -> (c -> IO a) -> IO (Int,a)
+acquire var x f = do
+ modifyMVar var (findConnection f x)
+
+findConnection :: (c -> IO a) -> c -> Pool a -> IO (Pool a, (Int,a))
+findConnection f x pool = findConnection' [] 0 x pool
+ where
+ findConnection' xs i _ ((Free res):ps) = return (xs++(Busy res):ps, (i,res))
+ findConnection' xs i x (NotConnected:ps) = do
+ res <- f x
+ return (xs++(Busy res):ps, (i,res))
+ findConnection' xs i x (p:ps) = findConnection' (xs++[p]) (i+1) x ps
+ findConnection' xs i x [] = do
+ res <- f x
+ return (xs++[Busy res], (i+1,res))
+
+free :: MPool a -> Int -> a -> IO ()
+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)
diff --git a/Framework/Storage.hs b/Framework/Storage.hs
index b2fea1c..94aef3f 100644
--- a/Framework/Storage.hs
+++ b/Framework/Storage.hs
@@ -18,6 +18,7 @@ import qualified Database.HDBC as D
import Framework.Types
import Framework.Models
+import Framework.Pool
-- | Connect to DB
connect :: String -- ^ DB backend
@@ -27,31 +28,12 @@ connect "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file)
connect "psql" str = DBC `fmap` (PostgreSQL.connectPostgreSQL str)
-- | 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))
+connect' :: MPool DBConnection -> StaticConfig -> IO (Int,DBConnection)
+connect' var hp = acquire var hp (\c -> connect (dbDriver c) (dbPath c))
-- | Disconnect from DB
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
+disconnect ac n dbc = free (dbpool $ httpParams ac) n dbc
-- | Generic query. Lazy.
query :: DBConnection
diff --git a/Framework/Types.hs b/Framework/Types.hs
index 2e70a57..bfa0f28 100644
--- a/Framework/Types.hs
+++ b/Framework/Types.hs
@@ -10,6 +10,7 @@ import Control.Concurrent.MVar
import Framework.Http.SessionTypes
import Framework.CacheTypes
+import Framework.Pool
----------------------------------------------------------------
--Types
@@ -23,13 +24,6 @@ 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 {
@@ -41,7 +35,8 @@ data StaticConfig = HP {
cachePath :: String,
sessionsDriver :: String,
sessionsPath :: String,
- dbpool :: MVar Pool
+ dbpool :: MPool DBConnection,
+ cpool :: MPool CacheConnection
}
deriving (Show)
@@ -55,7 +50,8 @@ data ActionConfig = ActionConfig {
sessionsBackend :: SessionsConnection, -- ^ Connection to sessions backend
cacheBackend :: CacheConnection, -- ^ Connection to cache backend
cookiesExp :: String, -- ^ Cookies expiration date
- dbpoolIndex :: Int
+ dbpoolIndex :: Int,
+ cpoolIndex :: Int
}
deriving (Show)
diff --git a/Framework/Wrapper.hs b/Framework/Wrapper.hs
index 13b5df3..2188144 100644
--- a/Framework/Wrapper.hs
+++ b/Framework/Wrapper.hs
@@ -20,7 +20,7 @@ mkActionConfig hp rq = do
let (sid,mm,addSession) = case sess of
Sessions.NewSession sid' -> (sid', M.empty, True)
Sessions.ExistingSession sid' mm' -> (sid', mm', False)
- cc <- Cache.initCache (cacheDriver hp) (cachePath hp)
+ (j,cc) <- Cache.initCache (cpool hp) (cacheDriver hp, cachePath hp)
let conf = ActionConfig {
request = rq,
httpParams = hp,
@@ -30,14 +30,15 @@ mkActionConfig hp rq = do
sessionsBackend = sb,
cacheBackend = cc,
cookiesExp = ed,
- dbpoolIndex = i
+ dbpoolIndex = i,
+ cpoolIndex = j
}
return (conf,addSession)
acFree :: ActionConfig -> IO ()
acFree ac = do
Storage.disconnect ac (dbpoolIndex ac) (dbconnection ac)
- Cache.cFree (cacheBackend ac)
+ Cache.cFree (cpool $ httpParams ac) (cpoolIndex ac) (cacheBackend ac)
Sessions.sFree (sessionsBackend ac)
----------------------------------------------------------------------------------------------------------