{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Database.Beam.Sqlite.Connection
  ( Sqlite(..), SqliteM(..)
  , sqliteUriSyntax

  , runBeamSqlite, runBeamSqliteDebug

    -- * Emulated @INSERT RETURNING@ support
  , insertReturning, runInsertReturningList
  ) where

import           Prelude hiding (fail)

import           Database.Beam.Backend
import           Database.Beam.Backend.Internal.Compat
import qualified Database.Beam.Backend.SQL.BeamExtensions as Beam
import           Database.Beam.Backend.URI
import           Database.Beam.Migrate.Generics
import           Database.Beam.Migrate.SQL ( BeamMigrateOnlySqlBackend, FieldReturnType(..) )
import qualified Database.Beam.Migrate.SQL as Beam
import           Database.Beam.Migrate.SQL.BeamExtensions
import           Database.Beam.Query ( SqlInsert(..), SqlInsertValues(..)
                                     , HasQBuilder(..), HasSqlEqualityCheck
                                     , HasSqlQuantifiedEqualityCheck
                                     , DataType(..)
                                     , HasSqlInTable(..)
                                     , insert, current_ )
import           Database.Beam.Query.Internal
import           Database.Beam.Query.SQL92
import           Database.Beam.Schema.Tables ( Beamable
                                             , Columnar'(..)
                                             , DatabaseEntity(..)
                                             , DatabaseEntityDescriptor(..)
                                             , TableEntity
                                             , TableField(..)
                                             , allBeamValues
                                             , changeBeamRep )
import           Database.Beam.Sqlite.Syntax

import           Database.SQLite.Simple ( Connection, ToRow(..), FromRow(..)
                                        , Query(..), SQLData(..), field
                                        , execute, execute_
                                        , withStatement, bind, nextRow
                                        , query_, open, close )
import           Database.SQLite.Simple.FromField ( FromField(..), ResultError(..)
                                                  , returnError, fieldData)
import           Database.SQLite.Simple.Internal (RowParser(RP), unRP)
import           Database.SQLite.Simple.Ok (Ok(..))
import           Database.SQLite.Simple.Types (Null)

import           Control.Exception (SomeException(..), bracket_, onException, mask)
import           Control.Monad (forM_)
import           Control.Monad.Base (MonadBase)
import           Control.Monad.Fail (MonadFail(..))
import           Control.Monad.Free.Church
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Identity (Identity)
import           Control.Monad.Reader (ReaderT(..), MonadReader(..), runReaderT)
import           Control.Monad.State.Strict (MonadState(..), StateT(..), runStateT)
import           Control.Monad.Trans (lift)
import           Control.Monad.Trans.Control (MonadBaseControl)
import           Control.Monad.Writer (tell, execWriter)

import           Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.DList as D
import           Data.Int
import           Data.Maybe (mapMaybe)
import           Data.Proxy (Proxy(..))
import           Data.Scientific (Scientific)
import           Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T (decodeUtf8)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8)
import           Data.Time ( LocalTime, UTCTime, Day
                           , ZonedTime, utc, utcToLocalTime )
import           Data.Typeable (cast)
import           Data.Word
import           GHC.TypeLits

import           Network.URI

#ifdef UNIX
import           System.Posix.Process (getProcessID)
#elif defined(WINDOWS)
import           System.Win32.Process (getCurrentProcessId)
#else
#error Need either POSIX or Win32 API for MonadBeamInsertReturning
#endif

import           Text.Read (readMaybe)

-- | The SQLite backend. Used to parameterize 'MonadBeam' and 'FromBackendRow'
-- to provide support for SQLite databases. See the documentation for
-- 'MonadBeam' and the <https://haskell-beam.github.io/beam/ user guide> for more
-- information on how to use this backend.
data Sqlite = Sqlite

instance BeamBackend Sqlite where
  type BackendFromField Sqlite = FromField

instance HasQBuilder Sqlite where
  buildSqlQuery :: forall a (db :: (* -> *) -> *) s.
Projectible Sqlite a =>
Text -> Q Sqlite db s a -> BeamSqlBackendSelectSyntax Sqlite
buildSqlQuery = forall be (db :: (* -> *) -> *) s a.
(BeamSqlBackend be, Projectible be a) =>
Bool -> Text -> Q be db s a -> BeamSqlBackendSelectSyntax be
buildSql92Query' Bool
False -- SQLite does not support arbitrarily nesting UNION, INTERSECT, and EXCEPT

instance HasSqlInTable Sqlite where
  inRowValuesE :: Proxy Sqlite
-> BeamSqlBackendExpressionSyntax Sqlite
-> [BeamSqlBackendExpressionSyntax Sqlite]
-> BeamSqlBackendExpressionSyntax Sqlite
inRowValuesE Proxy Sqlite
Proxy BeamSqlBackendExpressionSyntax Sqlite
e [BeamSqlBackendExpressionSyntax Sqlite]
es = SqliteSyntax -> SqliteExpressionSyntax
SqliteExpressionSyntax forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
    [ SqliteSyntax -> SqliteSyntax
parens forall a b. (a -> b) -> a -> b
$ SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression BeamSqlBackendExpressionSyntax Sqlite
e
    , ByteString -> SqliteSyntax
emit ByteString
" IN "
    , SqliteSyntax -> SqliteSyntax
parens forall a b. (a -> b) -> a -> b
$ ByteString -> SqliteSyntax
emit ByteString
"VALUES " forall a. Semigroup a => a -> a -> a
<> [SqliteSyntax] -> SqliteSyntax
commas (forall a b. (a -> b) -> [a] -> [b]
map SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression [BeamSqlBackendExpressionSyntax Sqlite]
es)
    ]

instance BeamSqlBackendIsString Sqlite T.Text
instance BeamSqlBackendIsString Sqlite String

instance FromBackendRow Sqlite Bool
instance FromBackendRow Sqlite Double
instance FromBackendRow Sqlite Float
instance FromBackendRow Sqlite Int8
instance FromBackendRow Sqlite Int16
instance FromBackendRow Sqlite Int32
instance FromBackendRow Sqlite Int64
instance FromBackendRow Sqlite Integer
instance FromBackendRow Sqlite Word8
instance FromBackendRow Sqlite Word16
instance FromBackendRow Sqlite Word32
instance FromBackendRow Sqlite Word64
instance FromBackendRow Sqlite BS.ByteString
instance FromBackendRow Sqlite BL.ByteString
instance FromBackendRow Sqlite T.Text
instance FromBackendRow Sqlite TL.Text
instance FromBackendRow Sqlite UTCTime
instance FromBackendRow Sqlite Day
instance FromBackendRow Sqlite Null
instance FromBackendRow Sqlite Char where
  fromBackendRow :: FromBackendRowM Sqlite Char
fromBackendRow = do
    Text
t <- forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow
    case Text -> Maybe (Char, Text)
