{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, TypeFamilies #-}
-- | Internal backend API.
--   Using anything exported from this module may or may not invalidate any
--   safety guarantees made by Selda; use at your own peril.
module Database.Selda.Backend.Internal
  ( StmtID (..), BackendID (..)
  , QueryRunner, SeldaBackend (..), SeldaConnection (..), SeldaStmt (..)
  , MonadSelda (..), SeldaT (..), SeldaM
  , SeldaError (..)
  , Param (..), Lit (..), ColAttr (..), AutoIncType (..)
  , SqlType (..), SqlValue (..), SqlTypeRep (..)
  , PPConfig (..), defPPConfig
  , TableInfo (..), ColumnInfo (..), tableInfo, fromColInfo
  , isAutoPrimary, isPrimary, isUnique
  , sqlDateTimeFormat, sqlDateFormat, sqlTimeFormat
  , freshStmtId
  , newConnection, allStmts
  , runSeldaT, withBackend
  ) where
import Data.List (nub)
import Database.Selda.SQL (Param (..))
import Database.Selda.SqlType
    ( SqlValue(..),
      Lit(..),
      SqlType(..),
      SqlTypeRep(..),
      sqlDateTimeFormat,
      sqlDateFormat,
      sqlTimeFormat )
import Database.Selda.Table.Type
    ( ColAttr(..),
      AutoIncType(..),
      Table(Table, tableAttrs, tableName, tableCols),
      isAutoPrimary,
      isPrimary,
      isUnique )
import qualified Database.Selda.Table.Type as Table ( ColInfo(..) )
import Database.Selda.SQL.Print.Config
    ( PPConfig(..), defPPConfig )
import Database.Selda.Types (TableName, ColName)
import Data.Int (Int64)
import Control.Concurrent ( newMVar, putMVar, takeMVar, MVar )
import Control.Monad.Catch
    ( Exception, bracket, MonadCatch, MonadMask, MonadThrow(..) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Reader
    ( MonadTrans(..), when, ReaderT(..), MonadReader(ask) )
import Data.Dynamic ( Typeable, Dynamic )
import qualified Data.IntMap as M
import Data.IORef
    ( IORef, atomicModifyIORef', newIORef, readIORef )
import Data.Text (Text)
import System.IO.Unsafe (unsafePerformIO)




-- | Uniquely identifies some particular backend.
--
--   When publishing a new backend, consider submitting a pull request with a
--   constructor for your backend instead of using the @Other@ constructor.
data BackendID = SQLite | PostgreSQL | Other Text
  deriving (Int -> BackendID -> ShowS
[BackendID] -> ShowS
BackendID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BackendID] -> ShowS
$cshowList :: [BackendID] -> ShowS
show :: BackendID -> String
$cshow :: BackendID -> String
showsPrec :: Int -> BackendID -> ShowS
$cshowsPrec :: Int -> BackendID -> ShowS
Show, BackendID -> BackendID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BackendID -> BackendID -> Bool
$c/= :: BackendID -> BackendID -> Bool
== :: BackendID -> BackendID -> Bool
$c== :: BackendID -> BackendID -> Bool
Eq, Eq BackendID
BackendID -> BackendID -> Bool
BackendID -> BackendID -> Ordering
BackendID -> BackendID -> BackendID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BackendID -> BackendID -> BackendID
$cmin :: BackendID -> BackendID -> BackendID
max :: BackendID -> BackendID -> BackendID
$cmax :: BackendID -> BackendID -> BackendID
>= :: BackendID -> BackendID -> Bool
$c>= :: BackendID -> BackendID -> Bool
> :: BackendID -> BackendID -> Bool
$c> :: BackendID -> BackendID -> Bool
<= :: BackendID -> BackendID -> Bool
$c<= :: BackendID -> BackendID -> Bool
< :: BackendID -> BackendID -> Bool
$c< :: BackendID -> BackendID -> Bool
compare :: BackendID -> BackendID -> Ordering
$ccompare :: BackendID -> BackendID -> Ordering
Ord)

-- | Thrown by any function in 'SeldaT' if an error occurs.
data SeldaError
  = DbError String     -- ^ Unable to open or connect to database.
  | SqlError String    -- ^ An error occurred while executing query.
  | UnsafeError String -- ^ An error occurred due to improper use of an unsafe
                       --   function.
  deriving (Int -> SeldaError -> ShowS
[SeldaError] -> ShowS
SeldaError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SeldaError] -> ShowS
$cshowList :: [SeldaError] -> ShowS
show :: SeldaError -> String
$cshow :: SeldaError -> String
showsPrec :: Int -> SeldaError -> ShowS
$cshowsPrec :: Int -> SeldaError -> ShowS
Show, SeldaError -> SeldaError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SeldaError -> SeldaError -> Bool
$c/= :: SeldaError -> SeldaError -> Bool
== :: SeldaError -> SeldaError -> Bool
$c== :: SeldaError -> SeldaError -> Bool
Eq, Typeable)

instance Exception SeldaError

-- | A prepared statement identifier. Guaranteed to be unique per application.
newtype StmtID = StmtID Int
  deriving (Int -> StmtID -> ShowS
[StmtID] -> ShowS
StmtID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StmtID] -> ShowS
$cshowList :: [StmtID] -> ShowS
show :: StmtID -> String
$cshow :: StmtID -> String
showsPrec :: Int -> StmtID -> ShowS
$cshowsPrec :: Int -> StmtID -> ShowS
Show, StmtID -> StmtID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StmtID -> StmtID -> Bool
$c/= :: StmtID -> StmtID -> Bool
== :: StmtID -> StmtID -> Bool
$c== :: StmtID -> StmtID -> Bool
Eq, Eq StmtID
StmtID -> StmtID -> Bool
StmtID -> StmtID -> Ordering
StmtID -> StmtID -> StmtID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StmtID -> StmtID -> StmtID
$cmin :: StmtID -> StmtID -> StmtID
max :: StmtID -> StmtID -> StmtID
$cmax :: StmtID -> StmtID -> StmtID
>= :: StmtID -> StmtID -> Bool
$c>= :: StmtID -> StmtID -> Bool
> :: StmtID -> StmtID -> Bool
$c> :: StmtID -> StmtID -> Bool
<= :: StmtID -> StmtID -> Bool
$c<= :: StmtID -> StmtID -> Bool
< :: StmtID -> StmtID -> Bool
$c< :: StmtID -> StmtID -> Bool
compare :: StmtID -> StmtID -> Ordering
$ccompare :: StmtID -> StmtID -> Ordering
Ord)

