{-# 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
       , unliftIO
       , withRunInIO
       , withUnliftIO
       )
import Control.Monad.Logger
       ( MonadLoggerIO
       , NoLoggingT
       , askLoggerIO
       , logWarn
       , runLoggingT
       , runNoLoggingT
       )
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Control.Monad.Trans.Resource (MonadResource)
#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.Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
import Data.Aeson.Types (modifyFailure)
import Data.Conduit
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as CL
import Data.Foldable (toList)
import qualified Data.HashMap.Lazy as HashMap
import Data.Int (Int64)
import Data.IORef (newIORef)
import Data.Maybe
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)

#if MIN_VERSION_base(4,12,0)
import Database.Persist.Compatible
#endif
import Database.Persist.Sql
import qualified Database.Persist.Sql.Util as Util
import Database.Persist.SqlBackend
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
forall a. Monoid a => a
mempty
    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] CautiousMigration)
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 ()
-> ConduitT [PersistValue] Void IO (Maybe Text)
-> ConduitT () Void IO (Maybe Text)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT [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
forall a. Monoid a => a
mempty
    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 ()
-> ConduitT [PersistValue] Void IO [Text]
-> ConduitT () Void IO [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT [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 Key
"database" Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
`isMember` 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 -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"database"
                            Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 -> Key -> Parser SqliteConnectionInfo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"connInfo"
                            Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"poolsize"
#if MIN_VERSION_aeson(2,0,0)
        isMember :: Key -> KeyMap a -> Bool
isMember = Key -> KeyMap a -> Bool
forall a. Key -> KeyMap a -> Bool
KeyMap.member
#else
        isMember = HashMap.member
#endif

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 -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"fkEnabled"
        Parser ([Text] -> SqliteConnectionInfo)
-> Parser [Text] -> Parser SqliteConnectionInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"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 ()
-> ConduitT [PersistValue] ForeignKeyViolation m ()
-> ConduitM () ForeignKeyViolation m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([PersistValue] -> m ForeignKeyViolation)
-> ConduitT [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