viewing paste Connection Pool | Haskell

Posted on the
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
module Main where
 
import Database.HDBC
import Database.HDBC.ODBC
import Data.Pool
import Control.Concurrent
import Data.Time.Clock      (NominalDiffTime)
 
-- The function run at start
-- Runs startWorker as a new thread with SQL connection
-- Jumps to check
main :: IO ()
main = do let conn = connect "127.0.0.1" "3306" "ro_main" "hathena" "haskell"
          pool <- connectionPool conn
          forkIO $ startWorker pool 10
          check pool
         
-- Prints active connections
check :: Pool Connection -> IO ()
check pool = do putStr "Active Connections: "
                res <- query' pool "show status like 'Threads_conn%'" []
                mapM_ (\val->putStrLn $ fromSql $ last val) res
                threadDelay 200000
                check pool
               
-- Starts n workers in new threads, one each second, then dies
startWorker :: Pool Connection -> Int -> IO ()
startWorker _    0 = return ()
startWorker pool n = do threadDelay 1000000
                        forkIO $ worker pool 100
                        startWorker pool (n-1)
               
-- The workers
-- Does n queries then dies
worker :: Pool Connection -> Int -> IO ()
worker _    0 = return ()
worker pool n = do res <- query' pool "SELECT * FROM login" []
                   worker pool (n-1)
 
-- Create database resource
-- OPTION=262144 | Disable transactions. Use if the tables aren't using InnoDB
connect :: String -> String -> String -> String -> String -> IO Connection
connect host port database user pass = do
  connectODBC $ unwords [ "DRIVER={MySQL ODBC 5.1 Driver};",
                          "OPTION=262144;",
                          "SERVER=" ++ host ++ ";",
                          "PORT=" ++ port ++ ";",
                          "DATABASE=" ++ database ++ ";",
                          "USER=" ++ user ++ ";",
                          "PASSWORD=" ++ pass ]
 
-- Create database pool
-- Config the connections here
connectionPool :: IO Connection -> IO (Pool Connection)
connectionPool conn = do
  let numStripes = 2 :: Int             -- Number of connection threads to run
  let idleTime = 2 :: NominalDiffTime   -- Time until idle connection dies, in seconds
  let maxResources = 3 :: Int           -- Number of connections per thread
  createPool conn disconnect numStripes idleTime maxResources
 
-- Run a query on the connection
query, query' :: Pool Connection -> String -> [SqlValue] -> IO [[SqlValue]]
query  pool query values = withResource pool (\conn->quickQuery  conn query values)
query' pool query values = withResource pool (\conn->quickQuery' conn query values)
Viewed 373 times, submitted by unknown.