-- | A connection identifier. Guaranteed to be unique per application.
newtype ConnID = ConnID Int
  deriving (Int -> ConnID -> ShowS
[ConnID] -> ShowS
ConnID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnID] -> ShowS
$cshowList :: [ConnID] -> ShowS
show :: ConnID -> String
$cshow :: ConnID -> String
showsPrec :: Int -> ConnID -> ShowS
$cshowsPrec :: Int -> ConnID -> ShowS
Show, ConnID -> ConnID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnID -> ConnID -> Bool
$c/= :: ConnID -> ConnID -> Bool
== :: ConnID -> ConnID -> Bool
$c== :: ConnID -> ConnID -> Bool
Eq, Eq ConnID
ConnID -> ConnID -> Bool
ConnID -> ConnID -> Ordering
ConnID -> ConnID -> ConnID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConnID -> ConnID -> ConnID
$cmin :: ConnID -> ConnID -> ConnID
max :: ConnID -> ConnID -> ConnID
$cmax :: ConnID -> ConnID -> ConnID
>= :: ConnID -> ConnID -> Bool
$c>= :: ConnID -> ConnID -> Bool
> :: ConnID -> ConnID -> Bool
$c> :: ConnID -> ConnID -> Bool
<= :: ConnID -> ConnID -> Bool
$c<= :: ConnID -> ConnID -> Bool
< :: ConnID -> ConnID -> Bool
$c< :: ConnID -> ConnID -> Bool
compare :: ConnID -> ConnID -> Ordering
$ccompare :: ConnID -> ConnID -> Ordering
Ord)