T.uncons Text
t of
      Just (Char
c, Text
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
      Maybe (Char, Text)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Need string of size one to parse Char"
instance FromBackendRow Sqlite SqlNull where
  fromBackendRow :: FromBackendRowM Sqlite SqlNull
fromBackendRow =
    SqlNull
SqlNull forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow :: FromBackendRowM Sqlite Null)
instance FromBackendRow Sqlite LocalTime where
  fromBackendRow :: FromBackendRowM Sqlite LocalTime
fromBackendRow = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow
instance FromBackendRow Sqlite Scientific where
  fromBackendRow :: FromBackendRowM Sqlite Scientific
fromBackendRow = SqliteScientific -> Scientific
unSqliteScientific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow
instance FromBackendRow Sqlite SqliteScientific

instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Sqlite Int
instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Sqlite Word

newtype SqliteScientific = SqliteScientific { SqliteScientific -> Scientific
unSqliteScientific :: Scientific }
instance FromField SqliteScientific where
  fromField :: FieldParser SqliteScientific
fromField Field
f =
    Scientific -> SqliteScientific
SqliteScientific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    case Field -> SQLData
fieldData Field
f of
      SQLInteger Int64
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
      SQLFloat Double
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ Double
d
      SQLText Text
t -> String -> Ok Scientific
tryRead (Text -> String
T.unpack Text
t)
      SQLBlob ByteString
b -> String -> Ok Scientific
tryRead (ByteString -> String
BS.unpack ByteString
b)
      SQLData
SQLNull -> forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
UnexpectedNull Field
f String
"null"
    where
      tryRead :: String -> Ok Scientific
tryRead String
s =
        case forall a. Read a => String -> Maybe a
readMaybe String
s of
          Maybe Scientific
Nothing -> forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f forall a b. (a -> b) -> a -> b
$
                     String
"No conversion to Scientific for '" forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"'"
          Just Scientific
s'  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
s'

instance BeamSqlBackend Sqlite
instance BeamMigrateOnlySqlBackend Sqlite
type instance BeamSqlBackendSyntax Sqlite = SqliteCommandSyntax

data SqliteHasDefault = SqliteHasDefault
instance FieldReturnType 'True 'False Sqlite resTy a =>
         FieldReturnType 'False 'False Sqlite resTy (SqliteHasDefault -> a) where
  field' :: BeamMigrateSqlBackend Sqlite =>
Proxy 'False
-> Proxy 'False
-> Text
-> Sql92ColumnSchemaColumnTypeSyntax
     (Sql92CreateTableColumnSchemaSyntax
        (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax Sqlite)))
-> Maybe (BeamSqlBackendExpressionSyntax Sqlite)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax Sqlite]
-> SqliteHasDefault
-> a
field' Proxy 'False
_ Proxy 'False
_ Text
nm Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax Sqlite)))
ty Maybe (BeamSqlBackendExpressionSyntax Sqlite)
_ Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax Sqlite]
constraints SqliteHasDefault
SqliteHasDefault =
    forall (defaultGiven :: Bool) (collationGiven :: Bool) be resTy a.
(FieldReturnType defaultGiven collationGiven be resTy a,
 BeamMigrateSqlBackend be) =>
Proxy defaultGiven
-> Proxy collationGiven
-> Text
-> BeamMigrateSqlBackendDataTypeSyntax be
-> Maybe (BeamSqlBackendExpressionSyntax be)
-> Maybe Text
-> [BeamSqlBackendColumnConstraintDefinitionSyntax be]
-> a
field' (forall {k} (t :: k). Proxy t
Proxy @'True) (forall {k} (t :: k). Proxy t
Proxy @'False) Text
nm Sql92ColumnSchemaColumnTypeSyntax
  (Sql92CreateTableColumnSchemaSyntax
     (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax Sqlite)))
ty forall a. Maybe a
Nothing Maybe Text
collation [BeamSqlBackendColumnConstraintDefinitionSyntax Sqlite]
constraints

instance BeamSqlBackendHasSerial Sqlite where
  genericSerial :: forall a.
FieldReturnType 'True 'False Sqlite (SqlSerial Int) a =>
Text -> a
genericSerial Text
nm = forall be resTy a.
(BeamMigrateSqlBackend be,
 FieldReturnType 'False 'False be resTy a) =>
Text -> DataType be resTy -> a
Beam.field Text
nm (forall be a. BeamSqlBackendCastTargetSyntax be -> DataType be a
DataType SqliteDataTypeSyntax
sqliteSerialType) SqliteHasDefault
SqliteHasDefault

-- | 'MonadBeam' instance inside which SQLite queries are run. See the
-- <https://haskell-beam.github.io/beam/ user guide> for more information
newtype SqliteM a
  = SqliteM
  { forall a. SqliteM a -> ReaderT (String -> IO (), Connection) IO a
runSqliteM :: ReaderT (String -> IO (), Connection) IO a
    -- ^ Run an IO action with access to a SQLite connection and a debug logging
    -- function, called or each query submitted on the connection.
  } deriving (Applicative SqliteM
forall a. a -> SqliteM a
forall a b. SqliteM a -> SqliteM b -> SqliteM b
forall a b. SqliteM a -> (a -> SqliteM b) -> SqliteM 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 -> SqliteM a
$creturn :: forall a. a -> SqliteM a
>> :: forall a b. SqliteM a -> SqliteM b -> SqliteM b
$c>> :: forall a b. SqliteM a -> SqliteM b -> SqliteM b
>>= :: forall a b. SqliteM a -> (a -> SqliteM b) -> SqliteM b
$c>>= :: forall a b. SqliteM a -> (a -> SqliteM b) -> SqliteM b
Monad, forall a b. a -> SqliteM b -> SqliteM a
forall a b. (a -> b) -> SqliteM a -> SqliteM 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 -> SqliteM b -> SqliteM a
$c<$ :: forall a b. a -> SqliteM b -> SqliteM a
fmap :: forall a b. (a -> b) -> SqliteM a -> SqliteM b
$cfmap :: forall a b. (a -> b) -> SqliteM a -> SqliteM b
Functor, Functor SqliteM
forall a. a -> SqliteM a
forall a b. SqliteM a -> SqliteM b -> SqliteM a
forall a b. SqliteM a -> SqliteM b -> SqliteM b
forall a b. SqliteM (a -> b) -> SqliteM a -> SqliteM b
forall a b c. (a -> b -> c) -> SqliteM a -> SqliteM b -> SqliteM 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. SqliteM a -> SqliteM b -> SqliteM a
$c<* :: forall a b. SqliteM a -> SqliteM b -> SqliteM a
*> :: forall a b. SqliteM a -> SqliteM b -> SqliteM b
$c*> :: forall a b. SqliteM a -> SqliteM b -> SqliteM b
liftA2 :: forall a b c. (a -> b -> c) -> SqliteM a -> SqliteM b -> SqliteM c
$cliftA2 :: forall a b c. (a -> b -> c) -> SqliteM a -> SqliteM b -> SqliteM c
<*> :: forall a b. SqliteM (a -> b) -> SqliteM a -> SqliteM b
$c<*> :: forall a b. SqliteM (a -> b) -> SqliteM a -> SqliteM b
pure :: forall a. a -> SqliteM a
$cpure :: forall a. a -> SqliteM a
Applicative, Monad SqliteM
forall a. IO a -> SqliteM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> SqliteM a
$cliftIO :: forall a. IO a -> SqliteM a
MonadIO, Monad SqliteM
forall a. String -> SqliteM a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> SqliteM a
$cfail :: forall a. String -> SqliteM a
MonadFail)
    deriving newtype (MonadBase IO, MonadBaseControl IO)

