{-# LANGUAGE RecordWildCards #-}
{-# language DerivingVia #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}

module Database.Sqlite.Easy.Internal where

import Database.SQLite3
import Data.String (IsString, fromString)
import Data.Text (Text)
import Data.Typeable
import Data.Pool
import Control.Monad.Reader
import Control.Exception
import Control.Monad.IO.Unlift

-- * Connection

-- | A SQLite3 connection string
newtype ConnectionString
  = ConnectionString
    { ConnectionString -> Text
unConnectionString :: Text
    }
  deriving String -> ConnectionString
forall a. (String -> a) -> IsString a
fromString :: String -> ConnectionString
$cfromString :: String -> ConnectionString
IsString via Text
  deriving Int -> ConnectionString -> ShowS
[ConnectionString] -> ShowS
ConnectionString -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionString] -> ShowS
$cshowList :: [ConnectionString] -> ShowS
show :: ConnectionString -> String
$cshow :: ConnectionString -> String
showsPrec :: Int -> ConnectionString -> ShowS
$cshowsPrec :: Int -> ConnectionString -> ShowS
Show

-- | Create a pool of a sqlite3 db with a specific connection string.
createSqlitePool :: ConnectionString -> IO (Pool Database)
createSqlitePool :: ConnectionString -> IO (Pool Database)
createSqlitePool (ConnectionString Text
connStr) =
  forall a. PoolConfig a -> IO (Pool a)
newPool PoolConfig
    { createResource :: IO Database
createResource = Text -> IO Database
open Text
connStr
    , freeResource :: Database -> IO ()
freeResource = Database -> IO ()
close
    , poolCacheTTL :: Double
poolCacheTTL = Double
180
    , poolMaxResources :: Int
poolMaxResources = Int
50
    }

-- | Open a database, run some stuff, close the database.
withDb :: ConnectionString -> SQLite a -> IO a
withDb :: forall a. ConnectionString -> SQLite a -> IO a
withDb (ConnectionString Text
connStr) =
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Text -> IO Database
open Text
connStr) Database -> IO ()
close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Database -> SQLite a -> IO a
runSQLite

-- | Use an active database connection to run some stuff on a database.
withDatabase :: Database -> SQLite a -> IO a
withDatabase :: forall a. Database -> SQLite a -> IO a
withDatabase = forall a. Database -> SQLite a -> IO a
runSQLite

-- | Use a resource pool to run some stuff on a database.
withPool :: Pool Database -> SQLite a -> IO a
withPool :: forall a. Pool Database -> SQLite a -> IO a
withPool Pool Database
pool = forall a r. Pool a -> (a -> IO r) -> IO r
withResource Pool Database
pool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Database -> SQLite a -> IO a
runSQLite

-- * Execution

-- | A SQL statement
newtype SQL
  = SQL
    { SQL -> Text
unSQL :: Text
    }
  deriving (NonEmpty SQL -> SQL
SQL -> SQL -> SQL
forall b. Integral b => b -> SQL -> SQL
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> SQL -> SQL
$cstimes :: forall b. Integral b => b -> SQL -> SQL
sconcat :: NonEmpty SQL -> SQL
$csconcat :: NonEmpty SQL -> SQL
<> :: SQL -> SQL -> SQL
$c<> :: SQL -> SQL -> SQL
Semigroup, String -> SQL
forall a. (String -> a) -> IsString a
fromString :: String -> SQL
$cfromString :: String -> SQL
IsString) via Text
  deriving Int -> SQL -> ShowS
[SQL] -> ShowS
SQL -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SQL] -> ShowS
$cshowList :: [SQL] -> ShowS
show :: SQL -> String
$cshow :: SQL -> String
showsPrec :: Int -> SQL -> ShowS
$cshowsPrec :: Int -> SQL -> ShowS
Show

-- | Run a SQL statement on a database and fetch the results.
run :: SQL -> SQLite [[SQLData]]
run :: SQL -> SQLite [[SQLData]]
run (SQL Text
stmt) = do
  Database