{-# NOINLINE nextStmtId #-}
nextStmtId :: IORef Int
nextStmtId :: IORef Int
nextStmtId = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Int
1

-- | Generate a fresh statement identifier, guaranteed to be unique per process.
freshStmtId :: MonadIO m => m StmtID
freshStmtId :: forall (m :: * -> *). MonadIO m => m StmtID
freshStmtId = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
nextStmtId forall a b. (a -> b) -> a -> b
$ \Int
n -> (Int
nforall a. Num a => a -> a -> a
+Int
1, Int -> StmtID
StmtID Int
n)

-- | A function which executes a query and gives back a list of extensible
--   tuples; one tuple per result row, and one tuple element per column.
type QueryRunner a = Text -> [Param] -> IO a

-- | A prepared statement.
data SeldaStmt = SeldaStmt
 { -- | Backend-specific handle to the prepared statement.
   SeldaStmt -> Dynamic
stmtHandle :: !Dynamic

   -- | The SQL code for the statement.
 , SeldaStmt -> Text
stmtText :: !Text

   -- | All parameters to be passed to the prepared statement.
   --   Parameters that are unique to each invocation are specified as indices
   --   starting at 0.
   --   Backends implementing @runPrepared@ should probably ignore this field.
 , SeldaStmt -> [Either Int Param]
stmtParams :: ![Either Int Param]
 }

data SeldaConnection b = SeldaConnection
  { -- | The backend used by the current connection.
    forall b. SeldaConnection b -> SeldaBackend b
connBackend :: !(SeldaBackend b)

    -- | A string uniquely identifying the database used by this connection.
    --   This could be, for instance, a PostgreSQL connection
    --   string or the absolute path to an SQLite file.
  , forall b. SeldaConnection b -> Text
connDbId :: Text

    -- | All statements prepared for this connection.
  , forall b. SeldaConnection b -> IORef (IntMap SeldaStmt)
connStmts :: !(IORef (M.IntMap SeldaStmt))

    -- | Is the connection closed?
  , forall b. SeldaConnection b -> IORef Bool
connClosed :: !(IORef Bool)

    -- | Lock to prevent this connection from being used concurrently by
    --   multiple invocations of 'runSeldaT'.
  , forall b. SeldaConnection b -> MVar ()
connLock :: !(MVar ())
}

-- | Create a new Selda connection for the given backend and database
--   identifier string.
newConnection :: MonadIO m => SeldaBackend b -> Text -> m (SeldaConnection b)
newConnection :: forall (m :: * -> *) b.
MonadIO m =>
SeldaBackend b -> Text -> m (SeldaConnection b)
newConnection SeldaBackend b
back Text
dbid =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b.
SeldaBackend b
-> Text
-> IORef (IntMap SeldaStmt)
-> IORef Bool
-> MVar ()
-> SeldaConnection b
SeldaConnection SeldaBackend b
back Text
dbid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. IntMap a
M.empty
                                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Bool
False
                                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (MVar a)
newMVar ()

-- | Get all statements and their corresponding identifiers for the current
--   connection.
allStmts :: SeldaConnection b -> IO [(StmtID, Dynamic)]
allStmts :: forall b. SeldaConnection b -> IO [(StmtID, Dynamic)]
allStmts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (\(Int
k, SeldaStmt
v) -> (Int -> StmtID
StmtID Int
k, SeldaStmt -> Dynamic
stmtHandle SeldaStmt
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
M.toList)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. SeldaConnection b -> IORef (IntMap SeldaStmt)
connStmts

-- | Comprehensive information about a table.
data TableInfo = TableInfo
  { -- | Name of the table.
    TableInfo -> TableName
tableInfoName :: TableName
    -- | Ordered information about each table column.
  , TableInfo -> [ColumnInfo]
tableColumnInfos :: [ColumnInfo]
    -- | Unordered list of all (non-PK) uniqueness constraints on this table.
  , TableInfo -> [[ColName]]
tableUniqueGroups :: [[ColName]]
    -- | Unordered list of all primary key constraints on this table.
  , TableInfo -> [ColName]
tablePrimaryKey :: [ColName]
  } deriving (Int -> TableInfo -> ShowS
[TableInfo] -> ShowS
TableInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TableInfo] -> ShowS
$cshowList :: [TableInfo] -> ShowS
show :: TableInfo -> String
$cshow :: TableInfo -> String
showsPrec :: Int -> TableInfo -> ShowS
$cshowsPrec :: Int -> TableInfo -> ShowS
Show, TableInfo -> TableInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TableInfo -> TableInfo -> Bool
$c/= :: TableInfo -> TableInfo -> Bool
== :: TableInfo -> TableInfo -> Bool
$c== :: TableInfo -> TableInfo -> Bool
Eq)

-- | Comprehensive information about a column.
data ColumnInfo = ColumnInfo
  { -- | Name of the column.
    ColumnInfo -> ColName
colName :: ColName
    -- | Selda type of the column, or the type name given by the database
    --   if Selda couldn't make sense of the type.
  , ColumnInfo -> Either Text SqlTypeRep
colType :: Either Text SqlTypeRep
    -- | Is the given column auto-incrementing?
  , ColumnInfo -> Bool
colIsAutoPrimary :: Bool
    -- | Can the column be NULL?
  , ColumnInfo -> Bool
colIsNullable :: Bool
    -- | Is the column explicitly indexed (i.e. using 'indexed')?
  , ColumnInfo -> Bool
colHasIndex :: Bool
    -- | Any foreign key (table, column) pairs referenced by this column.
  , ColumnInfo -> [(TableName, ColName)]
colFKs :: [(TableName, ColName)]
  } deriving (Int -> ColumnInfo -> ShowS
[ColumnInfo] -> ShowS
ColumnInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColumnInfo] -> ShowS
$cshowList :: [ColumnInfo] -> ShowS
show :: ColumnInfo -> String
$cshow :: ColumnInfo -> String
showsPrec :: Int -> ColumnInfo -> ShowS
$cshowsPrec :: Int -> ColumnInfo -> ShowS
Show, ColumnInfo -> ColumnInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColumnInfo -> ColumnInfo -> Bool
$c/= :: ColumnInfo -> ColumnInfo -> Bool
== :: ColumnInfo -> ColumnInfo -> Bool
$c== :: ColumnInfo -> ColumnInfo -> Bool
Eq)