newtype BeamSqliteParams = BeamSqliteParams [SQLData]
instance ToRow BeamSqliteParams where
  toRow :: BeamSqliteParams -> [SQLData]
toRow (BeamSqliteParams [SQLData]
x) = [SQLData]
x

newtype BeamSqliteRow a = BeamSqliteRow a
instance FromBackendRow Sqlite a => FromRow (BeamSqliteRow a) where
  fromRow :: RowParser (BeamSqliteRow a)
fromRow = forall a. a -> BeamSqliteRow a
BeamSqliteRow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Sqlite) a
fromBackendRow' forall {a}. a -> RowParser a
finish forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'
step
      where
        FromBackendRowM F (FromBackendRowF Sqlite) a
fromBackendRow' = forall be a. FromBackendRow be a => FromBackendRowM be a
fromBackendRow :: FromBackendRowM Sqlite a

        translateErrors :: Maybe Int -> SomeException -> Maybe SomeException
        translateErrors :: Maybe Int -> SomeException -> Maybe SomeException
translateErrors Maybe Int
col (SomeException e
e) =
          case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e of
            Just (ConversionFailed { errSQLType :: ResultError -> String
errSQLType     = String
typeString
                                   , errHaskellType :: ResultError -> String
errHaskellType = String
hsString
                                   , errMessage :: ResultError -> String
errMessage     = String
msg }) ->
              forall a. a -> Maybe a
Just (forall e. Exception e => e -> SomeException
SomeException (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError Maybe Int
col (String -> String -> String -> ColumnParseError
ColumnTypeMismatch String
hsString String
typeString (String
"conversion failed: " forall a. [a] -> [a] -> [a]
++ String
msg))))
            Just (UnexpectedNull {}) ->
              forall a. a -> Maybe a
Just (forall e. Exception e => e -> SomeException
SomeException (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError Maybe Int
col ColumnParseError
ColumnUnexpectedNull))
            Just (Incompatible { errSQLType :: ResultError -> String
errSQLType     = String
typeString
                               , errHaskellType :: ResultError -> String
errHaskellType = String
hsString
                               , errMessage :: ResultError -> String
errMessage     = String
msg }) ->
              forall a. a -> Maybe a
Just (forall e. Exception e => e -> SomeException
SomeException (Maybe Int -> ColumnParseError -> BeamRowReadError
BeamRowReadError Maybe Int
col (String -> String -> String -> ColumnParseError
ColumnTypeMismatch String
hsString String
typeString (String
"incompatible: " forall a. [a] -> [a] -> [a]
++ String
msg))))
            Maybe ResultError
Nothing -> forall a. Maybe a
Nothing

        finish :: a -> RowParser a
finish = forall (f :: * -> *) a. Applicative f => a -> f a
pure

        step :: forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'
        step :: forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'
step (ParseOneField a -> RowParser a'
next) =
            forall a.
ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a -> RowParser a
RP forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \RowParseRO
ro -> forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \st :: (Int, [SQLData])
st@(Int
col, [SQLData]
_) ->
            case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a.
RowParser a -> ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
unRP forall a. FromField a => RowParser a
field) RowParseRO
ro) (Int, [SQLData])
st of
              Ok (a
x, (Int, [SQLData])
st') -> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a.
RowParser a -> ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
unRP (a -> RowParser a'
next a
x)) RowParseRO
ro) (Int, [SQLData])
st'
              Errors [SomeException]
errs -> forall a. [SomeException] -> Ok a
Errors (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Int -> SomeException -> Maybe SomeException
translateErrors (forall a. a -> Maybe a
Just Int
col)) [SomeException]
errs)
        step (Alt (FromBackendRowM F (FromBackendRowF Sqlite) a
a) (FromBackendRowM F (FromBackendRowF Sqlite) a
b) a -> RowParser a'
next) = do
          forall a.
ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a -> RowParser a
RP forall a b. (a -> b) -> a -> b
$ do
            let RP ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
a' = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Sqlite) a
a forall {a}. a -> RowParser a
finish forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'
step
                RP ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
b' = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F (FromBackendRowF Sqlite) a
b forall {a}. a -> RowParser a
finish forall a'. FromBackendRowF Sqlite (RowParser a') -> RowParser a'
step

            (Int, [SQLData])
st <- forall s (m :: * -> *). MonadState s m => m s
get
            RowParseRO
ro <- forall r (m :: * -> *). MonadReader r m => m r
ask
            case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
a' RowParseRO
ro) (Int, [SQLData])
st of
              Ok (a
ra, (Int, [SQLData])
st') -> do
                forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int, [SQLData])
st'
                forall a.
RowParser a -> ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
unRP (a -> RowParser a'
next a
ra)
              Errors [SomeException]
aErrs ->
                case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
b' RowParseRO
ro) (Int, [SQLData])
st of
                  Ok (a
rb, (Int, [SQLData])
st') -> do
                    forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int, [SQLData])
st'
                    forall a.
RowParser a -> ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a
unRP (a -> RowParser a'
next a
rb)
                  Errors [SomeException]
bErrs ->
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [SomeException] -> Ok a
Errors ([SomeException]
aErrs forall a. [a] -> [a] -> [a]
++ [SomeException]
bErrs)))
        step (FailParseWith BeamRowReadError
err) = forall a.
ReaderT RowParseRO (StateT (Int, [SQLData]) Ok) a -> RowParser a
RP (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [SomeException] -> Ok a
Errors [forall e. Exception e => e -> SomeException
SomeException BeamRowReadError
err])))

-- * Equality checks
#define HAS_SQLITE_EQUALITY_CHECK(ty)                       \
  instance HasSqlEqualityCheck Sqlite (ty); \
  instance HasSqlQuantifiedEqualityCheck Sqlite (ty);

HAS_SQLITE_EQUALITY_CHECK(Int8)
HAS_SQLITE_EQUALITY_CHECK(Int16)
HAS_SQLITE_EQUALITY_CHECK(Int32)
HAS_SQLITE_EQUALITY_CHECK(Int64)
HAS_SQLITE_EQUALITY_CHECK(Word8)
HAS_SQLITE_EQUALITY_CHECK(Word16)
HAS_SQLITE_EQUALITY_CHECK(Word32)
HAS_SQLITE_EQUALITY_CHECK(Word64)
HAS_SQLITE_EQUALITY_CHECK(Double)
HAS_SQLITE_EQUALITY_CHECK(Float)
HAS_SQLITE_EQUALITY_CHECK(Bool)
HAS_SQLITE_EQUALITY_CHECK(String)
HAS_SQLITE_EQUALITY_CHECK(T.Text)
HAS_SQLITE_EQUALITY_CHECK(TL.Text)
HAS_SQLITE_EQUALITY_CHECK(BS.ByteString)
HAS_SQLITE_EQUALITY_CHECK(BL.ByteString)
HAS_SQLITE_EQUALITY_CHECK(UTCTime)
HAS_SQLITE_EQUALITY_CHECK(LocalTime)
HAS_SQLITE_EQUALITY_CHECK(ZonedTime)
HAS_SQLITE_EQUALITY_CHECK(Char)
HAS_SQLITE_EQUALITY_CHECK(Integer)
HAS_SQLITE_EQUALITY_CHECK(Scientific)

instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Sqlite Int
instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Sqlite Int
instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Sqlite Word
instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Sqlite Word

class HasDefaultSqlDataType Sqlite a => IsSqliteSerialIntegerType a
instance IsSqliteSerialIntegerType Int32
instance IsSqliteSerialIntegerType Int64
instance TypeError (PreferExplicitSize Int Int32) => IsSqliteSerialIntegerType Int

instance IsSqliteSerialIntegerType a => HasDefaultSqlDataType Sqlite (SqlSerial a) where
  defaultSqlDataType :: Proxy (SqlSerial a)
-> Proxy Sqlite
-> Bool
-> Sql92ExpressionCastTargetSyntax
     (BeamSqlBackendExpressionSyntax Sqlite)
defaultSqlDataType Proxy (SqlSerial a)
_ Proxy Sqlite
_ Bool
False = SqliteDataTypeSyntax
sqliteSerialType
  defaultSqlDataType Proxy (SqlSerial a)
_ Proxy Sqlite
_ Bool
True = forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType

instance HasDefaultSqlDataType Sqlite BS.ByteString where
  -- TODO we should somehow allow contsraints based on backend
  defaultSqlDataType :: Proxy ByteString
-> Proxy Sqlite
-> Bool
-> Sql92ExpressionCastTargetSyntax
     (BeamSqlBackendExpressionSyntax Sqlite)
defaultSqlDataType Proxy ByteString
_ Proxy Sqlite
_ Bool
_ = SqliteDataTypeSyntax
sqliteBlobType

instance HasDefaultSqlDataType Sqlite LocalTime where
  defaultSqlDataType :: Proxy LocalTime
-> Proxy Sqlite
-> Bool
-> Sql92ExpressionCastTargetSyntax
     (BeamSqlBackendExpressionSyntax Sqlite)
defaultSqlDataType Proxy LocalTime
_ Proxy Sqlite
_ Bool
_ = forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType forall a. Maybe a
Nothing Bool
False

-- | URI syntax for use with 'withDbConnection'. See documentation for
-- 'BeamURIOpeners' for more information.
sqliteUriSyntax :: c Sqlite Connection SqliteM
                -> BeamURIOpeners c
sqliteUriSyntax :: forall (c :: * -> * -> (* -> *) -> *).
c Sqlite Connection SqliteM -> BeamURIOpeners c
sqliteUriSyntax =
  forall hdl (m :: * -> *) (c :: * -> * -> (* -> *) -> *) be.
(forall a. hdl -> m a -> IO a)
-> String
-> (URI -> IO (hdl, IO ()))
-> c be hdl m
-> BeamURIOpeners c
mkUriOpener forall a. Connection -> SqliteM a -> IO a
runBeamSqlite String
"sqlite:"
    (\URI
uri -> do
        let sqliteName :: String
sqliteName = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriPath URI
uri) then String
":memory:" else URI -> String
uriPath URI
uri
        Connection
hdl <- String -> IO Connection
open String
sqliteName
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
hdl, Connection -> IO ()
close Connection
hdl))

runBeamSqliteDebug :: (String -> IO ()) -> Connection -> SqliteM a -> IO a
runBeamSqliteDebug :: forall a. (String -> IO ()) -> Connection -> SqliteM a -> IO a
runBeamSqliteDebug String -> IO ()
debugStmt Connection
conn SqliteM a
x = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. SqliteM a -> ReaderT (String -> IO (), Connection) IO a
runSqliteM SqliteM a
x) (String -> IO ()
debugStmt, Connection
conn)

runBeamSqlite :: Connection -> SqliteM a -> IO a
runBeamSqlite :: forall a. Connection -> SqliteM a -> IO a
runBeamSqlite = forall a. (String -> IO ()) -> Connection -> SqliteM a -> IO a
runBeamSqliteDebug (\String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

instance MonadBeam Sqlite SqliteM where
  runNoReturn :: BeamSqlBackendSyntax Sqlite -> SqliteM ()
runNoReturn (SqliteCommandSyntax (SqliteSyntax (SQLData -> Builder) -> Builder
cmd DList SQLData
vals)) =
    forall a. ReaderT (String -> IO (), Connection) IO a -> SqliteM a
SqliteM forall a b. (a -> b) -> a -> b
$ do
      (String -> IO ()
logger, Connection
conn) <- forall r (m :: * -> *). MonadReader r m => m r
ask
      let cmdString :: String
cmdString = ByteString -> String
BL.unpack (Builder -> ByteString
toLazyByteString (((SQLData -> Builder) -> Builder) -> Builder
withPlaceholders (SQLData -> Builder) -> Builder
cmd))
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
logger (String
cmdString forall a. [a] -> [a] -> [a]
++ String
";\n-- With values: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. DList a -> [a]
D.toList DList SQLData
vals)))
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn (forall a. IsString a => String -> a
fromString String
cmdString) (forall a. DList a -> [a]
D.toList DList SQLData
vals))
  runNoReturn (SqliteCommandInsert SqliteInsertSyntax
insertStmt_) =
    forall a. ReaderT (String -> IO (), Connection) IO a -> SqliteM a
SqliteM forall a b. (a -> b) -> a -> b
$ do
      (String -> IO ()
logger, Connection
conn) <- forall r (m :: * -> *). MonadReader r m => m r
ask
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO ()
runSqliteInsert String -> IO ()
logger Connection
conn SqliteInsertSyntax
insertStmt_)

  runReturningMany :: forall x a.
FromBackendRow Sqlite x =>
BeamSqlBackendSyntax Sqlite
-> (SqliteM (Maybe x) -> SqliteM a) -> SqliteM a
runReturningMany (SqliteCommandSyntax (SqliteSyntax (SQLData -> Builder) -> Builder
cmd DList SQLData
vals)) SqliteM (Maybe x) -> SqliteM a
action =
      forall a. ReaderT (String -> IO (), Connection) IO a -> SqliteM a
SqliteM forall a b. (a -> b) -> a -> b
$ do
        (String -> IO ()
logger, Connection
conn) <- forall r (m :: * -> *). MonadReader r m => m r
ask
        let cmdString :: String
