Sqlite3Utils.hs

{-| Implementation of an SQLite3-based event store. -}
module Data.CQRS.EventStore.Backend.Sqlite3Utils
       ( sourceQuery
       , execSql
       , withTransaction
       ) where

import           Control.Exception (catch, bracket, onException, SomeException)
import           Control.Monad.IO.Class (liftIO)
import           Data.Conduit (ResourceT, Source, bracketP, yield)
import           Data.Text (Text)
import qualified Database.SQLite3 as SQL
import           Database.SQLite3 (Database, Statement, SQLData(..), StepResult(..))

beginTransaction :: Database -> IO ()
beginTransaction database = execSql database "BEGIN TRANSACTION;" []

commitTransaction :: Database -> IO ()
commitTransaction database = execSql database "COMMIT TRANSACTION;" []

rollbackTransaction :: Database -> IO ()
rollbackTransaction database = execSql database "ROLLBACK TRANSACTION;" []

withSqlStatement :: Database -> Text -> [SQLData] -> (Statement -> IO a) -> IO a
withSqlStatement database sql parameters action =
  bracket (SQL.prepare database sql) SQL.finalize $ \statement -> do
    SQL.bind statement parameters
    action statement

-- | Execute an SQL statement for which no result is expected.
execSql :: Database -> Text -> [SQLData] -> IO ()
execSql database sql parameters =
  withSqlStatement database sql parameters $ \stmt -> do
    _ <- SQL.step stmt
    return ()

data State = Unbound | Bound
           deriving (Eq)

sourceQuery :: Database -> Text -> [SQLData] -> Source (ResourceT IO) [SQLData]
sourceQuery database sql parameters =
    bracketP (SQL.prepare database sql)
             (SQL.finalize)
             run
    where
      run stmt = do
        liftIO $ SQL.bind stmt parameters
        loop stmt
      loop stmt = do
        nextResult <- liftIO $ SQL.step stmt
        case nextResult of
          Done -> return ()
          Row -> do
            (liftIO $ SQL.columns stmt) >>= yield
            loop stmt

-- | Execute an IO action with an active transaction.
withTransaction :: Database -> IO a -> IO a
withTransaction database action = do
  beginTransaction database
  onException runAction tryRollback
  where
    runAction = do
      r <- action
      commitTransaction database
      return r

    tryRollback =
      -- Try rollback while discarding exception; we want to preserve
      -- original exception.
      catch (rollbackTransaction database) (\(_::SomeException) -> return ())