-- | Convert a 'Table.ColInfo' into a 'ColumnInfo'.
fromColInfo :: Table.ColInfo -> ColumnInfo
fromColInfo :: ColInfo -> ColumnInfo
fromColInfo ColInfo
ci = ColumnInfo
    { colName :: ColName
colName = ColInfo -> ColName
Table.colName ColInfo
ci
    , colType :: Either Text SqlTypeRep
colType = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ColInfo -> SqlTypeRep
Table.colType ColInfo
ci
    , colIsAutoPrimary :: Bool
colIsAutoPrimary = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ColAttr -> Bool
isAutoPrimary (ColInfo -> [ColAttr]
Table.colAttrs ColInfo
ci)
    , colIsNullable :: Bool
colIsNullable = ColAttr
Optional forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ColInfo -> [ColAttr]
Table.colAttrs ColInfo
ci
    , colHasIndex :: Bool
colHasIndex = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [() | Indexed Maybe IndexMethod
_ <- ColInfo -> [ColAttr]
Table.colAttrs ColInfo
ci]
    , colFKs :: [(TableName, ColName)]
colFKs = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. (Table a, b) -> (TableName, b)
fk (ColInfo -> [(Table (), ColName)]
Table.colFKs ColInfo
ci)
    }
  where
    fk :: (Table a, b) -> (TableName, b)
fk (Table TableName
tbl [ColInfo]
_ Bool
_ [([Int], ColAttr)]
_, b
col) = (TableName
tbl, b
col)

-- | Get the column information for each column in the given table.
tableInfo :: Table a -> TableInfo
tableInfo :: forall a. Table a -> TableInfo
tableInfo Table a
t = TableInfo
  { tableInfoName :: TableName
tableInfoName = forall a. Table a -> TableName
tableName Table a
t
  , tableColumnInfos :: [ColumnInfo]
tableColumnInfos = forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> ColumnInfo
fromColInfo (forall a. Table a -> [ColInfo]
tableCols Table a
t)
  , tableUniqueGroups :: [[ColName]]
tableUniqueGroups = [[ColName]]
uniqueGroups
  , tablePrimaryKey :: [ColName]
tablePrimaryKey = [ColName]
pkGroup
  }
  where
    uniqueGroups :: [[ColName]]
uniqueGroups =
      [ forall a b. (a -> b) -> [a] -> [b]
map (ColInfo -> ColName
Table.colName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Table a -> [ColInfo]
tableCols Table a
t) forall a. [a] -> Int -> a
!!)) [Int]
ixs
      | ([Int]
ixs, ColAttr
Unique) <- forall a. Table a -> [([Int], ColAttr)]
tableAttrs Table a
t
      ]
    pkGroup :: [ColName]