cmdString = ByteString -> String
BL.unpack (Builder -> ByteString
toLazyByteString (((SQLData -> Builder) -> Builder) -> Builder
withPlaceholders (SQLData -> Builder) -> Builder
cmd))
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
logger (String
cmdString forall a. [a] -> [a] -> [a]
++ String
";\n-- With values: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. DList a -> [a]
D.toList DList SQLData
vals))
          forall a. Connection -> Query -> (Statement -> IO a) -> IO a
withStatement Connection
conn (forall a. IsString a => String -> a
fromString String
cmdString) forall a b. (a -> b) -> a -> b
$ \Statement
stmt ->
            do forall params. ToRow params => Statement -> params -> IO ()
bind Statement
stmt ([SQLData] -> BeamSqliteParams
BeamSqliteParams (forall a. DList a -> [a]
D.toList DList SQLData
vals))
               let nextRow' :: SqliteM (Maybe x)
nextRow' = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall r. FromRow r => Statement -> IO (Maybe r)
nextRow Statement
stmt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe (BeamSqliteRow (Maybe x))
x ->
                              case Maybe (BeamSqliteRow (Maybe x))
x of
                                Maybe (BeamSqliteRow (Maybe x))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                                Just (BeamSqliteRow Maybe x
row) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe x
row
               forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. SqliteM a -> ReaderT (String -> IO (), Connection) IO a
runSqliteM (SqliteM (Maybe x) -> SqliteM a
action SqliteM (Maybe x)
nextRow')) (String -> IO ()
logger, Connection
conn)
  runReturningMany SqliteCommandInsert {} SqliteM (Maybe x) -> SqliteM a
_ =
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
      [ String
"runReturningMany{Sqlite}: sqlite does not support returning "
      , String
"rows from an insert, use Database.Beam.Sqlite.insertReturning "
      , String
"for emulation" ]

instance Beam.MonadBeamInsertReturning Sqlite SqliteM where
  runInsertReturningList :: forall (table :: (* -> *) -> *).
(Beamable table, Projectible Sqlite (table (QExpr Sqlite ())),
 FromBackendRow Sqlite (table Identity)) =>
SqlInsert Sqlite table -> SqliteM [table Identity]
runInsertReturningList = forall (table :: (* -> *) -> *).
(Beamable table, FromBackendRow Sqlite (table Identity)) =>
SqlInsert Sqlite table -> SqliteM [table Identity]
runInsertReturningList

runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO ()
runSqliteInsert :: (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO ()
runSqliteInsert String -> IO ()
logger Connection
conn (SqliteInsertSyntax SqliteTableNameSyntax
tbl [Text]
fields SqliteInsertValuesSyntax
vs Maybe SqliteOnConflictSyntax
onConflict)
    -- If all expressions are simple expressions (no default), then just

  | SqliteInsertExpressions [[SqliteExpressionSyntax]]
es <- SqliteInsertValuesSyntax
vs, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== SqliteExpressionSyntax
SqliteExpressionDefault)) [[SqliteExpressionSyntax]]
es =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[SqliteExpressionSyntax]]
es forall a b. (a -> b) -> a -> b
$ \[SqliteExpressionSyntax]
row -> do
        let ([Text]
fields', [SqliteExpressionSyntax]
row') = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= SqliteExpressionSyntax
SqliteExpressionDefault) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fields [SqliteExpressionSyntax]
row
            SqliteSyntax (SQLData -> Builder) -> Builder
cmd DList SQLData
vals = SqliteTableNameSyntax
-> [Text]
-> SqliteInsertValuesSyntax
-> Maybe SqliteOnConflictSyntax
-> SqliteSyntax
formatSqliteInsertOnConflict SqliteTableNameSyntax
tbl [Text]
fields' ([[SqliteExpressionSyntax]] -> SqliteInsertValuesSyntax
SqliteInsertExpressions [ [SqliteExpressionSyntax]
row' ]) Maybe SqliteOnConflictSyntax
onConflict
            cmdString :: String
cmdString = ByteString -> String
BL.unpack (Builder -> ByteString
toLazyByteString (((SQLData -> Builder) -> Builder) -> Builder
withPlaceholders (SQLData -> Builder) -> Builder
cmd))
        String -> IO ()
logger (String
cmdString forall a. [a] -> [a] -> [a]
++ String
";\n-- With values: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. DList a -> [a]
D.toList DList SQLData
vals))
        forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn (forall a. IsString a => String -> a
fromString String
cmdString) (forall a. DList a -> [a]
D.toList DList SQLData
vals)
  | Bool
otherwise = do
      let SqliteSyntax (SQLData -> Builder) -> Builder
cmd DList SQLData
vals = SqliteTableNameSyntax
-> [Text]
-> SqliteInsertValuesSyntax
-> Maybe SqliteOnConflictSyntax
-> SqliteSyntax
formatSqliteInsertOnConflict SqliteTableNameSyntax
tbl [Text]
fields SqliteInsertValuesSyntax
vs Maybe SqliteOnConflictSyntax
onConflict
          cmdString :: String
cmdString = ByteString -> String
BL.unpack (Builder -> ByteString
toLazyByteString (((SQLData -> Builder) -> Builder) -> Builder
withPlaceholders (SQLData -> Builder) -> Builder
cmd))
      String -> IO ()
logger (String
cmdString forall a. [a] -> [a] -> [a]
++ String
";\n-- With values: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. DList a -> [a]
D.toList DList SQLData
vals))
      forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn (forall a. IsString a => String -> a
fromString String
cmdString) (forall a. DList a -> [a]
D.toList DList SQLData
vals)

-- * emulated INSERT returning support

-- | Build a 'SqliteInsertReturning' representing inserting the given values
-- into the given table. Use 'runInsertReturningList'
insertReturning :: Beamable table
                => DatabaseEntity Sqlite db (TableEntity table)
                -> SqlInsertValues Sqlite (table (QExpr Sqlite s))
                -> SqlInsert Sqlite table
insertReturning :: forall (table :: (* -> *) -> *) (db :: (* -> *) -> *) s.
Beamable table =>
DatabaseEntity Sqlite db (TableEntity table)
-> SqlInsertValues Sqlite (table (QExpr Sqlite s))
-> SqlInsert Sqlite table
insertReturning = forall be (table :: (* -> *) -> *) s (db :: (* -> *) -> *).
(BeamSqlBackend be,
 ProjectibleWithPredicate AnyType () Text (table (QField s))) =>
DatabaseEntity be db (TableEntity table)
-> SqlInsertValues be (table (QExpr be s)) -> SqlInsert be table
insert

-- | Runs a 'SqliteInsertReturning' statement and returns a result for each
-- inserted row.
runInsertReturningList :: (Beamable table, FromBackendRow Sqlite (table Identity))
                       => SqlInsert Sqlite table
                       -> SqliteM [ table Identity ]
