concurrent sqlite

concurrnetSqlite.hs

#!/usr/bin/env stack
{-      stack
        script
        --resolver lts-18.28
        --package sqlite-simple
        --package async
        --package text
-}
{-
-- | the purpose of this code is :
-- 1) sqlite may be accessed concurrently
-- 2) multiple connections per process and thread is possible
--
-- Conclusion
-- Test was successful for:
--    concurrent inserts
--    concurrent queries
-- Test Failed for:
--    mixing inserts and queries, uncommenting the TODO will lock sqlite
-- However, if inserts are mixed in with the queries on the same connection, the threads will lock.
-}
{-# LANGUAGE OverloadedStrings #-}

import           Control.Concurrent.Async
import           Control.Monad            (void)
import           Database.SQLite.Simple


q :: Query
q =  "SELECT * from test where str=:str"
-- | create 2 connection, and query sqlite concurrently on each
--  run theinserts serially to avoid lucking the db

insertAction :: Connection -> Int -> IO ()
insertAction conn1 num =
  void $ concurrently
        (execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show num :: String))
                 >>  execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show num :: String))
                 >>  execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num+1) :: String))
                 >>  execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num +2):: String))
                 >>  execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num +4):: String))
        )
                (queryNamed conn1 q [":str" := show (num +3)] :: IO [TestField])

queryAction :: Connection -> Connection -> Int -> IO [TestField]
queryAction conn1 conn2 num = do
  -- TODO this will lock sqlite everytime
  -- insertAction conn1 num
  --
  (s1, s2) <- concurrently
                (execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num +2):: String)) >> queryNamed conn1 q [":str" := show (num+1)])
                (queryNamed conn1 q [":str" := show (num+2)])
  (s3, s4) <- concurrently
                ( queryNamed conn1 q [":str" := show (num +3)] :: IO [TestField])
                ( queryNamed conn1 q [":str" := show (num+4)] :: IO [TestField])
  void $ concurrently
                 (execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num +2):: String))
                 >>  execute conn1 "INSERT INTO test (str) VALUES (?)" (Only (show (num +4):: String)) )
                ( (queryNamed conn1 q [":str" := show (num +3)] :: IO [TestField])
                  >> (queryNamed conn2 q [":str" := show (num+4)]:: IO [TestField]) )
  pure $ s1 <> s2

data TestField = TestField Int String deriving (Show)

instance FromRow TestField where
  fromRow = TestField <$> field <*> field
num :: Int
num = 1
main :: IO ()
main = do

  conn1 <- open "/tmp/test.db"
  -----------------------------------------------------
  -- put sqlite in wall mode for concurrent insert/query
  -----------------------------------------------------
  execute_ conn1 "PRAGMA journal_mode=WAL"
  -----------------------------------------------------

  conn2 <- open "/tmp/test.db"
  conn <- open "/tmp/test.db"

  execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)" *>
    execute conn "INSERT INTO test (str) VALUES (?)" (Only (show num :: String)) *>
    execute conn "INSERT INTO test (str) VALUES (?)" (Only (show (num+1) :: String))
  forConcurrently_ [1 .. 20] (insertAction conn1)
  rs <- forConcurrently [1 .. 10] (queryAction conn1 conn2)
  mapM_ (\x -> print x >> putStrLn (replicate 40 '-')) rs

  close conn

  putStrLn "\n------ completed sqlite concurrent tests ----\n"