SQLiteFlawless.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where


import System.IO
import Control.Applicative
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import Control.Monad
import Control.Concurrent

main :: IO ()
main = do
    conn <- open "test.db"
    execute_ conn "CREATE TABLE IF NOT EXISTS singleton (t TEXT)"
    execute_ conn "DELETE FROM singleton"
    execute_ conn "INSERT INTO singleton (t) VALUES ('blah')"
    let total = 4000
    let nums = take 20 [2..]
    let jobs = map (\n -> replicateM_ (div total n) $ foobar n conn) nums
    sequence $ map forkIO jobs
    forkIO $ replicateM_ (div total 12) $ showDb conn
    milliSleep (5 * total)
    putStrLn ""
    close conn

foobar n conn = do
    execute conn "UPDATE singleton SET t = ?" [("fork #" ++ show n) :: String]
    milliSleep n

showDb conn = do
    r <- query_ conn "SELECT t FROM singleton"
    let s = (head $ head r) :: String
    putStr s
    putStr "\t"
    hFlush stdout
    milliSleep 11

milliSleep = threadDelay . (*) 1000