Frontend.hs

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-}
-- | API for running Selda operations over databases.
module Database.Selda.Frontend
  ( Result, Res, MonadIO (..), MonadSelda (..), SeldaT, OnError (..)
  , query, queryInto
  , insert, insert_, insertWithPK, tryInsert, insertWhen, insertUnless
  , update, update_, upsert
  , deleteFrom, deleteFrom_
  , createTable, tryCreateTable, createTableWithoutIndexes, createTableIndexes
  , dropTable, tryDropTable
  , transaction, withoutForeignKeyEnforcement
  ) where
import Database.Selda.Backend.Internal
    ( SqlValue,
      Param,
      SeldaT,
      MonadSelda(..),
      SeldaBackend(runStmtWithPK, disableForeignKeys, ppConfig, runStmt),
      QueryRunner,
      SeldaError(SqlError),
      withBackend )
import Database.Selda.Column ( Row, Col )
import Database.Selda.Compile
    ( Result,
      Res,
      compileWith,
      compileInsert,
      compileUpdate,
      compileDelete,
      buildResult )
import Database.Selda.Generic ( Relational )
import Database.Selda.Query.Type ( Query )
import Database.Selda.SqlType (ID, invalidId, toId)
import Database.Selda.Table.Type
    ( Table(tableName, tableHasAutoPK) )
import Database.Selda.Table.Compile
    ( OnError(..),
      compileCreateTable,
      compileCreateIndexes,
      compileDropTable )
import Database.Selda.Types (fromTableName)
import Data.Proxy ( Proxy(..) )
import Data.Text (Text)
import Control.Monad ( void )
import Control.Monad.Catch
    ( bracket_,
      onException,
      try,
      MonadCatch,
      MonadMask(mask),
      MonadThrow(throwM) )
import Control.Monad.IO.Class ( MonadIO(..) )

-- | Run a query within a Selda monad. In practice, this is often a 'SeldaT'
--   transformer on top of some other monad.
--   Selda transformers are entered using backend-specific @withX@ functions,
--   such as 'withSQLite' from the SQLite backend.
query :: (MonadSelda m, Result a) => Query (Backend m) a -> m [Res a]
query q = withBackend (flip queryWith q . runStmt)

-- | Perform the given query, and insert the result into the given table.
--   Returns the number of inserted rows.
queryInto :: (MonadSelda m, Relational a)
          => Table a
          -> Query (Backend m) (Row (Backend m) a)
          -> m Int
queryInto tbl q = withBackend $ \b -> do
    let (qry, ps) = compileWith (ppConfig b) q
        qry' = mconcat ["INSERT INTO ", tblName, " ", qry]
    fmap fst . liftIO $ runStmt b qry' ps
  where
    tblName = fromTableName (tableName tbl)

-- | Insert the given values into the given table. All columns of the table
--   must be present. If your table has an auto-incrementing primary key,
--   use the special value 'def' for that column to get the auto-incrementing
--   behavior.
--   Returns the number of rows that were inserted.
--
--   To insert a list of tuples into a table with auto-incrementing primary key:
--
-- > data Person = Person
-- >   { id :: ID Person
-- >   , name :: Text
-- >   , age :: Int
-- >   , pet :: Maybe Text
-- >   } deriving Generic
-- > instance SqlResult Person
-- >
-- > people :: Table Person
-- > people = table "people" [autoPrimary :- id]
-- >
-- > main = withSQLite "my_database.sqlite" $ do
-- >   insert_ people
-- >     [ Person def "Link" 125 (Just "horse")
-- >     , Person def "Zelda" 119 Nothing
-- >     , ...
-- >     ]
--
--   Note that if one or more of the inserted rows would cause a constraint
--   violation, NO rows will be inserted; the whole insertion fails atomically.
insert :: (MonadSelda m, Relational a) => Table a -> [a] -> m Int
insert _ [] = do
  return 0
insert t cs = withBackend $ \b -> do
  sum <$> mapM (uncurry exec) (compileInsert (ppConfig b) t cs)