db <- SQLite Database
getDB
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Database -> Text -> IO Statement
prepare Database
db Text
stmt) Statement -> IO ()
finalize Statement -> IO [[SQLData]]
fetchAll

-- | Run a SQL statement with certain parameters on a database and fetch the results.
runWith :: SQL -> [SQLData] -> SQLite [[SQLData]]
runWith :: SQL -> [SQLData] -> SQLite [[SQLData]]
runWith (SQL Text
stmt) [SQLData]
params = do
  Database
db <- SQLite Database
getDB
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Database -> Text -> IO Statement
prepare Database
db Text
stmt) Statement -> IO ()
finalize forall a b. (a -> b) -> a -> b
$ \Statement
preparedStmt -> do
      Statement -> [SQLData] -> IO ()
bind Statement
preparedStmt [SQLData]
params
      Statement -> IO [[SQLData]]
fetchAll Statement
preparedStmt

-- | Run a statement and fetch all of the data.
fetchAll :: Statement -> IO [[SQLData]]
fetchAll :: Statement -> IO [[SQLData]]
fetchAll Statement
stmt = do
  StepResult
res <- Statement -> IO StepResult
step Statement
stmt
  case StepResult
res of
    StepResult
Row -> do
      [SQLData]
row <- Statement -> IO [SQLData]
columns Statement
stmt
      [[SQLData]]
rows <- Statement -> IO [[SQLData]]
fetchAll Statement
stmt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SQLData]
row forall a. a -> [a] -> [a]
: [[SQLData]]
rows)
    StepResult
Done ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- * Transaction

-- | The type of actions to run on a SQLite database.
--   In essence, it is almost the same as @Database -> IO a@.
--
--   'SQLite' actions can be created with the 'run' and 'runWith'
--   functions, and can be composed using the type class instances.
--
--   'SQLite' actions can be run with the 'withDb', 'withDatabase',
--   and 'withPool' functions.
newtype SQLite a
  = SQLite
    { forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite :: SQLiteStuff -> IO a
    }
  deriving (forall a b. a -> SQLite b -> SQLite a
forall a b. (a -> b) -> SQLite a -> SQLite b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> SQLite b -> SQLite a
$c<$ :: forall a b. a -> SQLite b -> SQLite a
fmap :: forall a b. (a -> b) -> SQLite a -> SQLite b
$cfmap :: forall a b. (a -> b) -> SQLite a -> SQLite b
Functor, Functor SQLite
forall a. a -> SQLite a
forall a b. SQLite a -> SQLite b -> SQLite a
forall a b. SQLite a -> SQLite b -> SQLite b
forall a b. SQLite (a -> b) -> SQLite a -> SQLite b
forall a b c. (a -> b -> c) -> SQLite a -> SQLite b -> SQLite c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. SQLite a -> SQLite b -> SQLite a
$c<* :: forall a b. SQLite a -> SQLite b -> SQLite a
*> :: forall a b. SQLite a -> SQLite b -> SQLite b
$c*> :: forall a b. SQLite a -> SQLite b -> SQLite b
liftA2 :: forall a b c. (a -> b -> c) -> SQLite a -> SQLite b -> SQLite c
$cliftA2 :: forall a b c. (a -> b -> c) -> SQLite a -> SQLite b -> SQLite c
<*> :: forall a b. SQLite (a -> b) -> SQLite a -> SQLite b
$c<*> :: forall a b. SQLite (a -> b) -> SQLite a -> SQLite b
pure :: forall a. a -> SQLite a
$cpure :: forall a. a -> SQLite a
Applicative, Applicative SQLite
forall a. a -> SQLite a
forall a b. SQLite a -> SQLite b -> SQLite b
forall a b. SQLite a -> (a -> SQLite b) -> SQLite b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> SQLite a
$creturn :: forall a. a -> SQLite a
>> :: forall a b. SQLite a -> SQLite b -> SQLite b
$c>> :: forall a b. SQLite a -> SQLite b -> SQLite b
>>= :: forall a b. SQLite a -> (a -> SQLite b) -> SQLite b
$c>>= :: forall a b. SQLite a -> (a -> SQLite b) -> SQLite b
Monad, Monad SQLite
forall a. IO a -> SQLite a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> SQLite a
$cliftIO :: forall a. IO a -> SQLite a
MonadIO, Monad SQLite
forall a. String -> SQLite a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> SQLite a
$cfail :: forall a. String -> SQLite a
MonadFail, MonadIO SQLite
forall b. ((forall a. SQLite a -> IO a) -> IO b) -> SQLite b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b. ((forall a. SQLite a -> IO a) -> IO b) -> SQLite b
$cwithRunInIO :: forall b. ((forall a. SQLite a -> IO a) -> IO b) -> SQLite b
MonadUnliftIO)
  via ReaderT SQLiteStuff IO

