{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- Strictly, this could go as low as GHC 8.6.1, which is when DerivingVia was
-- introduced - this base version requires 8.6.5+
#if MIN_VERSION_base(4,12,0)
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
#endif

-- | A sqlite backend for persistent.
--
-- Note: If you prepend @WAL=off @ to your connection string, it will disable
-- the write-ahead log. This functionality is now deprecated in favour of using SqliteConnectionInfo.
module Database.Persist.Sqlite
    ( withSqlitePool
    , withSqlitePoolInfo
    , withSqliteConn
    , withSqliteConnInfo
    , createSqlitePool
    , createSqlitePoolFromInfo
    , module Database.Persist.Sql
    , SqliteConf (..)
    , SqliteConnectionInfo
    , mkSqliteConnectionInfo
    , sqlConnectionStr
    , walEnabled
    , fkEnabled
    , extraPragmas
    , runSqlite
    , runSqliteInfo
    , wrapConnection
    , wrapConnectionInfo
    , mockMigration
    , retryOnBusy
    , waitForDatabase
    , ForeignKeyViolation(..)
    , checkForeignKeys
    , RawSqlite
    , persistentBackend
    , rawSqliteConnection
    , withRawSqliteConnInfo
    , createRawSqlitePoolFromInfo
    , createRawSqlitePoolFromInfo_
    , withRawSqlitePoolInfo
    , withRawSqlitePoolInfo_
    ) where

import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Control.Monad (forM_)
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, askRunInIO, withRunInIO, withUnliftIO, unliftIO, withRunInIO)
import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLoggerIO, logWarn, runLoggingT, askLoggerIO)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
#if !MIN_VERSION_base(4,12,0)
import Control.Monad.Trans.Reader (withReaderT)
#endif
import Control.Monad.Trans.Writer (runWriterT)
import Data.Acquire (Acquire, mkAcquire, with)
import Data.Maybe
import Data.Aeson
import Data.Aeson.Types (modifyFailure)
import Data.Conduit
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Lazy as HashMap
import Data.Int (Int64)
import Data.IORef
import qualified Data.Map as Map
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Lens.Micro.TH (makeLenses)
import UnliftIO.Resource (ResourceT, runResourceT)
import Data.Foldable (toList)

#if MIN_VERSION_base(4,12,0)
import Database.Persist.Compatible
#endif
import Database.Persist.Sql
import Database.Persist.SqlBackend
import qualified Database.Persist.Sql.Util as Util
import qualified Database.Sqlite as Sqlite


-- | Create a pool of SQLite connections.
--
-- Note that this should not be used with the @:memory:@ connection string, as
-- the pool will regularly remove connections, destroying your database.
-- Instead, use 'withSqliteConn'.
createSqlitePool :: (MonadLoggerIO m, MonadUnliftIO m)
                 => Text -> Int -> m (Pool SqlBackend)