-- | Attempt to insert a list of rows into a table, but don't raise an error
--   if the insertion fails. Returns @True@ if the insertion succeeded, otherwise
--   @False@.
--
--   Like 'insert', if even one of the inserted rows would cause a constraint
--   violation, the whole insert operation fails.
tryInsert :: (MonadSelda m, MonadCatch m, Relational a) => Table a -> [a] -> m Bool
tryInsert tbl row = do
  mres <- try $ insert tbl row
  case mres of
    Right _           -> return True
    Left (SqlError _) -> return False
    Left e            -> throwM e

-- | Attempt to perform the given update. If no rows were updated, insert the
--   given row.
--   Returns the primary key of the inserted row, if the insert was performed.
--   Calling this function on a table which does not have a primary key will
--   return @Just id@ on a successful insert, where @id@ is a row identifier
--   guaranteed to not match any row in any table.
--
--   Note that this may perform two separate queries: one update, potentially
--   followed by one insert.
upsert :: (MonadSelda m, MonadMask m, Relational a)
       => Table a
       -> (Row (Backend m) a -> Col (Backend m) Bool)
       -> (Row (Backend m) a -> Row (Backend m) a)
       -> [a]
       -> m (Maybe (ID a))
upsert tbl check upd rows = transaction $ do
  updated <- update tbl check upd
  if updated == 0
    then Just <$> insertWithPK tbl rows
    else pure Nothing

-- | Perform the given insert, if no rows already present in the table match
--   the given predicate.
--   Returns the primary key of the last inserted row,
--   if the insert was performed.
--   If called on a table which doesn't have an auto-incrementing primary key,
--   @Just id@ is always returned on successful insert, where @id@ is a row
--   identifier guaranteed to not match any row in any table.
insertUnless :: (MonadSelda m, MonadMask m, Relational a)
             => Table a
             -> (Row (Backend m) a -> Col (Backend m) Bool)
             -> [a]
             -> m (Maybe (ID a))
insertUnless tbl check rows = upsert tbl check id rows

-- | Like 'insertUnless', but performs the insert when at least one row matches
--   the predicate.
insertWhen :: (MonadSelda m, MonadMask m, Relational a)
           => Table a
           -> (Row (Backend m) a -> Col (Backend m) Bool)
           -> [a]
           -> m (Maybe (ID a))
insertWhen tbl check rows = transaction $ do
  matches <- update tbl check id
  if matches > 0
    then Just <$> insertWithPK tbl rows
    else pure Nothing

-- | Like 'insert', but does not return anything.
--   Use this when you really don't care about how many rows were inserted.
insert_ :: (MonadSelda m, Relational a) => Table a -> [a] -> m ()
insert_ t cs = void $ insert t cs

-- | Like 'insert', but returns the primary key of the last inserted row.
--   Attempting to run this operation on a table without an auto-incrementing
--   primary key will always return a row identifier that is guaranteed to not
--   match any row in any table.
insertWithPK :: (MonadSelda m, Relational a) => Table a -> [a] -> m (ID a)
insertWithPK t cs = withBackend $ \b -> do
  if tableHasAutoPK t
    then do
      res <- liftIO $ do
        mapM (uncurry (runStmtWithPK b)) $ compileInsert (ppConfig b) t cs
      return $ toId (last res)
    else do
      insert_ t cs
      return invalidId

-- | Update the given table using the given update function, for all rows
--   matching the given predicate. Returns the number of updated rows.
update :: (MonadSelda m, Relational a)
       => Table a                                     -- ^ Table to update.
       -> (Row (Backend m) a -> Col (Backend m) Bool) -- ^ Predicate.
       -> (Row (Backend m) a -> Row (Backend m) a)    -- ^ Update function.
       -> m Int
update tbl check upd = withBackend $ \b -> do
  res <- uncurry exec $ compileUpdate (ppConfig b) tbl upd check
  return res

-- | Like 'update', but doesn't return the number of updated rows.
update_ :: (MonadSelda m, Relational a)
       => Table a
       -> (Row (Backend m) a -> Col (Backend m) Bool)
       -> (Row (Backend m) a -> Row (Backend m) a)
       -> m ()
update_ tbl check upd = void $ update tbl check upd

-- | From the given table, delete all rows matching the given predicate.
--   Returns the number of deleted rows.
deleteFrom :: (MonadSelda m, Relational a)
           => Table a
           -> (Row (Backend m) a -> Col (Backend m) Bool)
           -> m Int