runInsertReturningList :: forall (table :: (* -> *) -> *).
(Beamable table, FromBackendRow Sqlite (table Identity)) =>
SqlInsert Sqlite table -> SqliteM [table Identity]
runInsertReturningList SqlInsert Sqlite table
SqlInsertNoRows = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
runInsertReturningList (SqlInsert TableSettings table
tblSettings insertStmt_ :: BeamSqlBackendInsertSyntax Sqlite
insertStmt_@(SqliteInsertSyntax SqliteTableNameSyntax
nm [Text]
_ SqliteInsertValuesSyntax
_ Maybe SqliteOnConflictSyntax
_)) =
  do (String -> IO ()
logger, Connection
conn) <- forall a. ReaderT (String -> IO (), Connection) IO a -> SqliteM a
SqliteM forall r (m :: * -> *). MonadReader r m => m r
ask
     forall a. ReaderT (String -> IO (), Connection) IO a -> SqliteM a
SqliteM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do

#ifdef UNIX
       Text
processId <- forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ProcessID
getProcessID
#elif defined(WINDOWS)
       processId <- fromString . show <$> getCurrentProcessId
#else
#error Need either POSIX or Win32 API for MonadBeamInsertReturning
#endif

       let tableNameTxt :: Text
tableNameTxt = ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
BL.toStrict (SqliteSyntax -> ByteString
sqliteRenderSyntaxScript (SqliteTableNameSyntax -> SqliteSyntax
fromSqliteTableName SqliteTableNameSyntax
nm)))

           startSavepoint :: IO ()
startSavepoint =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"SAVEPOINT insert_savepoint_" forall a. Semigroup a => a -> a -> a
<> Text
processId))
           rollbackToSavepoint :: IO ()
rollbackToSavepoint =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"ROLLBACK TRANSACTION TO SAVEPOINT insert_savepoint_" forall a. Semigroup a => a -> a -> a
<> Text
processId))
           releaseSavepoint :: IO ()
releaseSavepoint =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"RELEASE SAVEPOINT insert_savepoint_" forall a. Semigroup a => a -> a -> a
<> Text
processId))

           createInsertedValuesTable :: IO ()
createInsertedValuesTable =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"CREATE TEMPORARY TABLE inserted_values_" forall a. Semigroup a => a -> a -> a
<> Text
processId forall a. Semigroup a => a -> a -> a
<> Text
" AS SELECT * FROM " forall a. Semigroup a => a -> a -> a
<> Text
tableNameTxt forall a. Semigroup a => a -> a -> a
<> Text
" LIMIT 0"))
           dropInsertedValuesTable :: IO ()
dropInsertedValuesTable =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"DROP TABLE inserted_values_" forall a. Semigroup a => a -> a -> a
<> Text
processId))

           createInsertTrigger :: IO ()
createInsertTrigger =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"CREATE TEMPORARY TRIGGER insert_trigger_" forall a. Semigroup a => a -> a -> a
<> Text
processId forall a. Semigroup a => a -> a -> a
<> Text
" AFTER INSERT ON " forall a. Semigroup a => a -> a -> a
<> Text
tableNameTxt forall a. Semigroup a => a -> a -> a
<> Text
" BEGIN " forall a. Semigroup a => a -> a -> a
<>
                                   Text
"INSERT INTO inserted_values_" forall a. Semigroup a => a -> a -> a
<> Text
processId forall a. Semigroup a => a -> a -> a
<> Text
" SELECT * FROM " forall a. Semigroup a => a -> a -> a
<> Text
tableNameTxt forall a. Semigroup a => a -> a -> a
<> Text
" WHERE ROWID=last_insert_rowid(); END" ))
           dropInsertTrigger :: IO ()
dropInsertTrigger =
             Connection -> Query -> IO ()
execute_ Connection
conn (Text -> Query
Query (Text
"DROP TRIGGER insert_trigger_" forall a. Semigroup a => a -> a -> a
<> Text
processId))


       forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
         IO ()
startSavepoint
         forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
onException IO ()
rollbackToSavepoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ do
           [table Identity]
x <- forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
createInsertedValuesTable IO ()
dropInsertedValuesTable forall a b. (a -> b) -> a -> b
$
                forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
createInsertTrigger IO ()
dropInsertTrigger forall a b. (a -> b) -> a -> b
$ do
                (String -> IO ()) -> Connection -> SqliteInsertSyntax -> IO ()
runSqliteInsert String -> IO ()
logger Connection
conn BeamSqlBackendInsertSyntax Sqlite
insertStmt_

                let columns :: Text
columns = Text -> Text
TL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TL.decodeUtf8 forall a b. (a -> b) -> a -> b
$
                              SqliteSyntax -> ByteString
sqliteRenderSyntaxScript forall a b. (a -> b) -> a -> b
$ [SqliteSyntax] -> SqliteSyntax
commas forall a b. (a -> b) -> a -> b
$
                              forall (table :: (* -> *) -> *) (f :: * -> *) b.