createSqlitePool :: Text -> Int -> m (Pool SqlBackend)
createSqlitePool = SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo (SqliteConnectionInfo -> Int -> m (Pool SqlBackend))
-> (Text -> SqliteConnectionInfo)
-> Text
-> Int
-> m (Pool SqlBackend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SqliteConnectionInfo
conStringToInfo

-- | Create a pool of SQLite connections.
--
-- Note that this should not be used with the @:memory:@ connection string, as
-- the pool will regularly remove connections, destroying your database.
-- Instead, use 'withSqliteConn'.
--
-- @since 2.6.2
createSqlitePoolFromInfo :: (MonadLoggerIO m, MonadUnliftIO m)
                         => SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo :: SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo SqliteConnectionInfo
connInfo = (LogFunc -> IO SqlBackend) -> Int -> m (Pool SqlBackend)
forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool ((LogFunc -> IO SqlBackend) -> Int -> m (Pool SqlBackend))
-> (LogFunc -> IO SqlBackend) -> Int -> m (Pool SqlBackend)
forall a b. (a -> b) -> a -> b
$ (SqlBackend -> Connection -> SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO SqlBackend
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> SqlBackend
forall a b. a -> b -> a
const SqliteConnectionInfo
connInfo

-- | Run the given action with a connection pool.
--
-- Like 'createSqlitePool', this should not be used with @:memory:@.
withSqlitePool :: (MonadUnliftIO m, MonadLoggerIO m)
               => Text
               -> Int -- ^ number of connections to open
               -> (Pool SqlBackend -> m a) -> m a
withSqlitePool :: Text -> Int -> (Pool SqlBackend -> m a) -> m a
withSqlitePool Text
connInfo = (LogFunc -> IO SqlBackend)
-> Int -> (Pool SqlBackend -> m a) -> m a
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool ((LogFunc -> IO SqlBackend)
 -> Int -> (Pool SqlBackend -> m a) -> m a)
-> (SqliteConnectionInfo -> LogFunc -> IO SqlBackend)
-> SqliteConnectionInfo
-> Int
-> (Pool SqlBackend -> m a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlBackend -> Connection -> SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO SqlBackend
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> SqlBackend
forall a b. a -> b -> a
const (SqliteConnectionInfo -> Int -> (Pool SqlBackend -> m a) -> m a)
-> SqliteConnectionInfo -> Int -> (Pool SqlBackend -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ Text -> SqliteConnectionInfo
conStringToInfo Text
connInfo

-- | Run the given action with a connection pool.
--
-- Like 'createSqlitePool', this should not be used with @:memory:@.
--
-- @since 2.6.2
withSqlitePoolInfo :: (MonadUnliftIO m, MonadLoggerIO m)
                   => SqliteConnectionInfo
                   -> Int -- ^ number of connections to open
                   -> (Pool SqlBackend -> m a) -> m a
withSqlitePoolInfo :: SqliteConnectionInfo -> Int -> (Pool SqlBackend -> m a) -> m a
withSqlitePoolInfo SqliteConnectionInfo
connInfo = (LogFunc -> IO SqlBackend)
-> Int -> (Pool SqlBackend -> m a) -> m a
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool ((LogFunc -> IO SqlBackend)
 -> Int -> (Pool SqlBackend -> m a) -> m a)
-> (LogFunc -> IO SqlBackend)
-> Int
-> (Pool SqlBackend -> m a)
-> m a
forall a b. (a -> b) -> a -> b
$ (SqlBackend -> Connection -> SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO SqlBackend
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> SqlBackend
forall a b. a -> b -> a
const SqliteConnectionInfo
connInfo

withSqliteConn :: (MonadUnliftIO m, MonadLoggerIO m)
               => Text -> (SqlBackend -> m a) -> m a
withSqliteConn :: Text -> (SqlBackend -> m a) -> m a
withSqliteConn = SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo (SqliteConnectionInfo -> (SqlBackend -> m a) -> m a)
-> (Text -> SqliteConnectionInfo)
-> Text
-> (SqlBackend -> m a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SqliteConnectionInfo
conStringToInfo

-- | @since 2.6.2
withSqliteConnInfo :: (MonadUnliftIO m, MonadLoggerIO m)
                   => SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo :: SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo = (LogFunc -> IO SqlBackend) -> (SqlBackend -> m a) -> m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn ((LogFunc -> IO SqlBackend) -> (SqlBackend -> m a) -> m a)
-> (SqliteConnectionInfo -> LogFunc -> IO SqlBackend)
-> SqliteConnectionInfo
-> (SqlBackend -> m a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlBackend -> Connection -> SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO SqlBackend
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> SqlBackend
forall a b. a -> b -> a
const

openWith :: (SqlBackend -> Sqlite.Connection -> r)
         -> SqliteConnectionInfo
         -> LogFunc
         -> IO r
openWith :: (SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> r
f SqliteConnectionInfo
connInfo LogFunc
logFunc = do
    Connection
conn <- Text -> IO Connection
Sqlite.open (Text -> IO Connection) -> Text -> IO Connection
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> Text
_sqlConnectionStr SqliteConnectionInfo
connInfo
    SqlBackend
backend <- SqliteConnectionInfo -> Connection -> LogFunc -> IO SqlBackend
wrapConnectionInfo SqliteConnectionInfo
connInfo Connection
conn LogFunc
logFunc IO SqlBackend -> IO () -> IO SqlBackend
forall a b. IO a -> IO b -> IO a
`E.onException` Connection -> IO ()
Sqlite.close Connection
conn
    r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> IO r) -> r -> IO r
forall a b. (a -> b) -> a -> b
$ SqlBackend -> Connection -> r
f SqlBackend
backend Connection
conn

-- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL 'Connection'.
--
-- === __Example usage__
--
-- > {-# LANGUAGE GADTs #-}
-- > {-# LANGUAGE ScopedTypeVariables #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE MultiParamTypeClasses #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- > {-# LANGUAGE TemplateHaskell #-}
-- > {-# LANGUAGE QuasiQuotes #-}
-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- >
-- > import Control.Monad.IO.Class  (liftIO)
-- > import Database.Persist
-- > import Database.Sqlite
-- > import Database.Persist.Sqlite
-- > import Database.Persist.TH
-- >
-- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- > Person
-- >   name String
-- >   age Int Maybe
-- >   deriving Show
-- > |]
-- >
-- > main :: IO ()
-- > main = do
-- >   conn <- open "/home/sibi/test.db"
-- >   (backend :: SqlBackend) <- wrapConnection conn (\_ _ _ _ -> return ())
-- >   flip runSqlPersistM backend $ do
-- >          runMigration migrateAll
-- >          insert_ $ Person "John doe" $ Just 35
-- >          insert_ $ Person "Hema" $ Just 36
-- >          (pers :: [Entity Person]) <- selectList [] []
-- >          liftIO $ print pers
-- >   close' backend
--
-- On executing it, you get this output:
--
-- > Migrating: CREATE TABLE "person"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"age" INTEGER NULL)
-- > [Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = Person {personName = "John doe", personAge = Just 35}},Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = Person {personName = "Hema", personAge = Just 36}}]
--
-- @since 1.1.5
wrapConnection :: Sqlite.Connection -> LogFunc -> IO SqlBackend
wrapConnection :: Connection -> LogFunc -> IO SqlBackend
wrapConnection = SqliteConnectionInfo -> Connection -> LogFunc -> IO SqlBackend
wrapConnectionInfo (Text -> SqliteConnectionInfo
mkSqliteConnectionInfo Text
"")

-- | Retry if a Busy is thrown, following an exponential backoff strategy.
--
-- @since 2.9.3
retryOnBusy :: (MonadUnliftIO m, MonadLoggerIO m) => m a -> m a
retryOnBusy :: m a -> m a
retryOnBusy m a
action =
  [Int] -> m a
start ([Int] -> m a) -> [Int] -> m a
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
20 ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall t. (Ord t, Num t) => t -> [t]
delays Int
1000
  where
    delays :: t -> [t]
delays t
x
      | t
x t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
1000000 = t -> [t]
forall a. a -> [a]
repeat t
x
      | Bool
otherwise = t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t]
delays (t
x t -> t -> t
forall a. Num a => a -> a -> a
* t
2)

    start :: [Int] -> m a
start [] = do
      Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logWarn Text
"Out of retry attempts"
      m a
action
    start (Int
x:[Int]
xs) = do
      -- Using try instead of catch to avoid creating a stack overflow
      Either SqliteException a
eres <- ((forall a. m a -> IO a) -> IO (Either SqliteException a))
-> m (Either SqliteException a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Either SqliteException a))
 -> m (Either SqliteException a))
-> ((forall a. m a -> IO a) -> IO (Either SqliteException a))
-> m (Either SqliteException a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> IO a -> IO (Either SqliteException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either SqliteException a))
-> IO a -> IO (Either SqliteException a)
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run m a
action
      case Either SqliteException a
eres of
        Left (Sqlite.SqliteException { seError :: SqliteException -> Error
Sqlite.seError = Error
Sqlite.ErrorBusy }) -> do
          Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logWarn Text
"Encountered an SQLITE_BUSY, going to retry..."
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
x
          [Int] -> m a
start [Int]
xs
        Left SqliteException
e -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ SqliteException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO SqliteException
e
        Right a
y -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y

-- | Wait until some noop action on the database does not return an 'Sqlite.ErrorBusy'. See 'retryOnBusy'.
--
-- @since 2.9.3
waitForDatabase
    :: (MonadUnliftIO m, MonadLoggerIO m, BackendCompatible SqlBackend backend)
    => ReaderT backend m ()
waitForDatabase :: ReaderT backend m ()
waitForDatabase = ReaderT backend m () -> ReaderT backend m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
m a -> m a
retryOnBusy (ReaderT backend m () -> ReaderT backend m ())
-> ReaderT backend m () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ Text -> [PersistValue] -> ReaderT backend m ()
forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
"SELECT 42" []

-- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL
-- 'Connection', allowing full control over WAL and FK constraints.
--
-- @since 2.6.2
wrapConnectionInfo
    :: SqliteConnectionInfo
    -> Sqlite.Connection
    -> LogFunc
    -> IO SqlBackend
wrapConnectionInfo :: SqliteConnectionInfo -> Connection -> LogFunc -> IO SqlBackend
wrapConnectionInfo SqliteConnectionInfo
connInfo Connection
conn LogFunc
logFunc = do
    let
        -- Turn on the write-ahead log
        -- https://github.com/yesodweb/persistent/issues/363
        walPragma :: [(Text, Bool)] -> [(Text, Bool)]
walPragma
          | SqliteConnectionInfo -> Bool
_walEnabled SqliteConnectionInfo
connInfo = ((Text
"PRAGMA journal_mode=WAL;", Bool
True)(Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
:)
          | Bool
otherwise = [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> a
id

        -- Turn on foreign key constraints
        -- https://github.com/yesodweb/persistent/issues/646
        fkPragma :: [(Text, Bool)] -> [(Text, Bool)]
fkPragma
          | SqliteConnectionInfo -> Bool
_fkEnabled SqliteConnectionInfo
connInfo = ((Text
"PRAGMA foreign_keys = on;", Bool
False)(Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
:)
          | Bool
otherwise = [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> a
id

        -- Allow arbitrary additional pragmas to be set
        -- https://github.com/commercialhaskell/stack/issues/4247
        pragmas :: [(Text, Bool)]
pragmas = [(Text, Bool)] -> [(Text, Bool)]
walPragma ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ [(Text, Bool)] -> [(Text, Bool)]
fkPragma ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, Bool)) -> [Text] -> [(Text, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (, Bool
False) ([Text] -> [(Text, Bool)]) -> [Text] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> [Text]
_extraPragmas SqliteConnectionInfo
connInfo

    [(Text, Bool)] -> ((Text, Bool) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Bool)]
pragmas (((Text, Bool) -> IO ()) -> IO ())
-> ((Text, Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
pragma, Bool
shouldRetry) -> (LoggingT IO () -> LogFunc -> IO ())
-> LogFunc -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> LogFunc -> IO ()
forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT LogFunc
logFunc (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (if Bool
shouldRetry then LoggingT IO () -> LoggingT IO ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
m a -> m a
retryOnBusy else LoggingT IO () -> LoggingT IO ()
forall a. a -> a
id) (LoggingT IO () -> LoggingT IO ())
-> LoggingT IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ do
        Statement
stmt <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
pragma
        StepResult
_ <- Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
        Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt
        Statement -> IO ()
Sqlite.finalize Statement
stmt

    IORef (Map Text Statement)
smap <- Map Text Statement -> IO (IORef (Map Text Statement))
forall a. a -> IO (IORef a)
newIORef (Map Text Statement -> IO (IORef (Map Text Statement)))
-> Map Text Statement -> IO (IORef (Map Text Statement))
forall a b. (a -> b) -> a -> b
$ Map Text Statement
forall k a. Map k a
Map.empty
    SqlBackend -> IO SqlBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (SqlBackend -> IO SqlBackend) -> SqlBackend -> IO SqlBackend
forall a b. (a -> b) -> a -> b
$
        Int -> SqlBackend -> SqlBackend
setConnMaxParams Int
999 (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
        (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnPutManySql EntityDef -> Int -> Text
putManySql (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
        (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnRepsertManySql EntityDef -> Int -> Text
repsertManySql (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
        MkSqlBackendArgs -> SqlBackend
mkSqlBackend MkSqlBackendArgs :: (Text -> IO Statement)
-> (EntityDef -> [PersistValue] -> InsertSqlResult)
-> IORef (Map Text Statement)
-> IO ()
-> ([EntityDef]
    -> (Text -> IO Statement)
    -> EntityDef
    -> IO (Either [Text] [(Bool, Text)]))
-> ((Text -> IO Statement) -> Maybe IsolationLevel -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (FieldNameDB -> Text)
-> (EntityDef -> Text)
-> (Text -> Text)
-> Text
-> Text
-> (CharPos -> Text -> Text)
-> LogFunc
-> MkSqlBackendArgs
MkSqlBackendArgs
            { connPrepare :: Text -> IO Statement
connPrepare = Connection -> Text -> IO Statement
prepare' Connection
conn
            , connStmtMap :: IORef (Map Text Statement)
connStmtMap = IORef (Map Text Statement)
smap
            , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql = EntityDef -> [PersistValue] -> InsertSqlResult
insertSql'
            , connClose :: IO ()
connClose = Connection -> IO ()
Sqlite.close Connection
conn
            , connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
connMigrateSql = [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate'
            , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin = \Text -> IO Statement
f Maybe IsolationLevel
_ -> Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"BEGIN" Text -> IO Statement
f
            , connCommit :: (Text -> IO Statement) -> IO ()
connCommit = Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"COMMIT"
            , connRollback :: (Text -> IO Statement) -> IO ()
connRollback = IO () -> IO ()
ignoreExceptions (IO () -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (Text -> IO Statement)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"ROLLBACK"
            , connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = Text -> Text
escape (Text -> Text) -> (FieldNameDB -> Text) -> FieldNameDB -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> Text
unFieldNameDB
            , connEscapeTableName :: EntityDef -> Text
connEscapeTableName = Text -> Text
escape (Text -> Text) -> (EntityDef -> Text) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
            , connEscapeRawName :: Text -> Text
connEscapeRawName = Text -> Text
escape
            , connNoLimit :: Text
connNoLimit = Text
"LIMIT -1"
            , connRDBMS :: Text
connRDBMS = Text
"sqlite"
            , connLimitOffset :: CharPos -> Text -> Text
connLimitOffset = Text -> CharPos -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT -1"
            , connLogFunc :: LogFunc
connLogFunc = LogFunc
logFunc
            }
  where
    helper :: t -> (t -> IO Statement) -> IO ()
helper t
t t -> IO Statement
getter = do
        Statement
stmt <- t -> IO Statement
getter t
t
        Int64
_ <- Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt []
        Statement -> IO ()
stmtReset Statement
stmt
    ignoreExceptions :: IO () -> IO ()
ignoreExceptions = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\(SomeException
_ :: E.SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | A convenience helper which creates a new database connection and runs the
-- given block, handling @MonadResource@ and @MonadLogger@ requirements. Note
-- that all log messages are discarded.
--
-- @since 1.1.4
runSqlite :: (MonadUnliftIO m)
          => Text -- ^ connection string
          -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -- ^ database action
          -> m a
runSqlite :: Text -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
runSqlite Text
connstr = ResourceT m a -> m a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
                  (ResourceT m a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> ResourceT m a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoLoggingT (ResourceT m) a -> ResourceT m a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT
                  (NoLoggingT (ResourceT m) a -> ResourceT m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> (SqlBackend -> NoLoggingT (ResourceT m) a)
-> NoLoggingT (ResourceT m) a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
Text -> (SqlBackend -> m a) -> m a
withSqliteConn Text
connstr
                  ((SqlBackend -> NoLoggingT (ResourceT m) a)
 -> NoLoggingT (ResourceT m) a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> SqlBackend -> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> NoLoggingT (ResourceT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> SqlBackend -> NoLoggingT (ResourceT m) a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn

-- | A convenience helper which creates a new database connection and runs the
-- given block, handling @MonadResource@ and @MonadLogger@ requirements. Note
-- that all log messages are discarded.
--
-- @since 2.6.2
runSqliteInfo :: (MonadUnliftIO m)
              => SqliteConnectionInfo
              -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -- ^ database action
              -> m a
runSqliteInfo :: SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
runSqliteInfo SqliteConnectionInfo
conInfo = ResourceT m a -> m a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
                      (ResourceT m a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> ResourceT m a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoLoggingT (ResourceT m) a -> ResourceT m a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT
                      (NoLoggingT (ResourceT m) a -> ResourceT m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteConnectionInfo
-> (SqlBackend -> NoLoggingT (ResourceT m) a)
-> NoLoggingT (ResourceT m) a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo SqliteConnectionInfo
conInfo
                      ((SqlBackend -> NoLoggingT (ResourceT m) a)
 -> NoLoggingT (ResourceT m) a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
    -> SqlBackend -> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> NoLoggingT (ResourceT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> SqlBackend -> NoLoggingT (ResourceT m) a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn

prepare' :: Sqlite.Connection -> Text -> IO Statement
prepare' :: Connection -> Text -> IO Statement
prepare' Connection
conn Text
sql = do
    Statement
stmt <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
sql
    Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement :: IO ()
-> IO ()
-> ([PersistValue] -> IO Int64)
-> (forall (m :: * -> *).
    MonadIO m =>
    [PersistValue] -> Acquire (ConduitM () [PersistValue] m ()))
-> Statement
Statement
        { stmtFinalize :: IO ()
stmtFinalize = Statement -> IO ()
Sqlite.finalize Statement
stmt
        , stmtReset :: IO ()
stmtReset = Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt
        , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = Connection -> Statement -> [PersistValue] -> IO Int64
execute' Connection
conn Statement
stmt
        , stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *).
MonadIO m =>
Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Statement
stmt
        }

insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' EntityDef
ent [PersistValue]
vals =
    case EntityDef -> EntityIdDef
getEntityId EntityDef
ent of
        EntityIdNaturalKey CompositeDef
_ ->
          Text -> [PersistValue] -> InsertSqlResult
ISRManyKeys Text
sql [PersistValue]
vals
            where sql :: Text
sql = [Text] -> Text
T.concat
                    [ Text
"INSERT INTO "
                    , EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
                    , Text
"("
                    , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) [FieldDef]
cols
                    , Text
") VALUES("
                    , Text -> [Text] -> Text
T.intercalate Text
"," ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
cols)
                    , Text
")"
                    ]
        EntityIdField FieldDef
fd ->
          Text -> Text -> InsertSqlResult
ISRInsertGet Text
ins Text
sel
            where
              sel :: Text
sel = [Text] -> Text
T.concat
                  [ Text
"SELECT "
                  , FieldNameDB -> Text
escapeF (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
fd
                  , Text
" FROM "
                  , EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
                  , Text
" WHERE _ROWID_=last_insert_rowid()"
                  ]
              ins :: Text
ins = [Text] -> Text
T.concat
                  [ Text
"INSERT INTO "
                  , EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
                  , if [FieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldDef]
cols
                        then Text
" VALUES(null)"
                        else [Text] -> Text
T.concat
                          [ Text
"("
                          , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) ([FieldDef] -> [Text]) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> a -> b
$ [FieldDef]
cols
                          , Text
") VALUES("
                          , Text -> [Text] -> Text
T.intercalate Text
"," ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
cols)
                          , Text
")"
                          ]
                  ]
  where
    notGenerated :: FieldDef -> Bool
notGenerated =
        Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool)
-> (FieldDef -> Maybe Text) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Maybe Text
fieldGenerated
    cols :: [FieldDef]
cols =
        (FieldDef -> Bool) -> [FieldDef] -> [FieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter FieldDef -> Bool
notGenerated ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields EntityDef
ent

execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64
execute' :: Connection -> Statement -> [PersistValue] -> IO Int64
execute' Connection
conn Statement
stmt [PersistValue]
vals = (IO Int64 -> IO () -> IO Int64) -> IO () -> IO Int64 -> IO Int64
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Int64 -> IO () -> IO Int64
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt) (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ do
    Statement -> [PersistValue] -> IO ()
Sqlite.bind Statement
stmt [PersistValue]
vals
    StepResult
_ <- Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
    Connection -> IO Int64
Sqlite.changes Connection
conn

withStmt'
          :: MonadIO m
          => Sqlite.Connection
          -> Sqlite.Statement
          -> [PersistValue]
          -> Acquire (ConduitM () [PersistValue] m ())
withStmt' :: Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Statement
stmt [PersistValue]
vals = do
    Statement
_ <- IO Statement -> (Statement -> IO ()) -> Acquire Statement
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire
        (Statement -> [PersistValue] -> IO ()
Sqlite.bind Statement
stmt [PersistValue]
vals IO () -> IO Statement -> IO Statement
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
stmt)
        (Connection -> Statement -> IO ()
Sqlite.reset Connection
conn)
    ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ConduitM () [PersistValue] m ()
pull
  where
    pull :: ConduitM () [PersistValue] m ()
pull = do
        StepResult
x <- IO StepResult -> ConduitT () [PersistValue] m StepResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StepResult -> ConduitT () [PersistValue] m StepResult)
-> IO StepResult -> ConduitT () [PersistValue] m StepResult
forall a b. (a -> b) -> a -> b
$ Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
        case StepResult
x of
            StepResult
Sqlite.Done -> () -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            StepResult
Sqlite.Row -> do
                [PersistValue]
cols <- IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue])
-> IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue]
forall a b. (a -> b) -> a -> b
$ Statement -> IO [PersistValue]
Sqlite.columns Statement
stmt
                [PersistValue] -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [PersistValue]
cols
                ConduitM () [PersistValue] m ()
pull

showSqlType :: SqlType -> Text
showSqlType :: SqlType -> Text
showSqlType SqlType
SqlString = Text
"VARCHAR"
showSqlType SqlType
SqlInt32 = Text
"INTEGER"
showSqlType SqlType
SqlInt64 = Text
"INTEGER"
showSqlType SqlType
SqlReal = Text
"REAL"
showSqlType (SqlNumeric Word32
precision Word32
scale) = [Text] -> Text
T.concat [ Text
"NUMERIC(", String -> Text
T.pack (Word32 -> String
forall a. Show a => a -> String
show Word32
precision), Text
",", String -> Text
T.pack (Word32 -> String
forall a. Show a => a -> String
show Word32
scale), Text
")" ]
showSqlType SqlType
SqlDay = Text
"DATE"
showSqlType SqlType
SqlTime = Text
"TIME"
showSqlType SqlType
SqlDayTime = Text
"TIMESTAMP"
showSqlType SqlType
SqlBlob = Text
"BLOB"
showSqlType SqlType
SqlBool = Text
"BOOLEAN"
showSqlType (SqlOther Text
t) = Text
t

sqliteMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
t = [EntityDef]
-> EntityDef
-> BackendSpecificOverrides
-> ([Column], [UniqueDef], [ForeignDef])
mkColumns [EntityDef]
allDefs EntityDef
t BackendSpecificOverrides
emptyBackendSpecificOverrides

migrate'
    :: [EntityDef]
    -> (Text -> IO Statement)
    -> EntityDef
    -> IO (Either [Text] [(Bool, Text)])
migrate' :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
val = do
    let ([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
val
    let newSql :: Text
newSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
False EntityDef
def ((Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Column -> Bool) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
val (FieldNameDB -> Bool) -> (Column -> FieldNameDB) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs)
    Statement
stmt <- Text -> IO Statement
getter Text
"SELECT sql FROM sqlite_master WHERE type='table' AND name=?"
    Maybe Text
oldSql' <- Acquire (ConduitM () [PersistValue] IO ())
-> (ConduitM () [PersistValue] IO () -> IO (Maybe Text))
-> IO (Maybe Text)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] IO ())
Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [Text -> PersistValue
PersistText (Text -> PersistValue) -> Text -> PersistValue
forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
table])
      (\ConduitM () [PersistValue] IO ()
src -> ConduitT () Void IO (Maybe Text) -> IO (Maybe Text)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO (Maybe Text) -> IO (Maybe Text))
-> ConduitT () Void IO (Maybe Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src ConduitM () [PersistValue] IO ()
-> ConduitM [PersistValue] Void IO (Maybe Text)
-> ConduitT () Void IO (Maybe Text)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM [PersistValue] Void IO (Maybe Text)
forall o. ConduitT [PersistValue] o IO (Maybe Text)
go)
    case Maybe Text
oldSql' of
        Maybe Text
Nothing -> Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right [(Bool
False, Text
newSql)]
        Just Text
oldSql -> do
            if Text
oldSql Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
newSql
                then Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right []
                else do
                    [(Bool, Text)]
sql <- [EntityDef]
-> (Text -> IO Statement) -> EntityDef -> IO [(Bool, Text)]
getCopyTable [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
val
                    Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right [(Bool, Text)]
sql
  where
    def :: EntityDef
def = EntityDef
val
    table :: EntityNameDB
table = EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
    go :: ConduitT [PersistValue] o IO (Maybe Text)
go = do
        Maybe [PersistValue]
x <- ConduitT [PersistValue] o IO (Maybe [PersistValue])
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        case Maybe [PersistValue]
x of
            Maybe [PersistValue]
Nothing -> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
            Just [PersistText Text
y] -> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text))
-> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
y
            Just [PersistValue]
y -> String -> ConduitT [PersistValue] o IO (Maybe Text)
forall a. HasCallStack => String -> a
error (String -> ConduitT [PersistValue] o IO (Maybe Text))
-> String -> ConduitT [PersistValue] o IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ String
"Unexpected result from sqlite_master: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
y

-- | Mock a migration even when the database is not present.
-- This function performs the same functionality of 'printMigration'
-- with the difference that an actual database isn't needed for it.
mockMigration :: Migration -> IO ()
mockMigration :: Migration -> IO ()
mockMigration Migration
mig = do
    IORef (Map Text Statement)
smap <- Map Text Statement -> IO (IORef (Map Text Statement))
forall a. a -> IO (IORef a)
newIORef (Map Text Statement -> IO (IORef (Map Text Statement)))
-> Map Text Statement -> IO (IORef (Map Text Statement))
forall a b. (a -> b) -> a -> b
$ Map Text Statement
forall k a. Map k a
Map.empty
    let sqlbackend :: SqlBackend
sqlbackend =
            Int -> SqlBackend -> SqlBackend
setConnMaxParams Int
999 (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
            MkSqlBackendArgs -> SqlBackend
mkSqlBackend MkSqlBackendArgs :: (Text -> IO Statement)
-> (EntityDef -> [PersistValue] -> InsertSqlResult)
-> IORef (Map Text Statement)
-> IO ()
-> ([EntityDef]
    -> (Text -> IO Statement)
    -> EntityDef
    -> IO (Either [Text] [(Bool, Text)]))
-> ((Text -> IO Statement) -> Maybe IsolationLevel -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (FieldNameDB -> Text)
-> (EntityDef -> Text)
-> (Text -> Text)
-> Text
-> Text
-> (CharPos -> Text -> Text)
-> LogFunc
-> MkSqlBackendArgs
MkSqlBackendArgs
                { connPrepare :: Text -> IO Statement
connPrepare = \Text
_ -> do
                    Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement :: IO ()
-> IO ()
-> ([PersistValue] -> IO Int64)
-> (forall (m :: * -> *).
    MonadIO m =>
    [PersistValue] -> Acquire (ConduitM () [PersistValue] m ()))
-> Statement
Statement
                        { stmtFinalize :: IO ()
stmtFinalize = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        , stmtReset :: IO ()
stmtReset = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        , stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = [PersistValue] -> IO Int64
forall a. HasCallStack => a
undefined
                        , stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = \[PersistValue]
_ -> ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitM () [PersistValue] m ()
 -> Acquire (ConduitM () [PersistValue] m ()))
-> ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall a b. (a -> b) -> a -> b
$ () -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        }
                , connStmtMap :: IORef (Map Text Statement)
connStmtMap = IORef (Map Text Statement)
smap
                , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql = EntityDef -> [PersistValue] -> InsertSqlResult
insertSql'
                , connClose :: IO ()
connClose = IO ()
forall a. HasCallStack => a
undefined
                , connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
connMigrateSql = [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate'
                , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin = \Text -> IO Statement
f Maybe IsolationLevel
_ -> Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"BEGIN" Text -> IO Statement
f
                , connCommit :: (Text -> IO Statement) -> IO ()
connCommit = Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"COMMIT"
                , connRollback :: (Text -> IO Statement) -> IO ()
connRollback = IO () -> IO ()
ignoreExceptions (IO () -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (Text -> IO Statement)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"ROLLBACK"
                , connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = Text -> Text
escape (Text -> Text) -> (FieldNameDB -> Text) -> FieldNameDB -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> Text
unFieldNameDB
                , connEscapeTableName :: EntityDef -> Text
connEscapeTableName = Text -> Text
escape (Text -> Text) -> (EntityDef -> Text) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
                , connEscapeRawName :: Text -> Text
connEscapeRawName = Text -> Text
escape
                , connNoLimit :: Text
connNoLimit = Text
"LIMIT -1"
                , connRDBMS :: Text
connRDBMS = Text
"sqlite"
                , connLimitOffset :: CharPos -> Text -> Text
connLimitOffset = Text -> CharPos -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT -1"
                , connLogFunc :: LogFunc
connLogFunc = LogFunc
forall a. HasCallStack => a
undefined
                }
        result :: SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result = ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
-> SqlBackend -> IO (((), [Text]), [(Bool, Text)])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
 -> SqlBackend -> IO (((), [Text]), [(Bool, Text)]))
-> (Migration
    -> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)]))
-> Migration
-> SqlBackend
-> IO (((), [Text]), [(Bool, Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
 -> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)]))
-> (Migration
    -> WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text]))
-> Migration
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration
-> WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Migration -> SqlBackend -> IO (((), [Text]), [(Bool, Text)]))
-> Migration -> SqlBackend -> IO (((), [Text]), [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ Migration
mig
    (((), [Text]), [(Bool, Text)])
resp <- SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result SqlBackend
sqlbackend
    (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
TIO.putStrLn ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Bool, Text) -> Text) -> [(Bool, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Text) -> Text
forall a b. (a, b) -> b
snd ([(Bool, Text)] -> [Text]) -> [(Bool, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ (((), [Text]), [(Bool, Text)]) -> [(Bool, Text)]
forall a b. (a, b) -> b
snd (((), [Text]), [(Bool, Text)])
resp
  where
    helper :: t -> (t -> IO Statement) -> IO ()
helper t
t t -> IO Statement
getter = do
        Statement
stmt <- t -> IO Statement
getter t
t
        Int64
_ <- Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt []
        Statement -> IO ()
stmtReset Statement
stmt
    ignoreExceptions :: IO () -> IO ()
ignoreExceptions =
        (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\(SomeException
_ :: E.SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Check if a column name is listed as the "safe to remove" in the entity
-- list.
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def (FieldNameDB Text
colName)
    = (FieldDef -> Bool) -> [FieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FieldAttr
FieldAttrSafeToRemove ([FieldAttr] -> Bool)
-> (FieldDef -> [FieldAttr]) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [FieldAttr]
fieldAttrs)
    ([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Bool) -> [FieldDef] -> [FieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldNameDB -> FieldNameDB -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameDB
FieldNameDB Text
colName) (FieldNameDB -> Bool)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB)
    ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ [FieldDef]
allEntityFields
  where
    allEntityFields :: [FieldDef]
allEntityFields =
        EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
def [FieldDef] -> [FieldDef] -> [FieldDef]
forall a. Semigroup a => a -> a -> a
<> case EntityDef -> EntityIdDef
getEntityId EntityDef
def of
            EntityIdField FieldDef
fdef ->
                [FieldDef
fdef]
            EntityIdDef
_ ->
                []

getCopyTable :: [EntityDef]
             -> (Text -> IO Statement)
             -> EntityDef
             -> IO [(Bool, Text)]
getCopyTable :: [EntityDef]
-> (Text -> IO Statement) -> EntityDef -> IO [(Bool, Text)]
getCopyTable [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
def = do
    Statement
stmt <- Text -> IO Statement
getter (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ Text
"PRAGMA table_info(", EntityNameDB -> Text
escapeE EntityNameDB
table, Text
")" ]
    [Text]
oldCols' <- Acquire (ConduitM () [PersistValue] IO ())
-> (ConduitM () [PersistValue] IO () -> IO [Text]) -> IO [Text]
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] IO ())
Statement
-> forall (m :: * -> *).
   MonadIO m =>
   [PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt []) (\ConduitM () [PersistValue] IO ()
src -> ConduitT () Void IO [Text] -> IO [Text]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO [Text] -> IO [Text])
-> ConduitT () Void IO [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src ConduitM () [PersistValue] IO ()
-> ConduitM [PersistValue] Void IO [Text]
-> ConduitT () Void IO [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM [PersistValue] Void IO [Text]
forall o. ConduitT [PersistValue] o IO [Text]
getCols)
    let oldCols :: [FieldNameDB]
oldCols = (Text -> FieldNameDB) -> [Text] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FieldNameDB
FieldNameDB [Text]
oldCols'
    let newCols :: [FieldNameDB]
newCols = (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FieldNameDB -> Bool) -> FieldNameDB -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def) ([FieldNameDB] -> [FieldNameDB]) -> [FieldNameDB] -> [FieldNameDB]
forall a b. (a -> b) -> a -> b
$ (Column -> FieldNameDB) -> [Column] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map Column -> FieldNameDB
cName [Column]
cols
    let common :: [FieldNameDB]
common = (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldNameDB -> [FieldNameDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldNameDB]
oldCols) [FieldNameDB]
newCols
    [(Bool, Text)] -> IO [(Bool, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Bool
False, Text
tmpSql)
           , (Bool
False, [FieldNameDB] -> Text
copyToTemp [FieldNameDB]
common)
           , ([FieldNameDB]
common [FieldNameDB] -> [FieldNameDB] -> Bool
forall a. Eq a => a -> a -> Bool
/= (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FieldNameDB -> Bool) -> FieldNameDB -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def) [FieldNameDB]
oldCols, Text
dropOld)
           , (Bool
False, Text
newSql)
           , (Bool
False, [FieldNameDB] -> Text
copyToFinal [FieldNameDB]
newCols)
           , (Bool
False, Text
dropTmp)
           ]
  where
    getCols :: ConduitT [PersistValue] o IO [Text]
getCols = do
        Maybe [PersistValue]
x <- ConduitT [PersistValue] o IO (Maybe [PersistValue])
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        case Maybe [PersistValue]
x of
            Maybe [PersistValue]
Nothing -> [Text] -> ConduitT [PersistValue] o IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just (PersistValue
_:PersistText Text
name:[PersistValue]
_) -> do
                [Text]
names <- ConduitT [PersistValue] o IO [Text]
getCols
                [Text] -> ConduitT [PersistValue] o IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> ConduitT [PersistValue] o IO [Text])
-> [Text] -> ConduitT [PersistValue] o IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
names
            Just [PersistValue]
y -> String -> ConduitT [PersistValue] o IO [Text]
forall a. HasCallStack => String -> a
error (String -> ConduitT [PersistValue] o IO [Text])
-> String -> ConduitT [PersistValue] o IO [Text]
forall a b. (a -> b) -> a -> b
$ String
"Invalid result from PRAGMA table_info: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
y
    table :: EntityNameDB
table = EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
    tableTmp :: EntityNameDB
tableTmp = Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_backup"
    ([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdef) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
def
    cols' :: [Column]
cols' = (Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Column -> Bool) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def (FieldNameDB -> Bool) -> (Column -> FieldNameDB) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols
    newSql :: Text
newSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
False EntityDef
def ([Column]
cols', [UniqueDef]
uniqs, [ForeignDef]
fdef)
    tmpSql :: Text
tmpSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
True (EntityNameDB -> EntityDef -> EntityDef
setEntityDBName EntityNameDB
tableTmp EntityDef
def) ([Column]
cols', [UniqueDef]
uniqs, [])
    dropTmp :: Text
dropTmp = Text
"DROP TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
    dropOld :: Text
dropOld = Text
"DROP TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
table
    copyToTemp :: [FieldNameDB] -> Text
copyToTemp [FieldNameDB]
common = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
        , Text
"("
        , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
common
        , Text
") SELECT "
        , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
common
        , Text
" FROM "
        , EntityNameDB -> Text
escapeE EntityNameDB
table
        ]
    copyToFinal :: [FieldNameDB] -> Text
copyToFinal [FieldNameDB]
newCols = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , EntityNameDB -> Text
escapeE EntityNameDB
table
        , Text
" SELECT "
        , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
newCols
        , Text
" FROM "
        , EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
        ]

mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
isTemp EntityDef
entity ([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs) =
    [Text] -> Text
T.concat ([Text]
header [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
columns [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
footer)
  where
    header :: [Text]
header =
        [ Text
"CREATE"
        , if Bool
isTemp then Text
" TEMP" else Text
""
        , Text
" TABLE "
        , EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
        , Text
"("
        ]

    footer :: [Text]
footer =
        [ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (UniqueDef -> Text) -> [UniqueDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> Text
sqlUnique [UniqueDef]
uniqs
        , [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ForeignDef -> Text) -> [ForeignDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ForeignDef -> Text
sqlForeign [ForeignDef]
fdefs
        , Text
")"
        ]

    columns :: [Text]
columns = case EntityDef -> EntityIdDef
getEntityId EntityDef
entity of
        EntityIdNaturalKey CompositeDef
pdef ->
            [ Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Column -> Text) -> [Column] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Column -> Text
sqlColumn Bool
isTemp) [Column]
cols
            , Text
", PRIMARY KEY "
            , Text
"("
            , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) ([FieldDef] -> [Text]) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldDef -> [FieldDef])
-> NonEmpty FieldDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
            , Text
")"
            ]

        EntityIdField FieldDef
fd ->
            [ FieldNameDB -> Text
escapeF (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
fd
            , Text
" "
            , SqlType -> Text
showSqlType (SqlType -> Text) -> SqlType -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> SqlType
fieldSqlType FieldDef
fd
            , Text
" PRIMARY KEY"
            , Maybe Text -> Text
mayDefault (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [FieldAttr] -> Maybe Text
defaultAttribute ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
            , [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Column -> Text) -> [Column] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Column -> Text
sqlColumn Bool
isTemp) [Column]
nonIdCols
            ]

    nonIdCols :: [Column]
nonIdCols = (Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Column
c -> FieldNameDB -> Maybe FieldNameDB
forall a. a -> Maybe a
Just (Column -> FieldNameDB
cName Column
c) Maybe FieldNameDB -> Maybe FieldNameDB -> Bool
forall a. Eq a => a -> a -> Bool
/= (FieldDef -> FieldNameDB) -> Maybe FieldDef -> Maybe FieldNameDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
entity)) [Column]
cols

mayDefault :: Maybe Text -> Text
mayDefault :: Maybe Text -> Text
mayDefault Maybe Text
def = case Maybe Text
def of
    Maybe Text
Nothing -> Text
""
    Just Text
d -> Text
" DEFAULT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d

mayGenerated :: Maybe Text -> Text
mayGenerated :: Maybe Text -> Text
mayGenerated Maybe Text
gen = case Maybe Text
gen of
    Maybe Text
Nothing -> Text
""
    Just Text
g -> Text
" GENERATED ALWAYS AS (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") STORED"

sqlColumn :: Bool -> Column -> Text
sqlColumn :: Bool -> Column -> Text
sqlColumn Bool
noRef (Column FieldNameDB
name Bool
isNull SqlType
typ Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
_cn Maybe Integer
_maxLen Maybe ColumnReference
ref) = [Text] -> Text
T.concat
    [ Text
","
    , FieldNameDB -> Text
escapeF FieldNameDB
name
    , Text
" "
    , SqlType -> Text
showSqlType SqlType
typ
    , if Bool
isNull then Text
" NULL" else Text
" NOT NULL"
    , Maybe Text -> Text
mayDefault Maybe Text
def
    , Maybe Text -> Text
mayGenerated Maybe Text
gen
    , case Maybe ColumnReference
ref of
        Maybe ColumnReference
Nothing -> Text
""
        Just ColumnReference {crTableName :: ColumnReference -> EntityNameDB
crTableName=EntityNameDB
table, crFieldCascade :: ColumnReference -> FieldCascade
crFieldCascade=FieldCascade
cascadeOpts} ->
          if Bool
noRef then Text
"" else Text
" REFERENCES " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
table
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldCascade -> Text
onDelete FieldCascade
cascadeOpts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldCascade -> Text
onUpdate FieldCascade
cascadeOpts
    ]
  where
    onDelete :: FieldCascade -> Text
onDelete FieldCascade
opts = Text -> (CascadeAction -> Text) -> Maybe CascadeAction -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
T.append Text
" ON DELETE " (Text -> Text) -> (CascadeAction -> Text) -> CascadeAction -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CascadeAction -> Text
renderCascadeAction) (FieldCascade -> Maybe CascadeAction
fcOnDelete FieldCascade
opts)
    onUpdate :: FieldCascade -> Text
onUpdate FieldCascade
opts = Text -> (CascadeAction -> Text) -> Maybe CascadeAction -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
T.append Text
" ON UPDATE " (Text -> Text) -> (CascadeAction -> Text) -> CascadeAction -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CascadeAction -> Text
renderCascadeAction) (FieldCascade -> Maybe CascadeAction
fcOnUpdate FieldCascade
opts)

sqlForeign :: ForeignDef -> Text
sqlForeign :: ForeignDef -> Text
sqlForeign ForeignDef
fdef = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
", CONSTRAINT "
    , ConstraintNameDB -> Text
escapeC (ConstraintNameDB -> Text) -> ConstraintNameDB -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef
    , Text
" FOREIGN KEY("
    , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Text)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
    -> FieldNameDB)
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
    -> (FieldNameHS, FieldNameDB))
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB)
forall a b. (a, b) -> a
fst) ([((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
 -> [Text])
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> a -> b
$ ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef
    , Text
") REFERENCES "
    , EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef
    , Text
"("
    , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Text)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
    -> FieldNameDB)
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
    -> (FieldNameHS, FieldNameDB))
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB)
forall a b. (a, b) -> b
snd) ([((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
 -> [Text])
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> a -> b
$ ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef
    , Text
")"
    ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
onDelete [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
onUpdate
  where
    onDelete :: [Text]
onDelete =
        (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
T.append Text
" ON DELETE ")
        ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe CascadeAction -> [Text]
showAction
        (Maybe CascadeAction -> [Text]) -> Maybe CascadeAction -> [Text]
forall a b. (a -> b) -> a -> b
$ FieldCascade -> Maybe CascadeAction
fcOnDelete
        (FieldCascade -> Maybe CascadeAction)
-> FieldCascade -> Maybe CascadeAction
forall a b. (a -> b) -> a -> b
$ ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef
    onUpdate :: [Text]
onUpdate =
        (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
T.append Text
" ON UPDATE ")
        ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe CascadeAction -> [Text]
showAction
        (Maybe CascadeAction -> [Text]) -> Maybe CascadeAction -> [Text]
forall a b. (a -> b) -> a -> b
$ FieldCascade -> Maybe CascadeAction
fcOnUpdate
        (FieldCascade -> Maybe CascadeAction)
-> FieldCascade -> Maybe CascadeAction
forall a b. (a -> b) -> a -> b
$ ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef

    showAction :: Maybe CascadeAction -> [Text]
showAction = Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Maybe Text -> [Text])
-> (Maybe CascadeAction -> Maybe Text)
-> Maybe CascadeAction
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CascadeAction -> Text) -> Maybe CascadeAction -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CascadeAction -> Text
renderCascadeAction

sqlUnique :: UniqueDef -> Text
sqlUnique :: UniqueDef -> Text
sqlUnique (UniqueDef ConstraintNameHS
_ ConstraintNameDB
cname NonEmpty (FieldNameHS, FieldNameDB)
cols [Text]
_) = [Text] -> Text
T.concat
    [ Text
",CONSTRAINT "
    , ConstraintNameDB -> Text
escapeC ConstraintNameDB
cname
    , Text
" UNIQUE ("
    , Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd) ([(FieldNameHS, FieldNameDB)] -> [Text])
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (FieldNameHS, FieldNameDB)
cols
    , Text
")"
    ]

escapeC :: ConstraintNameDB -> Text
escapeC :: ConstraintNameDB -> Text
escapeC = (Text -> Text) -> ConstraintNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape

escapeE :: EntityNameDB -> Text
escapeE :: EntityNameDB -> Text
escapeE = (Text -> Text) -> EntityNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape

escapeF :: FieldNameDB -> Text
escapeF :: FieldNameDB -> Text
escapeF = (Text -> Text) -> FieldNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape

escape :: Text -> Text
escape :: Text -> Text
escape Text
s =
    [Text] -> Text
T.concat [Text
q, (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
go Text
s, Text
q]
  where
    q :: Text
q = Char -> Text
T.singleton Char
'"'
    go :: Char -> Text
go Char
'"' = Text
"\"\""
    go Char
c = Char -> Text
T.singleton Char
c

putManySql :: EntityDef -> Int -> Text
putManySql :: EntityDef -> Int -> Text
putManySql EntityDef
ent Int
n = [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns ([FieldDef] -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [FieldDef]
fields) EntityDef
ent Int
n
  where
    fields :: [FieldDef]
fields = EntityDef -> [FieldDef]
getEntityFields EntityDef
ent
    conflictColumns :: [Text]
conflictColumns = (UniqueDef -> [Text]) -> [UniqueDef] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd) ([(FieldNameHS, FieldNameDB)] -> [Text])
-> (UniqueDef -> [(FieldNameHS, FieldNameDB)])
-> UniqueDef
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (FieldNameHS, FieldNameDB)
 -> [(FieldNameHS, FieldNameDB)])
-> (UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB))
-> UniqueDef
-> [(FieldNameHS, FieldNameDB)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields) (EntityDef -> [UniqueDef]
getEntityUniques EntityDef
ent)

repsertManySql :: EntityDef -> Int -> Text
repsertManySql :: EntityDef -> Int -> Text
repsertManySql EntityDef
ent Int
n = [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns (NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldDef
fields) EntityDef
ent Int
n
  where
    fields :: NonEmpty FieldDef
fields = EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent
    conflictColumns :: [Text]
conflictColumns = FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB (FieldDef -> Text) -> [FieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (EntityDef -> NonEmpty FieldDef
getEntityKeyFields EntityDef
ent)

putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns [FieldDef]
fields EntityDef
ent Int
n = Text
q
  where
    fieldDbToText :: FieldDef -> Text
fieldDbToText = FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
    mkAssignment :: Text -> Text
mkAssignment Text
f = [Text] -> Text
T.concat [Text
f, Text
"=EXCLUDED.", Text
f]

    table :: Text
table = EntityNameDB -> Text
escapeE (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName (EntityDef -> Text) -> EntityDef -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef
ent
    columns :: Text
columns = [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText [FieldDef]
fields
    placeholders :: [Text]
placeholders = (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
fields
    updates :: [Text]
updates = (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
mkAssignment (Text -> Text) -> (FieldDef -> Text) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Text
fieldDbToText) [FieldDef]
fields

    q :: Text
q = [Text] -> Text
T.concat
        [ Text
"INSERT INTO "
        , Text
table
        , Text -> Text
Util.parenWrapped Text
columns
        , Text
" VALUES "
        , [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
n
            (Text -> [Text]) -> ([Text] -> Text) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.parenWrapped (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
placeholders
        , Text
" ON CONFLICT "
        , Text -> Text
Util.parenWrapped (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
conflictColumns
        , Text
" DO UPDATE SET "
        , [Text] -> Text
Util.commaSeparated [Text]
updates
        ]

-- | Information required to setup a connection pool.
data SqliteConf = SqliteConf
    { SqliteConf -> Text
sqlDatabase :: Text
    , SqliteConf -> Int
sqlPoolSize :: Int
    }
    | SqliteConfInfo
    { SqliteConf -> SqliteConnectionInfo
sqlConnInfo :: SqliteConnectionInfo
    , sqlPoolSize :: Int
    } deriving Int -> SqliteConf -> String -> String
[SqliteConf] -> String -> String
SqliteConf -> String
(Int -> SqliteConf -> String -> String)
-> (SqliteConf -> String)
-> ([SqliteConf] -> String -> String)
-> Show SqliteConf
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SqliteConf] -> String -> String
$cshowList :: [SqliteConf] -> String -> String
show :: SqliteConf -> String
$cshow :: SqliteConf -> String
showsPrec :: Int -> SqliteConf -> String -> String
$cshowsPrec :: Int -> SqliteConf -> String -> String
Show

instance FromJSON SqliteConf where
    parseJSON :: Value -> Parser SqliteConf
parseJSON Value
v = (String -> String) -> Parser SqliteConf -> Parser SqliteConf
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (String
"Persistent: error loading Sqlite conf: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Parser SqliteConf -> Parser SqliteConf)
-> Parser SqliteConf -> Parser SqliteConf
forall a b. (a -> b) -> a -> b
$ ((Object -> Parser SqliteConf) -> Value -> Parser SqliteConf)
-> Value -> (Object -> Parser SqliteConf) -> Parser SqliteConf
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser SqliteConf) -> Value -> Parser SqliteConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SqliteConf") Value
v Object -> Parser SqliteConf
parser where
        parser :: Object -> Parser SqliteConf
parser Object
o = if Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
"database" Object
o
                      then Text -> Int -> SqliteConf
SqliteConf
                            (Text -> Int -> SqliteConf)
-> Parser Text -> Parser (Int -> SqliteConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"database"
                            Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"poolsize"
                      else SqliteConnectionInfo -> Int -> SqliteConf
SqliteConfInfo
                            (SqliteConnectionInfo -> Int -> SqliteConf)
-> Parser SqliteConnectionInfo -> Parser (Int -> SqliteConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser SqliteConnectionInfo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"connInfo"
                            Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"poolsize"

instance PersistConfig SqliteConf where
    type PersistConfigBackend SqliteConf = SqlPersistT
    type PersistConfigPool SqliteConf = ConnectionPool
    createPoolConfig :: SqliteConf -> IO (PersistConfigPool SqliteConf)
createPoolConfig (SqliteConf Text
cs Int
size) = NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend))
-> NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> Int -> NoLoggingT IO (Pool SqlBackend)
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo (Text -> SqliteConnectionInfo
conStringToInfo Text
cs) Int
size -- FIXME
    createPoolConfig (SqliteConfInfo SqliteConnectionInfo
info Int
size) = NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend))
-> NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> Int -> NoLoggingT IO (Pool SqlBackend)
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo SqliteConnectionInfo
info Int
size -- FIXME
    runPool :: SqliteConf
-> PersistConfigBackend SqliteConf m a
-> PersistConfigPool SqliteConf
-> m a
runPool SqliteConf
_ = PersistConfigBackend SqliteConf m a
-> PersistConfigPool SqliteConf -> m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool
    loadConfig :: Value -> Parser SqliteConf
loadConfig = Value -> Parser SqliteConf
forall a. FromJSON a => Value -> Parser a
parseJSON

finally :: MonadUnliftIO m
        => m a -- ^ computation to run first
        -> m b -- ^ computation to run afterward (even if an exception was raised)
        -> m a
finally :: m a -> m b -> m a
finally m a
a m b
sequel = (UnliftIO m -> IO a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO m -> IO a) -> m a) -> (UnliftIO m -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \UnliftIO m
u ->
                     IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
E.finally (UnliftIO m -> m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u m a
a)
                               (UnliftIO m -> m b -> IO b
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u m b
sequel)
{-# INLINABLE finally #-}
-- | Creates a SqliteConnectionInfo from a connection string, with the
-- default settings.
--
-- @since 2.6.2
mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo
mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo
mkSqliteConnectionInfo Text
fp = Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo
SqliteConnectionInfo Text
fp Bool
True Bool
True []

-- | Parses connection options from a connection string. Used only to provide deprecated API.
conStringToInfo :: Text -> SqliteConnectionInfo
conStringToInfo :: Text -> SqliteConnectionInfo
conStringToInfo Text
connStr = Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo
SqliteConnectionInfo Text
connStr' Bool
enableWal Bool
True [] where
    (Text
connStr', Bool
enableWal) = case () of
        ()
            | Just Text
cs <- Text -> Text -> Maybe Text
T.stripPrefix Text
"WAL=on "  Text
connStr -> (Text
cs, Bool
True)
            | Just Text
cs <- Text -> Text -> Maybe Text
T.stripPrefix Text
"WAL=off " Text
connStr -> (Text
cs, Bool
False)
            | Bool
otherwise                                   -> (Text
connStr, Bool
True)

-- | Information required to connect to a sqlite database. We export
-- lenses instead of fields to avoid being limited to the current
-- implementation.
--
-- @since 2.6.2
data SqliteConnectionInfo = SqliteConnectionInfo
    { SqliteConnectionInfo -> Text
_sqlConnectionStr :: Text -- ^ connection string for the database. Use @:memory:@ for an in-memory database.
    , SqliteConnectionInfo -> Bool
_walEnabled :: Bool -- ^ if the write-ahead log is enabled - see https://github.com/yesodweb/persistent/issues/363.
    , SqliteConnectionInfo -> Bool
_fkEnabled :: Bool -- ^ if foreign-key constraints are enabled.
    , SqliteConnectionInfo -> [Text]
_extraPragmas :: [Text] -- ^ additional pragmas to be set on initialization
    } deriving Int -> SqliteConnectionInfo -> String -> String
[SqliteConnectionInfo] -> String -> String
SqliteConnectionInfo -> String
(Int -> SqliteConnectionInfo -> String -> String)
-> (SqliteConnectionInfo -> String)
-> ([SqliteConnectionInfo] -> String -> String)
-> Show SqliteConnectionInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SqliteConnectionInfo] -> String -> String
$cshowList :: [SqliteConnectionInfo] -> String -> String
show :: SqliteConnectionInfo -> String
$cshow :: SqliteConnectionInfo -> String
showsPrec :: Int -> SqliteConnectionInfo -> String -> String
$cshowsPrec :: Int -> SqliteConnectionInfo -> String -> String
Show

instance FromJSON SqliteConnectionInfo where
    parseJSON :: Value -> Parser SqliteConnectionInfo
parseJSON Value
v = (String -> String)
-> Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (String
"Persistent: error loading SqliteConnectionInfo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo
forall a b. (a -> b) -> a -> b
$
      ((Object -> Parser SqliteConnectionInfo)
 -> Value -> Parser SqliteConnectionInfo)
-> Value
-> (Object -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser SqliteConnectionInfo)
-> Value
-> Parser SqliteConnectionInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SqliteConnectionInfo") Value
v ((Object -> Parser SqliteConnectionInfo)
 -> Parser SqliteConnectionInfo)
-> (Object -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo
SqliteConnectionInfo
        (Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Text
-> Parser (Bool -> Bool -> [Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"connectionString"
        Parser (Bool -> Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Bool -> Parser (Bool -> [Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"walEnabled"
        Parser (Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Bool -> Parser ([Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"fkEnabled"
        Parser ([Text] -> SqliteConnectionInfo)
-> Parser [Text] -> Parser SqliteConnectionInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"extraPragmas" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []

-- | Data type for reporting foreign key violations using 'checkForeignKeys'.
--
-- @since 2.11.1
data ForeignKeyViolation = ForeignKeyViolation
    { ForeignKeyViolation -> Text
foreignKeyTable :: Text -- ^ The table of the violated constraint
    , ForeignKeyViolation -> Text
foreignKeyColumn :: Text -- ^ The column of the violated constraint
    , ForeignKeyViolation -> Int64
foreignKeyRowId :: Int64 -- ^ The ROWID of the row with the violated foreign key constraint
    } deriving (ForeignKeyViolation -> ForeignKeyViolation -> Bool
(ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> (ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> Eq ForeignKeyViolation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c/= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
== :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c== :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
Eq, Eq ForeignKeyViolation
Eq ForeignKeyViolation
-> (ForeignKeyViolation -> ForeignKeyViolation -> Ordering)
-> (ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> (ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> (ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> (ForeignKeyViolation -> ForeignKeyViolation -> Bool)
-> (ForeignKeyViolation
    -> ForeignKeyViolation -> ForeignKeyViolation)
-> (ForeignKeyViolation
    -> ForeignKeyViolation -> ForeignKeyViolation)
-> Ord ForeignKeyViolation
ForeignKeyViolation -> ForeignKeyViolation -> Bool
ForeignKeyViolation -> ForeignKeyViolation -> Ordering
ForeignKeyViolation -> ForeignKeyViolation -> ForeignKeyViolation
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 :: ForeignKeyViolation -> ForeignKeyViolation -> ForeignKeyViolation
$cmin :: ForeignKeyViolation -> ForeignKeyViolation -> ForeignKeyViolation
max :: ForeignKeyViolation -> ForeignKeyViolation -> ForeignKeyViolation
$cmax :: ForeignKeyViolation -> ForeignKeyViolation -> ForeignKeyViolation
>= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c>= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
> :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c> :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
<= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c<= :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
< :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
$c< :: ForeignKeyViolation -> ForeignKeyViolation -> Bool
compare :: ForeignKeyViolation -> ForeignKeyViolation -> Ordering
$ccompare :: ForeignKeyViolation -> ForeignKeyViolation -> Ordering
$cp1Ord :: Eq ForeignKeyViolation
Ord, Int -> ForeignKeyViolation -> String -> String
[ForeignKeyViolation] -> String -> String
ForeignKeyViolation -> String
(Int -> ForeignKeyViolation -> String -> String)
-> (ForeignKeyViolation -> String)
-> ([ForeignKeyViolation] -> String -> String)
-> Show ForeignKeyViolation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ForeignKeyViolation] -> String -> String
$cshowList :: [ForeignKeyViolation] -> String -> String
show :: ForeignKeyViolation -> String
$cshow :: ForeignKeyViolation -> String
showsPrec :: Int -> ForeignKeyViolation -> String -> String
$cshowsPrec :: Int -> ForeignKeyViolation -> String -> String
Show)

-- | Outputs all (if any) the violated foreign key constraints in the database.
--
-- The main use is to validate that no foreign key constraints were
-- broken/corrupted by anyone operating on the database with foreign keys
-- disabled. See 'fkEnabled'.
--
-- @since 2.11.1
checkForeignKeys
    :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
    => ConduitM () ForeignKeyViolation m ()
checkForeignKeys :: ConduitM () ForeignKeyViolation m ()
checkForeignKeys = Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) env.
(MonadResource m, MonadReader env m,
 BackendCompatible SqlBackend env) =>
Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
rawQuery Text
query [] ConduitM () [PersistValue] m ()
-> ConduitM [PersistValue] ForeignKeyViolation m ()
-> ConduitM () ForeignKeyViolation m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ([PersistValue] -> m ForeignKeyViolation)
-> ConduitM [PersistValue] ForeignKeyViolation m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
C.mapM [PersistValue] -> m ForeignKeyViolation
forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> m ForeignKeyViolation
parse
  where
    parse :: [PersistValue] -> m ForeignKeyViolation
parse [PersistValue]
l = case [PersistValue]
l of
        [ PersistInt64 Int64
rowid , PersistText Text
table , PersistText Text
column ] ->
            ForeignKeyViolation -> m ForeignKeyViolation
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignKeyViolation :: Text -> Text -> Int64 -> ForeignKeyViolation
ForeignKeyViolation
                { foreignKeyTable :: Text
foreignKeyTable = Text
table
                , foreignKeyColumn :: Text
foreignKeyColumn = Text
column
                , foreignKeyRowId :: Int64
foreignKeyRowId = Int64
rowid
                }
        [PersistValue]
_ -> IO ForeignKeyViolation -> m ForeignKeyViolation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignKeyViolation -> m ForeignKeyViolation)
-> (Text -> IO ForeignKeyViolation)
-> Text
-> m ForeignKeyViolation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistException -> IO ForeignKeyViolation
forall e a. Exception e => e -> IO a
E.throwIO (PersistException -> IO ForeignKeyViolation)
-> (Text -> PersistException) -> Text -> IO ForeignKeyViolation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PersistException
PersistMarshalError (Text -> m ForeignKeyViolation) -> Text -> m ForeignKeyViolation
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Unexpected result from foreign key check:\n", String -> Text
T.pack ([PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
l) ]

    query :: Text
query = [Text] -> Text
T.unlines
        [ Text
"SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")"
        , Text
"FROM pragma_foreign_key_check() AS origin"
        , Text
"INNER JOIN pragma_foreign_key_list(origin.\"table\") AS foreignkeys"
        , Text
"ON origin.fkid = foreignkeys.id AND origin.parent = foreignkeys.\"table\""
        , Text
"GROUP BY origin.rowid"
        ]

-- | Like `withSqliteConnInfo`, but exposes the internal `Sqlite.Connection`.
-- For power users who want to manually interact with SQLite's C API via
-- internals exposed by "Database.Sqlite.Internal"
--
-- @since 2.10.2
withRawSqliteConnInfo
    :: (MonadUnliftIO m, MonadLoggerIO m)
    => SqliteConnectionInfo
    -> (RawSqlite SqlBackend -> m a)
    -> m a
withRawSqliteConnInfo :: SqliteConnectionInfo -> (RawSqlite SqlBackend -> m a) -> m a
withRawSqliteConnInfo SqliteConnectionInfo
connInfo RawSqlite SqlBackend -> m a
f = do
    LogFunc
logFunc <- m LogFunc
forall (m :: * -> *). MonadLoggerIO m => m LogFunc
askLoggerIO
    ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> IO (RawSqlite SqlBackend)
-> (RawSqlite SqlBackend -> IO ())
-> (RawSqlite SqlBackend -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (LogFunc -> IO (RawSqlite SqlBackend)
openBackend LogFunc
logFunc) RawSqlite SqlBackend -> IO ()
closeBackend ((RawSqlite SqlBackend -> IO a) -> IO a)
-> (RawSqlite SqlBackend -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (RawSqlite SqlBackend -> m a) -> RawSqlite SqlBackend -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSqlite SqlBackend -> m a
f
  where
    openBackend :: LogFunc -> IO (RawSqlite SqlBackend)
openBackend = (SqlBackend -> Connection -> RawSqlite SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO (RawSqlite SqlBackend)
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> RawSqlite SqlBackend
forall backend. backend -> Connection -> RawSqlite backend
RawSqlite SqliteConnectionInfo
connInfo
    closeBackend :: RawSqlite SqlBackend -> IO ()
closeBackend = SqlBackend -> IO ()
forall backend.
BackendCompatible SqlBackend backend =>
backend -> IO ()
close' (SqlBackend -> IO ())
-> (RawSqlite SqlBackend -> SqlBackend)
-> RawSqlite SqlBackend
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSqlite SqlBackend -> SqlBackend
forall backend. RawSqlite backend -> backend
_persistentBackend

-- | Like `createSqlitePoolFromInfo`, but like `withRawSqliteConnInfo` it
-- exposes the internal `Sqlite.Connection`.
--
-- For power users who want to manually interact with SQLite's C API via
-- internals exposed by "Database.Sqlite.Internal". The callback can be used to
-- run arbitrary actions on the connection upon allocation from the pool.
--
-- @since 2.10.6
createRawSqlitePoolFromInfo
    :: (MonadLoggerIO m, MonadUnliftIO m)
    => SqliteConnectionInfo
    -> (RawSqlite SqlBackend -> m ())
    -- ^ An action that is run whenever a new `RawSqlite` connection is
    -- allocated in the pool. The main use of this function is to register
    -- custom functions with the SQLite connection upon creation.
    -> Int
    -> m (Pool (RawSqlite SqlBackend))
createRawSqlitePoolFromInfo :: SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> m (Pool (RawSqlite SqlBackend))
createRawSqlitePoolFromInfo SqliteConnectionInfo
connInfo RawSqlite SqlBackend -> m ()
f Int
n = do
    m () -> IO ()
runIO <- m (m () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    let createRawSqlite :: LogFunc -> IO (RawSqlite SqlBackend)
createRawSqlite LogFunc
logFun = do
            RawSqlite SqlBackend
result <- (SqlBackend -> Connection -> RawSqlite SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO (RawSqlite SqlBackend)
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> RawSqlite SqlBackend
forall backend. backend -> Connection -> RawSqlite backend
RawSqlite SqliteConnectionInfo
connInfo LogFunc
logFun
            RawSqlite SqlBackend
result RawSqlite SqlBackend -> IO () -> IO (RawSqlite SqlBackend)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m () -> IO ()
runIO (RawSqlite SqlBackend -> m ()
f RawSqlite SqlBackend
result)

    (LogFunc -> IO (RawSqlite SqlBackend))
-> Int -> m (Pool (RawSqlite SqlBackend))
forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool LogFunc -> IO (RawSqlite SqlBackend)
createRawSqlite Int
n

-- | Like `createRawSqlitePoolFromInfo`, but doesn't require a callback
-- operating on the connection.
--
-- @since 2.10.6
createRawSqlitePoolFromInfo_
    :: (MonadLoggerIO m, MonadUnliftIO m)
    => SqliteConnectionInfo -> Int -> m (Pool (RawSqlite SqlBackend))
createRawSqlitePoolFromInfo_ :: SqliteConnectionInfo -> Int -> m (Pool (RawSqlite SqlBackend))
createRawSqlitePoolFromInfo_ SqliteConnectionInfo
connInfo =
  SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> m (Pool (RawSqlite SqlBackend))
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> m (Pool (RawSqlite SqlBackend))
createRawSqlitePoolFromInfo SqliteConnectionInfo
connInfo (m () -> RawSqlite SqlBackend -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

-- | Like `createSqlitePoolInfo`, but based on `createRawSqlitePoolFromInfo`.
--
-- @since 2.10.6
withRawSqlitePoolInfo
    :: (MonadUnliftIO m, MonadLoggerIO m)
    => SqliteConnectionInfo
    -> (RawSqlite SqlBackend -> m ())
    -> Int -- ^ number of connections to open
    -> (Pool (RawSqlite SqlBackend) -> m a)
    -> m a
withRawSqlitePoolInfo :: SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> (Pool (RawSqlite SqlBackend) -> m a)
-> m a
withRawSqlitePoolInfo SqliteConnectionInfo
connInfo RawSqlite SqlBackend -> m ()
f Int
n Pool (RawSqlite SqlBackend) -> m a
work = do
    m () -> IO ()
runIO <- m (m () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    let createRawSqlite :: LogFunc -> IO (RawSqlite SqlBackend)
createRawSqlite LogFunc
logFun = do
            RawSqlite SqlBackend
result <- (SqlBackend -> Connection -> RawSqlite SqlBackend)
-> SqliteConnectionInfo -> LogFunc -> IO (RawSqlite SqlBackend)
forall r.
(SqlBackend -> Connection -> r)
-> SqliteConnectionInfo -> LogFunc -> IO r
openWith SqlBackend -> Connection -> RawSqlite SqlBackend
forall backend. backend -> Connection -> RawSqlite backend
RawSqlite SqliteConnectionInfo
connInfo LogFunc
logFun
            RawSqlite SqlBackend
result RawSqlite SqlBackend -> IO () -> IO (RawSqlite SqlBackend)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m () -> IO ()
runIO (RawSqlite SqlBackend -> m ()
f RawSqlite SqlBackend
result)

    (LogFunc -> IO (RawSqlite SqlBackend))
-> Int -> (Pool (RawSqlite SqlBackend) -> m a) -> m a
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
 BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool LogFunc -> IO (RawSqlite SqlBackend)
createRawSqlite Int
n Pool (RawSqlite SqlBackend) -> m a
work

-- | Like `createSqlitePoolInfo`, but based on `createRawSqlitePoolFromInfo_`.
--
-- @since 2.10.6
withRawSqlitePoolInfo_
    :: (MonadUnliftIO m, MonadLoggerIO m)
    => SqliteConnectionInfo
    -> Int -- ^ number of connections to open
    -> (Pool (RawSqlite SqlBackend) -> m a)
    -> m a
withRawSqlitePoolInfo_ :: SqliteConnectionInfo
-> Int -> (Pool (RawSqlite SqlBackend) -> m a) -> m a
withRawSqlitePoolInfo_ SqliteConnectionInfo
connInfo =
  SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> (Pool (RawSqlite SqlBackend) -> m a)
-> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> (Pool (RawSqlite SqlBackend) -> m a)
-> m a
withRawSqlitePoolInfo SqliteConnectionInfo
connInfo (m () -> RawSqlite SqlBackend -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

-- | Wrapper for persistent SqlBackends that carry the corresponding
-- `Sqlite.Connection`.
--
-- @since 2.10.2
data RawSqlite backend = RawSqlite
    { RawSqlite backend -> backend
_persistentBackend :: backend -- ^ The persistent backend
    , RawSqlite backend -> Connection
_rawSqliteConnection :: Sqlite.Connection -- ^ The underlying `Sqlite.Connection`
    }

instance BackendCompatible b (RawSqlite b) where
    projectBackend :: RawSqlite b -> b
projectBackend = RawSqlite b -> b
forall backend. RawSqlite backend -> backend
_persistentBackend

#if MIN_VERSION_base(4,12,0)
instance (PersistCore b) => PersistCore (RawSqlite b) where
  newtype BackendKey (RawSqlite b) = RawSqliteKey { BackendKey (RawSqlite b) -> BackendKey (Compatible b (RawSqlite b))
unRawSqliteKey :: BackendKey (Compatible b (RawSqlite b)) }

makeCompatibleKeyInstances [t| forall b. Compatible b (RawSqlite b) |]
#else
instance (PersistCore b) => PersistCore (RawSqlite b) where
  newtype BackendKey (RawSqlite b) = RawSqliteKey { unRawSqliteKey :: BackendKey (RawSqlite b) }

deriving instance (Show (BackendKey b)) => Show (BackendKey (RawSqlite b))
deriving instance (Read (BackendKey b)) => Read (BackendKey (RawSqlite b))
deriving instance (Eq (BackendKey b)) => Eq (BackendKey (RawSqlite b))
deriving instance (Ord (BackendKey b)) => Ord (BackendKey (RawSqlite b))
deriving instance (Num (BackendKey b)) => Num (BackendKey (RawSqlite b))
deriving instance (Integral (BackendKey b)) => Integral (BackendKey (RawSqlite b))
deriving instance (PersistField (BackendKey b)) => PersistField (BackendKey (RawSqlite b))
deriving instance (PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (RawSqlite b))
deriving instance (Real (BackendKey b)) => Real (BackendKey (RawSqlite b))
deriving instance (Enum (BackendKey b)) => Enum (BackendKey (RawSqlite b))
deriving instance (Bounded (BackendKey b)) => Bounded (BackendKey (RawSqlite b))
deriving instance (ToJSON (BackendKey b)) => ToJSON (BackendKey (RawSqlite b))
deriving instance (FromJSON (BackendKey b)) => FromJSON (BackendKey (RawSqlite b))
#endif


#if MIN_VERSION_base(4,12,0)
$(pure [])

makeCompatibleInstances [t| forall b. Compatible b (RawSqlite b) |]
#else
instance HasPersistBackend b => HasPersistBackend (RawSqlite b) where
    type BaseBackend (RawSqlite b) = BaseBackend b
    persistBackend = persistBackend . _persistentBackend

instance (PersistStoreRead b) => PersistStoreRead (RawSqlite b) where
    get = withReaderT _persistentBackend . get
    getMany = withReaderT _persistentBackend . getMany

instance (PersistQueryRead b) => PersistQueryRead (RawSqlite b) where
    selectSourceRes filts opts = withReaderT _persistentBackend $ selectSourceRes filts opts
    selectFirst filts opts = withReaderT _persistentBackend $ selectFirst filts opts
    selectKeysRes filts opts = withReaderT _persistentBackend $ selectKeysRes filts opts
    count = withReaderT _persistentBackend . count
    exists = withReaderT _persistentBackend . exists

instance (PersistQueryWrite b) => PersistQueryWrite (RawSqlite b) where
    updateWhere filts updates = withReaderT _persistentBackend $ updateWhere filts updates
    deleteWhere = withReaderT _persistentBackend . deleteWhere

instance (PersistUniqueRead b) => PersistUniqueRead (RawSqlite b) where
    getBy = withReaderT _persistentBackend . getBy

instance (PersistStoreWrite b) => PersistStoreWrite (RawSqlite b) where
    insert = withReaderT _persistentBackend . insert
    insert_ = withReaderT _persistentBackend . insert_
    insertMany = withReaderT _persistentBackend . insertMany
    insertMany_ = withReaderT _persistentBackend . insertMany_
    insertEntityMany = withReaderT _persistentBackend . insertEntityMany
    insertKey k = withReaderT _persistentBackend . insertKey k
    repsert k = withReaderT _persistentBackend . repsert k
    repsertMany = withReaderT _persistentBackend . repsertMany
    replace k = withReaderT _persistentBackend . replace k
    delete = withReaderT _persistentBackend . delete
    update k = withReaderT _persistentBackend . update k
    updateGet k = withReaderT _persistentBackend . updateGet k

instance (PersistUniqueWrite b) => PersistUniqueWrite (RawSqlite b) where
    deleteBy = withReaderT _persistentBackend . deleteBy
    insertUnique = withReaderT _persistentBackend . insertUnique
    upsert rec = withReaderT _persistentBackend . upsert rec
    upsertBy uniq rec = withReaderT _persistentBackend . upsertBy uniq rec
    putMany = withReaderT _persistentBackend . putMany
#endif

makeLenses ''RawSqlite
makeLenses ''SqliteConnectionInfo