deleteFrom tbl f = withBackend $ \b -> do
  res <- uncurry exec $ compileDelete (ppConfig b) tbl f
  return res

-- | Like 'deleteFrom', but does not return the number of deleted rows.
deleteFrom_ :: (MonadSelda m, Relational a)
            => Table a
            -> (Row (Backend m) a -> Col (Backend m) Bool)
            -> m ()
deleteFrom_ tbl f = void $ deleteFrom tbl f

-- | Create a table from the given schema.
createTable :: MonadSelda m => Table a -> m ()
createTable tbl = do
  createTableWithoutIndexes Fail tbl
  createTableIndexes Fail tbl

-- | Create a table from the given schema, but don't create any indexes.
createTableWithoutIndexes :: MonadSelda m => OnError -> Table a -> m ()
createTableWithoutIndexes onerror tbl = withBackend $ \b -> do
  void $ exec (compileCreateTable (ppConfig b) onerror tbl) []

-- | Create all indexes for the given table. Fails if any of the table's indexes
--   already exists.
createTableIndexes :: MonadSelda m => OnError -> Table a -> m ()
createTableIndexes ifex tbl = withBackend $ \b -> do
  mapM_ (flip exec []) $ compileCreateIndexes (ppConfig b) ifex tbl

-- | Create a table from the given schema, unless it already exists.
tryCreateTable :: MonadSelda m => Table a -> m ()
tryCreateTable tbl = do
  createTableWithoutIndexes Ignore tbl
  createTableIndexes Ignore tbl

-- | Drop the given table.
dropTable :: MonadSelda m => Table a -> m ()
dropTable = void . flip exec [] . compileDropTable Fail

-- | Drop the given table, if it exists.
tryDropTable :: MonadSelda m => Table a -> m ()
tryDropTable = void . flip exec [] . compileDropTable Ignore

-- | Perform the given computation atomically.
--   If an exception is raised during its execution, the entire transaction
--   will be rolled back and the exception re-thrown, even if the exception
--   is caught and handled within the transaction.
transaction :: (MonadSelda m, MonadMask m) => m a -> m a
transaction m = mask $ \restore -> transact $ do
  void $ exec "BEGIN TRANSACTION" []
  x <- restore m `onException` void (exec "ROLLBACK" [])
  void $ exec "COMMIT" []
  return x

-- | Run the given computation as a transaction without enforcing foreign key
--   constraints.
--
--   If the computation finishes with the database in an inconsistent state
--   with regards to foreign keys, the resulting behavior is undefined.
--   Use with extreme caution, preferably only for migrations.
--
--   On the PostgreSQL backend, at least PostgreSQL 9.6 is required.
--
--   Using this should be avoided in favor of deferred foreign key
--   constraints. See SQL backend documentation for deferred constraints.
withoutForeignKeyEnforcement :: (MonadSelda m, MonadMask m) => m a -> m a
withoutForeignKeyEnforcement m = withBackend $ \b -> do
  bracket_ (liftIO $ disableForeignKeys b True)
           (liftIO $ disableForeignKeys b False)
           m

-- | Build the final result from a list of result columns.
queryWith :: forall m a. (MonadSelda m, Result a)
          => QueryRunner (Int, [[SqlValue]]) -> Query (Backend m) a -> m [Res a]
queryWith run q = withBackend $ \b -> do
  res <- fmap snd . liftIO . uncurry run $ compileWith (ppConfig b) q
  return $ mkResults (Proxy :: Proxy a) res

-- | Generate the final result of a query from a list of untyped result rows.
mkResults :: Result a => Proxy a -> [[SqlValue]] -> [Res a]
mkResults p = map (buildResult p)

{-# INLINE exec #-}
-- | Execute a statement without a result.
exec :: MonadSelda m => Text -> [Param] -> m Int
exec q ps = withBackend $ \b -> liftIO $ execIO b q ps

{-# INLINE execIO #-}
-- | Like 'exec', but in 'IO'.
execIO :: SeldaBackend b -> Text -> [Param] -> IO Int
execIO backend q ps = fmap fst $ runStmt backend q ps