instance Semigroup a => Semigroup (SQLite a) where
  SQLite a
a <> :: SQLite a -> SQLite a -> SQLite a
<> SQLite a
b = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SQLite a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SQLite a
b

instance Monoid a => Monoid (SQLite a) where
  mempty :: SQLite a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

data SQLiteStuff
  = SQLiteStuff
    { SQLiteStuff -> Database
dbConn :: Database
    , SQLiteStuff -> Maybe Int
transactionNumber :: Maybe Int
    }

getDB :: SQLite Database
getDB :: SQLite Database
getDB = forall a. (SQLiteStuff -> IO a) -> SQLite a
SQLite (\(SQLiteStuff Database
dbConn Maybe Int
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Database
dbConn)

runSQLite :: Database -> SQLite a -> IO a
runSQLite :: forall a. Database -> SQLite a -> IO a
runSQLite Database
db SQLite a
t = (forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite SQLite a
t) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
db forall a. Maybe a
Nothing)

-- | Run operations as a transaction.
--   If the action throws an error, the transaction is rolled back.
--   For more information, visit: <https://www.sqlite.org/lang_transaction.html>
transaction :: forall a. Typeable a => SQLite a -> SQLite a
transaction :: forall a. Typeable a => SQLite a -> SQLite a
transaction SQLite a
action = do
  SQLiteStuff {Maybe Int
Database
transactionNumber :: Maybe Int
dbConn :: Database
transactionNumber :: SQLiteStuff -> Maybe Int
dbConn :: SQLiteStuff -> Database
..} <- forall a. (SQLiteStuff -> IO a) -> SQLite a
SQLite forall a b. (a -> b) -> a -> b
$ \SQLiteStuff
stuff -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SQLiteStuff
stuff
  case Maybe Int
transactionNumber of
    Maybe Int
Nothing -> do
      let
        runIO :: SQL -> IO [[SQLData]]
runIO SQL
sql = (forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite (SQL -> SQLite [[SQLData]]
run SQL
sql)) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
dbConn forall a. Maybe a
Nothing)
        commit :: IO [[SQLData]]
commit = SQL -> IO [[SQLData]]
runIO SQL
"COMMIT"
        rollback' :: IO [[SQLData]]
rollback' = SQL -> IO [[SQLData]]
runIO SQL
"ROLLBACK"
      [] <- SQL -> SQLite [[SQLData]]
run SQL
"BEGIN"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> [Handler a] -> IO a
catches
        ((forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite SQLite a
action) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
dbConn (forall a. a -> Maybe a
Just Int
1)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO [[SQLData]]
commit)
        [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(RollbackCurrent a
a) -> IO [[SQLData]]
rollback' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(RollbackAll a
a) -> IO [[SQLData]]
rollback' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) -> IO [[SQLData]]
rollback' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e a. Exception e => e -> IO a
throwIO SomeException
ex
        ]
    Just Int