Beamable table =>
(forall a. Columnar' f a -> b) -> table f -> [b]
allBeamValues (\(Columnar' Columnar (TableField table) a
projField) -> Text -> SqliteSyntax
quotedIdentifier (forall (table :: (* -> *) -> *) ty. TableField table ty -> Text
_fieldName Columnar (TableField table) a
projField)) forall a b. (a -> b) -> a -> b
$
                              TableSettings table
tblSettings

                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(BeamSqliteRow table Identity
r) -> table Identity
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn (Text -> Query
Query (Text
"SELECT " forall a. Semigroup a => a -> a -> a
<> Text
columns forall a. Semigroup a => a -> a -> a
<> Text
" FROM inserted_values_" forall a. Semigroup a => a -> a -> a
<> Text
processId))
           IO ()
releaseSavepoint
           forall (m :: * -> *) a. Monad m => a -> m a
return [table Identity]
x

instance Beam.BeamHasInsertOnConflict Sqlite where
  newtype SqlConflictTarget Sqlite table = SqliteConflictTarget
    { forall (table :: (* -> *) -> *).
SqlConflictTarget Sqlite table
-> table (QExpr Sqlite QInternal) -> SqliteSyntax
unSqliteConflictTarget :: table (QExpr Sqlite QInternal) -> SqliteSyntax }
  newtype SqlConflictAction Sqlite table = SqliteConflictAction
    { forall (table :: (* -> *) -> *).
SqlConflictAction Sqlite table
-> forall s. table (QField s) -> SqliteSyntax
unSqliteConflictAction :: forall s. table (QField s) -> SqliteSyntax }

  insertOnConflict
    :: forall db table s. Beamable table
    => DatabaseEntity Sqlite db (TableEntity table)
    -> SqlInsertValues Sqlite (table (QExpr Sqlite s))
    -> Beam.SqlConflictTarget Sqlite table
    -> Beam.SqlConflictAction Sqlite table
    -> SqlInsert Sqlite table
  insertOnConflict :: forall (db :: (* -> *) -> *) (table :: (* -> *) -> *) s.
Beamable table =>
DatabaseEntity Sqlite db (TableEntity table)
-> SqlInsertValues Sqlite (table (QExpr Sqlite s))
-> SqlConflictTarget Sqlite table
-> SqlConflictAction Sqlite table
-> SqlInsert Sqlite table
insertOnConflict (DatabaseEntity DatabaseEntityDescriptor Sqlite (TableEntity table)
dt) SqlInsertValues Sqlite (table (QExpr Sqlite s))
values SqlConflictTarget Sqlite table
target SqlConflictAction Sqlite table
action = case SqlInsertValues Sqlite (table (QExpr Sqlite s))
values of
    SqlInsertValues Sqlite (table (QExpr Sqlite s))
SqlInsertValuesEmpty -> forall be (table :: (* -> *) -> *). SqlInsert be table
SqlInsertNoRows
    SqlInsertValues BeamSqlBackendInsertValuesSyntax Sqlite
vs -> forall be (table :: (* -> *) -> *).
TableSettings table
-> BeamSqlBackendInsertSyntax be -> SqlInsert be table
SqlInsert (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor Sqlite (TableEntity table)
dt) forall a b. (a -> b) -> a -> b
$
      let getFieldName
            :: forall a
            .  Columnar' (TableField table) a
            -> Columnar' (QField QInternal) a
          getFieldName :: forall a.
Columnar' (TableField table) a -> Columnar' (QField QInternal) a
getFieldName (Columnar' Columnar (TableField table) a
fd) =
            forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall a b. (a -> b) -> a -> b
$ forall s ty. Bool -> Text -> Text -> QField s ty
QField Bool
False (forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> Text
dbTableCurrentName DatabaseEntityDescriptor Sqlite (TableEntity table)
dt) forall a b. (a -> b) -> a -> b
$ forall (table :: (* -> *) -> *) ty. TableField table ty -> Text
_fieldName Columnar (TableField table) a
fd
          tableFields :: table (QField QInternal)
tableFields = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep forall a.
Columnar' (TableField table) a -> Columnar' (QField QInternal) a
getFieldName forall a b. (a -> b) -> a -> b
$ forall (tbl :: (* -> *) -> *) be.
DatabaseEntityDescriptor be (TableEntity tbl) -> TableSettings tbl
dbTableSettings DatabaseEntityDescriptor Sqlite (TableEntity table)
dt
          tellFieldName :: p -> p -> b -> m b
tellFieldName p
_ p
_ b
f = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [b
f] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
f
          fieldNames :: [Text]
fieldNames = forall w a. Writer w a -> w
execWriter forall a b. (a -> b) -> a -> b
$
            forall (contextPredicate :: * -> Constraint) be res a
       (m :: * -> *).
(ProjectibleWithPredicate contextPredicate be res a, Monad m) =>
Proxy contextPredicate
-> Proxy (be, res)
-> (forall context.
    contextPredicate context =>
    Proxy context -> Proxy be -> res -> m res)
-> a
-> m a
project' (forall {k} (t :: k). Proxy t
Proxy @AnyType) (forall {k} (t :: k). Proxy t
Proxy @((), T.Text)) forall {m :: * -> *} {b} {p} {p}.
MonadWriter [b] m =>
p -> p -> b -> m b
tellFieldName table (QField QInternal)
tableFields
          currentField
            :: forall a
            .  Columnar' (QField QInternal) a
            -> Columnar' (QExpr Sqlite QInternal) a
          currentField :: forall a.
Columnar' (QField QInternal) a
-> Columnar' (QExpr Sqlite QInternal) a
currentField (Columnar' Columnar (QField QInternal) a
f) = forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall a b. (a -> b) -> a -> b
$ forall be s ty. BeamSqlBackend be => QField s ty -> QExpr be s ty
current_ Columnar (QField QInternal) a
f
          tableCurrent :: table (QExpr Sqlite QInternal)
tableCurrent = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep forall a.
Columnar' (QField QInternal) a
-> Columnar' (QExpr Sqlite QInternal) a
currentField table (QField QInternal)
tableFields
      in SqliteTableNameSyntax
-> [Text]
-> SqliteInsertValuesSyntax
-> Maybe SqliteOnConflictSyntax
-> SqliteInsertSyntax
SqliteInsertSyntax (forall name be (tbl :: (* -> *) -> *).
IsSql92TableNameSyntax name =>
DatabaseEntityDescriptor be (TableEntity tbl) -> name
tableNameFromEntity DatabaseEntityDescriptor Sqlite (TableEntity table)
dt) [Text]
fieldNames BeamSqlBackendInsertValuesSyntax Sqlite
vs forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
           SqliteSyntax -> SqliteOnConflictSyntax
SqliteOnConflictSyntax forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> SqliteSyntax
emit ByteString
"ON CONFLICT "
             , forall (table :: (* -> *) -> *).
SqlConflictTarget Sqlite table
-> table (QExpr Sqlite QInternal) -> SqliteSyntax
unSqliteConflictTarget SqlConflictTarget Sqlite table
target table (QExpr Sqlite QInternal)
tableCurrent
             , ByteString -> SqliteSyntax
emit ByteString
" DO "
             , forall (table :: (* -> *) -> *).
SqlConflictAction Sqlite table
-> forall s. table (QField s) -> SqliteSyntax
unSqliteConflictAction SqlConflictAction Sqlite table
action table (QField QInternal)
tableFields
             ]

  anyConflict :: forall (table :: (* -> *) -> *). SqlConflictTarget Sqlite table
anyConflict = forall (table :: (* -> *) -> *).
(table (QExpr Sqlite QInternal) -> SqliteSyntax)
-> SqlConflictTarget Sqlite table
SqliteConflictTarget forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. Monoid a => a
mempty
  conflictingFields :: forall proj (table :: (* -> *) -> *).
Projectible Sqlite proj =>
(table (QExpr Sqlite QInternal) -> proj)
-> SqlConflictTarget Sqlite table
conflictingFields table (QExpr Sqlite QInternal) -> proj
makeProjection = forall (table :: (* -> *) -> *).
(table (QExpr Sqlite QInternal) -> SqliteSyntax)
-> SqlConflictTarget Sqlite table
SqliteConflictTarget forall a b. (a -> b) -> a -> b
$ \table (QExpr Sqlite QInternal)
table ->
    SqliteSyntax -> SqliteSyntax
parens forall a b. (a -> b) -> a -> b
$ [SqliteSyntax] -> SqliteSyntax
commas forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression forall a b. (a -> b) -> a -> b
$
      forall be a.
Projectible be a =>
Proxy be
-> a -> WithExprContext [BeamSqlBackendExpressionSyntax be]
project (forall {k} (t :: k). Proxy t
Proxy @Sqlite) (table (QExpr Sqlite QInternal) -> proj
makeProjection table (QExpr Sqlite QInternal)
table) Text
"t"
  conflictingFieldsWhere :: forall proj (table :: (* -> *) -> *).
Projectible Sqlite proj =>
(table (QExpr Sqlite QInternal) -> proj)
-> (forall s. table (QExpr Sqlite s) -> QExpr Sqlite s Bool)
-> SqlConflictTarget Sqlite table
conflictingFieldsWhere table (QExpr Sqlite QInternal) -> proj
makeProjection forall s. table (QExpr Sqlite s) -> QExpr Sqlite s Bool
makeWhere =
    forall (table :: (* -> *) -> *).