pkGroup = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall a b. (a -> b) -> [a] -> [b]
map (ColInfo -> ColName
Table.colName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Table a -> [ColInfo]
tableCols Table a
t) forall a. [a] -> Int -> a
!!)) [Int]
ixs
        | ([Int]
ixs, ColAttr
attr) <- forall a. Table a -> [([Int], ColAttr)]
tableAttrs Table a
t
        , ColAttr -> Bool
isPrimary ColAttr
attr
        ]
      , [ ColInfo -> ColName
Table.colName ColInfo
col
        | ColInfo
col <- forall a. Table a -> [ColInfo]
tableCols Table a
t
        , ColAttr
attr <- ColInfo -> [ColAttr]
Table.colAttrs ColInfo
col
        , ColAttr -> Bool
isPrimary ColAttr
attr
        ]
      ]

-- | A collection of functions making up a Selda backend.
data SeldaBackend b = SeldaBackend
  { -- | Execute an SQL statement.
    forall b.
SeldaBackend b -> Text -> [Param] -> IO (Int, [[SqlValue]])
runStmt :: Text -> [Param] -> IO (Int, [[SqlValue]])

    -- | Execute an SQL statement and return the last inserted primary key,
    --   where the primary key is auto-incrementing.
    --   Backends must take special care to make this thread-safe.
  , forall b. SeldaBackend b -> Text -> [Param] -> IO Int64
runStmtWithPK :: Text -> [Param] -> IO Int64

    -- | Prepare a statement using the given statement identifier.
  , forall b.
SeldaBackend b -> StmtID -> [SqlTypeRep] -> Text -> IO Dynamic
prepareStmt :: StmtID -> [SqlTypeRep] -> Text -> IO Dynamic

    -- | Execute a prepared statement.
  , forall b.
SeldaBackend b -> Dynamic -> [Param] -> IO (Int, [[SqlValue]])
runPrepared :: Dynamic -> [Param] -> IO (Int, [[SqlValue]])

    -- | Get a list of all columns in the given table, with the type and any
    --   modifiers for each column.
    --   Return an empty list if the given table does not exist.
  , forall b. SeldaBackend b -> TableName -> IO TableInfo
getTableInfo :: TableName -> IO TableInfo

    -- | SQL pretty-printer configuration.
  , forall b. SeldaBackend b -> PPConfig
ppConfig :: PPConfig

    -- | Close the currently open connection.
  , forall b. SeldaBackend b -> SeldaConnection b -> IO ()
closeConnection :: SeldaConnection b -> IO ()

    -- | Unique identifier for this backend.
  , forall b. SeldaBackend b -> BackendID
backendId :: BackendID

    -- | Turn on or off foreign key checking, and initiate/commit
    --   a transaction.
    --
    --   When implementing this function, it is safe to assume that
    --   @disableForeignKeys True@
    --   will always be called exactly once before each
    --   @disableForeignKeys False@.
  , forall b. SeldaBackend b -> Bool -> IO ()
disableForeignKeys :: Bool -> IO ()
  }

