F8dQdmyq

1module Main where
2
3import Control.Exception (throw)
4
5import Database.HDBC
6import Database.HDBC.Sqlite3 -- just for this example, I use MySQL in production
7
8main = do
9    exec "CREATE TABLE IF NOT EXISTS users (name VARCHAR(80) NOT NULL)" []
10
11    exec "INSERT INTO users VALUES ('John')" []
12    exec "INSERT INTO users VALUES ('Rick')" []
13
14    rows <- select "SELECT name FROM users" []
15
16    let toS x = (fromSql x)::String
17    let names = map (toS . head) rows
18
19    print names
20	
21exec :: String -> [SqlValue] -> IO Integer
22exec query params = withDb $ c -> run c query params
23
24select :: String -> [SqlValue] -> IO [[SqlValue]]
25select query params = withDb $ c -> quickQuery' c query params
26
27withDb :: (Connection -> IO a) -> IO a
28withDb f = do
29    conn <- handleSqlError $ connectSqlite3 "users.db"
30    catchSql
31        (do r <- f conn
32            commit conn
33            disconnect conn
34            return r)
35        (e@(SqlError _ _ m) -> do
36            rollback conn
37            disconnect conn
38            throw e)
39	
40trySql :: Connection -> (Connection -> IO a) -> IO a
41trySql conn f = handleSql catcher $ do
42    r <- f conn
43    commit conn
44    return r
45  where catcher e = rollback conn >> throw e
46	
47import Control.Concurrent
48import Control.Exception
49
50data Pool a =
51    Pool { poolMin :: Int, poolMax :: Int, poolUsed :: Int, poolFree :: [a] }
52
53newConnPool low high newConn delConn = do
54    cs <- handleSqlError . sequence . replicate low newConn
55    mPool <- newMVar $ Pool low high 0 cs
56    return (mPool, newConn, delConn)
57
58delConnPool (mPool, newConn, delConn) = do
59    pool <- takeMVar mPool
60    if length (poolFree pool) /= poolUsed pool
61      then putMVar mPool pool >> fail "pool in use"
62      else mapM_ delConn $ poolFree pool
63
64takeConn (mPool, newConn, delConn) = modifyMVar mPool $ pool ->
65    case poolFree pool of
66        conn:cs ->
67            return (pool { poolUsed = poolUsed pool + 1, poolFree = cs }, conn)
68        _ | poolUsed pool < poolMax pool -> do
69            conn <- handleSqlError newConn
70            return (pool { poolUsed = poolUsed pool + 1 }, conn)
71        _ -> fail "pool is exhausted"
72
73putConn (mPool, newConn, delConn) conn = modifyMVar_ mPool $ pool ->
74    let used = poolUsed pool in
75    if used > poolMin conn
76      then handleSqlError (delConn conn) >> return (pool { poolUsed = used - 1 })
77      else return $ pool { poolUsed = used - 1, poolFree = conn : poolFree pool }
78
79withConn connPool = bracket (takeConn connPool) (putConn conPool)
80	
81connPool <- newConnPool 0 50 (connectSqlite3 "user.db") disconnect
82	
83module ConnPool ( newConnPool, withConn, delConnPool ) where
84
85import Control.Concurrent
86import Control.Exception
87import Control.Monad (replicateM)
88import Database.HDBC
89
90data Pool a =
91    Pool { poolMin :: Int, poolMax :: Int, poolUsed :: Int, poolFree :: [a] }
92
93newConnPool :: Int -> Int -> IO a -> (a -> IO ()) -> IO (MVar (Pool a), IO a, (a -> IO ()))
94newConnPool low high newConn delConn = do
95--    cs <- handleSqlError . sequence . replicate low newConn
96    cs <- replicateM low newConn 
97    mPool <- newMVar $ Pool low high 0 cs 
98    return (mPool, newConn, delConn)
99
100delConnPool (mPool, newConn, delConn) = do
101    pool <- takeMVar mPool
102    if length (poolFree pool) /= poolUsed pool
103      then putMVar mPool pool >> fail "pool in use"
104      else mapM_ delConn $ poolFree pool
105
106takeConn (mPool, newConn, delConn) = modifyMVar mPool $ pool ->
107    case poolFree pool of
108        conn:cs ->
109            return (pool { poolUsed = poolUsed pool + 1, poolFree = cs }, conn)
110        _ | poolUsed pool < poolMax pool -> do
111            conn <- handleSqlError newConn
112            return (pool { poolUsed = poolUsed pool + 1 }, conn)
113        _ -> fail "pool is exhausted"
114
115putConn :: (MVar (Pool a), IO a, (a -> IO b)) -> a -> IO ()
116putConn (mPool, newConn, delConn) conn = modifyMVar_ mPool $ pool ->
117    let used = poolUsed pool in
118    if used > poolMin pool
119    then handleSqlError (delConn conn) >> return (pool { poolUsed = used - 1 })
120    else return $ pool { poolUsed = used - 1, poolFree = conn : (poolFree pool) }
121
122withConn connPool = bracket (takeConn connPool) (putConn connPool)