n -> do
      let
        runIO :: SQL -> IO [[SQLData]]
runIO SQL
sql = (forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite (SQL -> SQLite [[SQLData]]
run SQL
sql)) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
dbConn forall a. Maybe a
Nothing)
        transactionName :: SQL
transactionName = SQL
"'sqlite_easy_transaction_" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Int
n) forall a. Semigroup a => a -> a -> a
<> SQL
"'"
        release :: IO [[SQLData]]
release = SQL -> IO [[SQLData]]
runIO forall a b. (a -> b) -> a -> b
$ SQL
"RELEASE SAVEPOINT " forall a. Semigroup a => a -> a -> a
<> SQL
transactionName
        rollbackCurrent :: IO [[SQLData]]
rollbackCurrent = SQL -> IO [[SQLData]]
runIO forall a b. (a -> b) -> a -> b
$ SQL
"ROLLBACK TRANSACTION TO SAVEPOINT " forall a. Semigroup a => a -> a -> a
<> SQL
transactionName
      [] <- SQL -> SQLite [[SQLData]]
run forall a b. (a -> b) -> a -> b
$ SQL
"SAVEPOINT " forall a. Semigroup a => a -> a -> a
<> SQL
transactionName
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> [Handler a] -> IO a
catches
        ((forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite SQLite a
action) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
dbConn (forall a. a -> Maybe a
Just (Int
n forall a. Num a => a -> a -> a
+ Int
1))) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO [[SQLData]]
release)
        [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(RollbackCurrent a
a) -> IO [[SQLData]]
rollbackCurrent forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(RollbackAll a
ex :: RollbackAll a) -> IO [[SQLData]]
rollbackCurrent forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e a. Exception e => e -> IO a
throwIO RollbackAll a
ex
        , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) -> IO [[SQLData]]
rollbackCurrent forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e a. Exception e => e -> IO a
throwIO SomeException
ex
        ]

asTransaction' :: Database -> IO a -> IO a
asTransaction' :: forall a. Database -> IO a -> IO a
asTransaction' Database
db IO a
action = do
  let
    runIO :: SQL -> IO [[SQLData]]
runIO SQL
sql = (forall a. SQLite a -> SQLiteStuff -> IO a
unSQLite (SQL -> SQLite [[SQLData]]
run SQL
sql)) (Database -> Maybe Int -> SQLiteStuff
SQLiteStuff Database
db forall a. Maybe a
Nothing)
  [] <- SQL -> IO [[SQLData]]
runIO SQL
"BEGIN"
  forall a. IO a -> [Handler a] -> IO a
catches
    (IO a
action forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* SQL -> IO [[SQLData]]
runIO SQL
"COMMIT")
    [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) -> SQL -> IO [[SQLData]]
runIO SQL
"ROLLBACK" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e a. Exception e => e -> IO a
throwIO SomeException
ex
    ]

-- | Rollback the current (inner-most) transaction by supplying the return value.
--   To be used inside transactions.
rollback :: Typeable a => a -> SQLite a
rollback :: forall a. Typeable a => a -> SQLite a
rollback = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> RollbackCurrent a
RollbackCurrent

-- | Rollback all transaction structure by supplying the return value.
--   To be used inside transactions.
rollbackAll :: Typeable a => a -> SQLite a
rollbackAll :: forall a. Typeable a => a -> SQLite a
rollbackAll = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> RollbackAll a
RollbackAll

data RollbackCurrent a
  = RollbackCurrent a

instance Show (RollbackCurrent a) where
  show :: RollbackCurrent a -> String
show RollbackCurrent{} = String
"RollbackCurrent"

instance (Typeable a) => Exception (RollbackCurrent a)

data RollbackAll a
  = RollbackAll a

instance Show (RollbackAll a) where
  show :: RollbackAll a -> String
show RollbackAll{} = String
"RollbackAll"

instance (Typeable a) => Exception (RollbackAll a)