-- | Some monad with Selda SQL capabilitites.
class MonadIO m => MonadSelda m where
  {-# MINIMAL withConnection #-}

  -- | Type of database backend used by @m@.
  type Backend m

  -- | Pass a Selda connection to the given computation and execute it.
  --   After the computation finishes, @withConnection@ is free to do anything
  --   it likes to the connection, including closing it or giving it to another
  --   Selda computation.
  --   Thus, the computation must take care never to return or otherwise
  --   access the connection after returning.
  withConnection :: (SeldaConnection (Backend m) -> m a) -> m a

  -- | Perform the given computation as a transaction.
  --   Implementations must ensure that subsequent calls to 'withConnection'
  --   within the same transaction always passes the same connection
  --   to its argument.
  transact :: m a -> m a
  transact = forall a. a -> a
id

-- | Get the backend in use by the computation.
withBackend :: MonadSelda m => (SeldaBackend (Backend m) -> m a) -> m a
withBackend :: forall (m :: * -> *) a.
MonadSelda m =>
(SeldaBackend (Backend m) -> m a) -> m a
withBackend SeldaBackend (Backend m) -> m a
m = forall (m :: * -> *) a.
MonadSelda m =>
(SeldaConnection (Backend m) -> m a) -> m a
withConnection (SeldaBackend (Backend m) -> m a
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. SeldaConnection b -> SeldaBackend b
connBackend)

-- | Monad transformer adding Selda SQL capabilities.
newtype SeldaT b m a = S {forall b (m :: * -> *) a.
SeldaT b m a -> ReaderT (SeldaConnection b) m a
unS :: ReaderT (SeldaConnection b) m a}
  deriving ( forall a b. a -> SeldaT b m b -> SeldaT b m a
forall a b. (a -> b) -> SeldaT b m a -> SeldaT b m b
forall b (m :: * -> *) a b.
Functor m =>
a -> SeldaT b m b -> SeldaT b m a
forall b (m :: * -> *) a b.
Functor m =>
(a -> b) -> SeldaT b m a -> SeldaT b m 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 -> SeldaT b m b -> SeldaT b m a
$c<$ :: forall b (m :: * -> *) a b.
Functor m =>
a -> SeldaT b m b -> SeldaT b m a
fmap :: forall a b. (a -> b) -> SeldaT b m a -> SeldaT b m b
$cfmap :: forall b (m :: * -> *) a b.
Functor m =>
(a -> b) -> SeldaT b m a -> SeldaT b m b
Functor, forall a. a -> SeldaT b m a
forall a b. SeldaT b m a -> SeldaT b m b -> SeldaT b m a
forall a b. SeldaT b m a -> SeldaT b m b -> SeldaT b m b
forall a b. SeldaT b m (a -> b) -> SeldaT b m a -> SeldaT b m b
forall a b c.
(a -> b -> c) -> SeldaT b m a -> SeldaT b m b -> SeldaT b m c
forall {b} {m :: * -> *}. Applicative m => Functor (SeldaT b m)
forall b (m :: * -> *) a. Applicative m => a -> SeldaT b m a
forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m a
forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m b
forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m (a -> b) -> SeldaT b m a -> SeldaT b m b
forall b (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SeldaT b m a -> SeldaT b m b -> SeldaT b m 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. SeldaT b m a -> SeldaT b m b -> SeldaT b m a
$c<* :: forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m a
*> :: forall a b. SeldaT b m a -> SeldaT b m b -> SeldaT b m b
$c*> :: forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m b
liftA2 :: forall a b c.
(a -> b -> c) -> SeldaT b m a -> SeldaT b m b -> SeldaT b m c
$cliftA2 :: forall b (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SeldaT b m a -> SeldaT b m b -> SeldaT b m c
<*> :: forall a b. SeldaT b m (a -> b) -> SeldaT b m a -> SeldaT b m b
$c<*> :: forall b (m :: * -> *) a b.
Applicative m =>
SeldaT b m (a -> b) -> SeldaT b m a -> SeldaT b m b
pure :: forall a. a -> SeldaT b m a
$cpure :: forall b (m :: * -> *) a. Applicative m => a -> SeldaT b m a
Applicative, forall a. a -> SeldaT b m a
forall a b. SeldaT b m a -> SeldaT b m b -> SeldaT b m b
forall a b. SeldaT b m a -> (a -> SeldaT b m b) -> SeldaT b m b
forall {b} {m :: * -> *}. Monad m => Applicative (SeldaT b m)
forall b (m :: * -> *) a. Monad m => a -> SeldaT b m a
forall b (m :: * -> *) a b.
Monad m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m b
forall b (m :: * -> *) a b.
Monad m =>
SeldaT b m a -> (a -> SeldaT b m b) -> SeldaT b m 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 -> SeldaT b m a
$creturn :: forall b (m :: * -> *) a. Monad m => a -> SeldaT b m a
>> :: forall a b. SeldaT b m a -> SeldaT b m b -> SeldaT b m b
$c>> :: forall b (m :: * -> *) a b.
Monad m =>
SeldaT b m a -> SeldaT b m b -> SeldaT b m b
>>= :: forall a b. SeldaT b m a -> (a -> SeldaT b m b) -> SeldaT b m b
$c>>= :: forall b (m :: * -> *) a b.
Monad m =>
SeldaT b m a -> (a -> SeldaT b m b) -> SeldaT b m b
Monad, forall a. IO a -> SeldaT b m a
forall {b} {m :: * -> *}. MonadIO m => Monad (SeldaT b m)
forall b (m :: * -> *) a. MonadIO m => IO a -> SeldaT b m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> SeldaT b m a
$cliftIO :: forall b (m :: * -> *) a. MonadIO m => IO a -> SeldaT b m a
MonadIO
           , forall e a. Exception e => e -> SeldaT b m a
forall {b} {m :: * -> *}. MonadThrow m => Monad (SeldaT b m)
forall b (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SeldaT b m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> SeldaT b m a
$cthrowM :: forall b (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SeldaT b m a
MonadThrow, forall e a.
Exception e =>
SeldaT b m a -> (e -> SeldaT b m a) -> SeldaT b m a
forall {b} {m :: * -> *}. MonadCatch m => MonadThrow (SeldaT b m)
forall b (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SeldaT b m a -> (e -> SeldaT b m a) -> SeldaT b m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
SeldaT b m a -> (e -> SeldaT b m a) -> SeldaT b m a
$ccatch :: forall b (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SeldaT b m a -> (e -> SeldaT b m a) -> SeldaT b m a
MonadCatch, forall b.
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
forall a b c.
SeldaT b m a
-> (a -> ExitCase b -> SeldaT b m c)
-> (a -> SeldaT b m b)
-> SeldaT b m (b, c)
forall {b} {m :: * -> *}. MonadMask m => MonadCatch (SeldaT b m)
forall b (m :: * -> *) b.
MonadMask m =>
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
forall b (m :: * -> *) a b c.
MonadMask m =>
SeldaT b m a
-> (a -> ExitCase b -> SeldaT b m c)
-> (a -> SeldaT b m b)
-> SeldaT b m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
SeldaT b m a
-> (a -> ExitCase b -> SeldaT b m c)
-> (a -> SeldaT b m b)
-> SeldaT b m (b, c)
$cgeneralBracket :: forall b (m :: * -> *) a b c.
MonadMask m =>
SeldaT b m a
-> (a -> ExitCase b -> SeldaT b m c)
-> (a -> SeldaT b m b)
-> SeldaT b m (b, c)
uninterruptibleMask :: forall b.
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
$cuninterruptibleMask :: forall b (m :: * -> *) b.
MonadMask m =>
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
mask :: forall b.
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
$cmask :: forall b (m :: * -> *) b.
MonadMask m =>
((forall a. SeldaT b m a -> SeldaT b m a) -> SeldaT b m b)
-> SeldaT b m b
MonadMask , forall a. String -> SeldaT b m a
forall {b} {m :: * -> *}. MonadFail m => Monad (SeldaT b m)
forall b (m :: * -> *) a. MonadFail m => String -> SeldaT b m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> SeldaT b m a
$cfail :: forall b (m :: * -> *) a. MonadFail m => String -> SeldaT b m a
MonadFail
           )

instance (MonadIO m, MonadMask m) => MonadSelda (SeldaT b m) where
  type Backend (SeldaT b m) = b
  withConnection :: forall a.
(SeldaConnection (Backend (SeldaT b m)) -> SeldaT b m a)
-> SeldaT b m a
withConnection SeldaConnection (Backend (SeldaT b m)) -> SeldaT b m a
m = forall b (m :: * -> *) a.
ReaderT (SeldaConnection b) m a -> SeldaT b m a
S forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SeldaConnection (Backend (SeldaT b m)) -> SeldaT b m a
m

instance MonadTrans (SeldaT b) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> SeldaT b m a
lift = forall b (m :: * -> *) a.
ReaderT (SeldaConnection b) m a -> SeldaT b m a
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | The simplest form of Selda computation; 'SeldaT' specialized to 'IO'.
type SeldaM b = SeldaT b IO

-- | Run a Selda transformer. Backends should use this to implement their
--   @withX@ functions.
runSeldaT :: (MonadIO m, MonadMask m)
          => SeldaT b m a
          -> SeldaConnection b
          -> m a
runSeldaT :: forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
SeldaT b m a -> SeldaConnection b -> m a
runSeldaT SeldaT b m a
m SeldaConnection b
c =
    forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar (forall b. SeldaConnection b -> MVar ()
connLock SeldaConnection b
c))
            (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar (forall b. SeldaConnection b -> MVar ()
connLock SeldaConnection b
c) ())
            (forall a b. a -> b -> a
const m a
go)
  where
    go :: m a
go = do
      Bool
closed <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (forall b. SeldaConnection b -> IORef Bool
connClosed SeldaConnection b
c)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> SeldaError
DbError String
"runSeldaT called with a closed connection"
      forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall b (m :: * -> *) a.
SeldaT b m a -> ReaderT (SeldaConnection b) m a
unS SeldaT b m a
m) SeldaConnection b
c