(table (QExpr Sqlite QInternal) -> SqliteSyntax)
-> SqlConflictTarget Sqlite table
SqliteConflictTarget forall a b. (a -> b) -> a -> b
$ \table (QExpr Sqlite QInternal)
table -> forall a. Monoid a => [a] -> a
mconcat
      [ forall (table :: (* -> *) -> *).
SqlConflictTarget Sqlite table
-> table (QExpr Sqlite QInternal) -> SqliteSyntax
unSqliteConflictTarget (forall be proj (table :: (* -> *) -> *).
(BeamHasInsertOnConflict be, Projectible be proj) =>
(table (QExpr be QInternal) -> proj) -> SqlConflictTarget be table
Beam.conflictingFields table (QExpr Sqlite QInternal) -> proj
makeProjection) table (QExpr Sqlite QInternal)
table
      , ByteString -> SqliteSyntax
emit ByteString
" WHERE "
      , let QExpr Text -> BeamSqlBackendExpressionSyntax Sqlite
mkE = forall s. table (QExpr Sqlite s) -> QExpr Sqlite s Bool
makeWhere table (QExpr Sqlite QInternal)
table
        in SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression forall a b. (a -> b) -> a -> b
$ Text -> BeamSqlBackendExpressionSyntax Sqlite
mkE Text
"t"
      ]

  onConflictDoNothing :: forall (table :: (* -> *) -> *). SqlConflictAction Sqlite table
onConflictDoNothing = forall (table :: (* -> *) -> *).
(forall s. table (QField s) -> SqliteSyntax)
-> SqlConflictAction Sqlite table
SqliteConflictAction forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ ByteString -> SqliteSyntax
emit ByteString
"NOTHING"
  onConflictUpdateSet :: forall (table :: (* -> *) -> *).
Beamable table =>
(forall s.
 table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s)
-> SqlConflictAction Sqlite table
onConflictUpdateSet forall s.
table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s
makeAssignments = forall (table :: (* -> *) -> *).
(forall s. table (QField s) -> SqliteSyntax)
-> SqlConflictAction Sqlite table
SqliteConflictAction forall a b. (a -> b) -> a -> b
$ \table (QField s)
table -> forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> SqliteSyntax
emit ByteString
"UPDATE SET "
    , let QAssignment [(BeamSqlBackendFieldNameSyntax Sqlite,
  BeamSqlBackendExpressionSyntax Sqlite)]
assignments = forall s.
table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s
makeAssignments table (QField s)
table forall a b. (a -> b) -> a -> b
$ forall (table :: (* -> *) -> *) s.
Beamable table =>
table (QField s) -> table (QExpr Sqlite s)
excluded table (QField s)
table
          emitAssignment :: (SqliteFieldNameSyntax, SqliteExpressionSyntax) -> SqliteSyntax
emitAssignment (SqliteFieldNameSyntax
fieldName, SqliteExpressionSyntax
expr) = forall a. Monoid a => [a] -> a
mconcat
            [ SqliteFieldNameSyntax -> SqliteSyntax
fromSqliteFieldNameSyntax SqliteFieldNameSyntax
fieldName
            , ByteString -> SqliteSyntax
emit ByteString
" = "
            , SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression SqliteExpressionSyntax
expr
            ]
      in [SqliteSyntax] -> SqliteSyntax
commas forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SqliteFieldNameSyntax, SqliteExpressionSyntax) -> SqliteSyntax
emitAssignment [(BeamSqlBackendFieldNameSyntax Sqlite,
  BeamSqlBackendExpressionSyntax Sqlite)]
assignments
    ]
  onConflictUpdateSetWhere :: forall (table :: (* -> *) -> *).
Beamable table =>
(forall s.
 table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s)
-> (forall s.
    table (QField s) -> table (QExpr Sqlite s) -> QExpr Sqlite s Bool)
-> SqlConflictAction Sqlite table
onConflictUpdateSetWhere forall s.
table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s
makeAssignments forall s.
table (QField s) -> table (QExpr Sqlite s) -> QExpr Sqlite s Bool
makeWhere =
    forall (table :: (* -> *) -> *).
(forall s. table (QField s) -> SqliteSyntax)
-> SqlConflictAction Sqlite table
SqliteConflictAction forall a b. (a -> b) -> a -> b
$ \table (QField s)
table -> forall a. Monoid a => [a] -> a
mconcat
      [ forall (table :: (* -> *) -> *).
SqlConflictAction Sqlite table
-> forall s. table (QField s) -> SqliteSyntax
unSqliteConflictAction (forall be (table :: (* -> *) -> *).
(BeamHasInsertOnConflict be, Beamable table) =>
(forall s.
 table (QField s) -> table (QExpr be s) -> QAssignment be s)
-> SqlConflictAction be table
Beam.onConflictUpdateSet forall s.
table (QField s) -> table (QExpr Sqlite s) -> QAssignment Sqlite s
makeAssignments) table (QField s)
table
      , ByteString -> SqliteSyntax
emit ByteString
" WHERE "
      , let QExpr Text -> BeamSqlBackendExpressionSyntax Sqlite
mkE = forall s.
table (QField s) -> table (QExpr Sqlite s) -> QExpr Sqlite s Bool
makeWhere table (QField s)
table forall a b. (a -> b) -> a -> b
$ forall (table :: (* -> *) -> *) s.
Beamable table =>
table (QField s) -> table (QExpr Sqlite s)
excluded table (QField s)
table
        in SqliteExpressionSyntax -> SqliteSyntax
fromSqliteExpression forall a b. (a -> b) -> a -> b
$ Text -> BeamSqlBackendExpressionSyntax Sqlite
mkE Text
"t"
      ]

excluded
  :: forall table s
  .  Beamable table
  => table (QField s)
  -> table (QExpr Sqlite s)
excluded :: forall (table :: (* -> *) -> *) s.
Beamable table =>
table (QField s) -> table (QExpr Sqlite s)
excluded table (QField s)
table = forall (table :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Beamable table =>
(forall a. Columnar' f a -> Columnar' g a) -> table f -> table g
changeBeamRep forall {f :: * -> *} {a} {context} {be} {s} {t} {f :: * -> *} {a}
       {s} {ty}.
(Columnar f a ~ QGenExpr context be s t,
 Columnar f a ~ QField s ty,
 IsSql92ExpressionSyntax
   (Sql92SelectTableExpressionSyntax
      (Sql92SelectSelectTableSyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))))) =>
Columnar' f a -> Columnar' f a
excludedField table (QField s)
table
  where excludedField :: Columnar' f a -> Columnar' f a
excludedField (Columnar' (QField Bool
_ Text
_ Text
name)) =
          forall (f :: * -> *) a. Columnar f a -> Columnar' f a
Columnar' forall a b. (a -> b) -> a -> b
$ forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall expr.
IsSql92ExpressionSyntax expr =>
Sql92ExpressionFieldNameSyntax expr -> expr
fieldE forall a b. (a -> b) -> a -> b
$ forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
"excluded" Text
name