{-# 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 #-}
#if MIN_VERSION_base(4,12,0)
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
#endif
module Database.Persist.Sqlite
( withSqlitePool
, withSqlitePoolInfo
, withSqliteConn
, withSqliteConnInfo
, createSqlitePool
, createSqlitePoolFromInfo
, module Database.Persist.Sql
, SqliteConf (..)
, SqliteConnectionInfo
, mkSqliteConnectionInfo
, sqlConnectionStr
, walEnabled
, fkEnabled
, extraPragmas
, runSqlite
, runSqliteInfo
, wrapConnection
, wrapConnectionInfo
, mockMigration
, retryOnBusy
, waitForDatabase
, ForeignKeyViolation(..)
, checkForeignKeys
, RawSqlite
, persistentBackend
, rawSqliteConnection
, withRawSqliteConnInfo
, createRawSqlitePoolFromInfo
, createRawSqlitePoolFromInfo_
, withRawSqlitePoolInfo
, withRawSqlitePoolInfo_
) where
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Control.Monad (forM_)
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, askRunInIO, withRunInIO, withUnliftIO, unliftIO, withRunInIO)
import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLoggerIO, logWarn, runLoggingT, askLoggerIO)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
#if !MIN_VERSION_base(4,12,0)
import Control.Monad.Trans.Reader (withReaderT)
#endif
import Control.Monad.Trans.Writer (runWriterT)
import Data.Acquire (Acquire, mkAcquire, with)
import Data.Maybe
import Data.Aeson
import Data.Aeson.Types (modifyFailure)
import Data.Conduit
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Lazy as HashMap
import Data.Int (Int64)
import Data.IORef
import qualified Data.Map as Map
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Lens.Micro.TH (makeLenses)
import UnliftIO.Resource (ResourceT, runResourceT)
import Data.Foldable (toList)
#if MIN_VERSION_base(4,12,0)
import Database.Persist.Compatible
#endif
import Database.Persist.Sql
import Database.Persist.SqlBackend
import qualified Database.Persist.Sql.Util as Util
import qualified Database.Sqlite as Sqlite
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
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
withSqlitePool :: (MonadUnliftIO m, MonadLoggerIO m)
=> Text
-> Int
-> (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
withSqlitePoolInfo :: (MonadUnliftIO m, MonadLoggerIO m)
=> SqliteConnectionInfo
-> Int
-> (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
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
wrapConnection :: Sqlite.Connection -> LogFunc -> IO SqlBackend
wrapConnection :: Connection -> LogFunc -> IO SqlBackend
wrapConnection = SqliteConnectionInfo -> Connection -> LogFunc -> IO SqlBackend
wrapConnectionInfo (Text -> SqliteConnectionInfo
mkSqliteConnectionInfo Text
"")
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
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
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" []
wrapConnectionInfo
:: SqliteConnectionInfo
-> Sqlite.Connection
-> LogFunc
-> IO SqlBackend
wrapConnectionInfo :: SqliteConnectionInfo -> Connection -> LogFunc -> IO SqlBackend
wrapConnectionInfo SqliteConnectionInfo
connInfo Connection
conn LogFunc
logFunc = do
let
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
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
pragmas :: [(Text, Bool)]
pragmas = [(Text, Bool)] -> [(Text, Bool)]
walPragma ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ [(Text, Bool)] -> [(Text, Bool)]
fkPragma ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, Bool)) -> [Text] -> [(Text, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (, Bool
False) ([Text] -> [(Text, Bool)]) -> [Text] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> [Text]
_extraPragmas SqliteConnectionInfo
connInfo
[(Text, Bool)] -> ((Text, Bool) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Bool)]
pragmas (((Text, Bool) -> IO ()) -> IO ())
-> ((Text, Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
pragma, Bool
shouldRetry) -> (LoggingT IO () -> LogFunc -> IO ())
-> LogFunc -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> LogFunc -> IO ()
forall (m :: * -> *) a. LoggingT m a -> LogFunc -> m a
runLoggingT LogFunc
logFunc (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(if Bool
shouldRetry then LoggingT IO () -> LoggingT IO ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
m a -> m a
retryOnBusy else LoggingT IO () -> LoggingT IO ()
forall a. a -> a
id) (LoggingT IO () -> LoggingT IO ())
-> LoggingT IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> LoggingT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LoggingT IO ()) -> IO () -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ do
Statement
stmt <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
pragma
StepResult
_ <- Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt
Statement -> IO ()
Sqlite.finalize Statement
stmt
IORef (Map Text Statement)
smap <- Map Text Statement -> IO (IORef (Map Text Statement))
forall a. a -> IO (IORef a)
newIORef (Map Text Statement -> IO (IORef (Map Text Statement)))
-> Map Text Statement -> IO (IORef (Map Text Statement))
forall a b. (a -> b) -> a -> b
$ Map Text Statement
forall k a. Map k a
Map.empty
SqlBackend -> IO SqlBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (SqlBackend -> IO SqlBackend) -> SqlBackend -> IO SqlBackend
forall a b. (a -> b) -> a -> b
$
Int -> SqlBackend -> SqlBackend
setConnMaxParams Int
999 (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
(EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnPutManySql EntityDef -> Int -> Text
putManySql (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
(EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnRepsertManySql EntityDef -> Int -> Text
repsertManySql (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
MkSqlBackendArgs -> SqlBackend
mkSqlBackend MkSqlBackendArgs :: (Text -> IO Statement)
-> (EntityDef -> [PersistValue] -> InsertSqlResult)
-> IORef (Map Text Statement)
-> IO ()
-> ([EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)]))
-> ((Text -> IO Statement) -> Maybe IsolationLevel -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (FieldNameDB -> Text)
-> (EntityDef -> Text)
-> (Text -> Text)
-> Text
-> Text
-> (CharPos -> Text -> Text)
-> LogFunc
-> MkSqlBackendArgs
MkSqlBackendArgs
{ connPrepare :: Text -> IO Statement
connPrepare = Connection -> Text -> IO Statement
prepare' Connection
conn
, connStmtMap :: IORef (Map Text Statement)
connStmtMap = IORef (Map Text Statement)
smap
, connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql = EntityDef -> [PersistValue] -> InsertSqlResult
insertSql'
, connClose :: IO ()
connClose = Connection -> IO ()
Sqlite.close Connection
conn
, connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
connMigrateSql = [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate'
, connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin = \Text -> IO Statement
f Maybe IsolationLevel
_ -> Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"BEGIN" Text -> IO Statement
f
, connCommit :: (Text -> IO Statement) -> IO ()
connCommit = Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"COMMIT"
, connRollback :: (Text -> IO Statement) -> IO ()
connRollback = IO () -> IO ()
ignoreExceptions (IO () -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (Text -> IO Statement)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"ROLLBACK"
, connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = Text -> Text
escape (Text -> Text) -> (FieldNameDB -> Text) -> FieldNameDB -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> Text
unFieldNameDB
, connEscapeTableName :: EntityDef -> Text
connEscapeTableName = Text -> Text
escape (Text -> Text) -> (EntityDef -> Text) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
, connEscapeRawName :: Text -> Text
connEscapeRawName = Text -> Text
escape
, connNoLimit :: Text
connNoLimit = Text
"LIMIT -1"
, connRDBMS :: Text
connRDBMS = Text
"sqlite"
, connLimitOffset :: CharPos -> Text -> Text
connLimitOffset = Text -> CharPos -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT -1"
, connLogFunc :: LogFunc
connLogFunc = LogFunc
logFunc
}
where
helper :: t -> (t -> IO Statement) -> IO ()
helper t
t t -> IO Statement
getter = do
Statement
stmt <- t -> IO Statement
getter t
t
Int64
_ <- Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt []
Statement -> IO ()
stmtReset Statement
stmt
ignoreExceptions :: IO () -> IO ()
ignoreExceptions = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\(SomeException
_ :: E.SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
runSqlite :: (MonadUnliftIO m)
=> Text
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> 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
runSqliteInfo :: (MonadUnliftIO m)
=> SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> m a
runSqliteInfo :: SqliteConnectionInfo
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
runSqliteInfo SqliteConnectionInfo
conInfo = ResourceT m a -> m a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
(ResourceT m a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> ResourceT m a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoLoggingT (ResourceT m) a -> ResourceT m a
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT
(NoLoggingT (ResourceT m) a -> ResourceT m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqliteConnectionInfo
-> (SqlBackend -> NoLoggingT (ResourceT m) a)
-> NoLoggingT (ResourceT m) a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
SqliteConnectionInfo -> (SqlBackend -> m a) -> m a
withSqliteConnInfo SqliteConnectionInfo
conInfo
((SqlBackend -> NoLoggingT (ResourceT m) a)
-> NoLoggingT (ResourceT m) a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> SqlBackend -> NoLoggingT (ResourceT m) a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> NoLoggingT (ResourceT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (NoLoggingT (ResourceT m)) a
-> SqlBackend -> NoLoggingT (ResourceT m) a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> backend -> m a
runSqlConn
prepare' :: Sqlite.Connection -> Text -> IO Statement
prepare' :: Connection -> Text -> IO Statement
prepare' Connection
conn Text
sql = do
Statement
stmt <- Connection -> Text -> IO Statement
Sqlite.prepare Connection
conn Text
sql
Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement :: IO ()
-> IO ()
-> ([PersistValue] -> IO Int64)
-> (forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ()))
-> Statement
Statement
{ stmtFinalize :: IO ()
stmtFinalize = Statement -> IO ()
Sqlite.finalize Statement
stmt
, stmtReset :: IO ()
stmtReset = Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt
, stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = Connection -> Statement -> [PersistValue] -> IO Int64
execute' Connection
conn Statement
stmt
, stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *).
MonadIO m =>
Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Statement
stmt
}
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' EntityDef
ent [PersistValue]
vals =
case EntityDef -> EntityIdDef
getEntityId EntityDef
ent of
EntityIdNaturalKey CompositeDef
_ ->
Text -> [PersistValue] -> InsertSqlResult
ISRManyKeys Text
sql [PersistValue]
vals
where sql :: Text
sql = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) [FieldDef]
cols
, Text
") VALUES("
, Text -> [Text] -> Text
T.intercalate Text
"," ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
cols)
, Text
")"
]
EntityIdField FieldDef
fd ->
Text -> Text -> InsertSqlResult
ISRInsertGet Text
ins Text
sel
where
sel :: Text
sel = [Text] -> Text
T.concat
[ Text
"SELECT "
, FieldNameDB -> Text
escapeF (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
fd
, Text
" FROM "
, EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
, Text
" WHERE _ROWID_=last_insert_rowid()"
]
ins :: Text
ins = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
, if [FieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldDef]
cols
then Text
" VALUES(null)"
else [Text] -> Text
T.concat
[ Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) ([FieldDef] -> [Text]) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> a -> b
$ [FieldDef]
cols
, Text
") VALUES("
, Text -> [Text] -> Text
T.intercalate Text
"," ((FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
cols)
, Text
")"
]
]
where
notGenerated :: FieldDef -> Bool
notGenerated =
Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool)
-> (FieldDef -> Maybe Text) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Maybe Text
fieldGenerated
cols :: [FieldDef]
cols =
(FieldDef -> Bool) -> [FieldDef] -> [FieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter FieldDef -> Bool
notGenerated ([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields EntityDef
ent
execute' :: Sqlite.Connection -> Sqlite.Statement -> [PersistValue] -> IO Int64
execute' :: Connection -> Statement -> [PersistValue] -> IO Int64
execute' Connection
conn Statement
stmt [PersistValue]
vals = (IO Int64 -> IO () -> IO Int64) -> IO () -> IO Int64 -> IO Int64
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Int64 -> IO () -> IO Int64
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Statement -> IO ()
Sqlite.reset Connection
conn Statement
stmt) (IO Int64 -> IO Int64) -> IO Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ do
Statement -> [PersistValue] -> IO ()
Sqlite.bind Statement
stmt [PersistValue]
vals
StepResult
_ <- Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
Connection -> IO Int64
Sqlite.changes Connection
conn
withStmt'
:: MonadIO m
=> Sqlite.Connection
-> Sqlite.Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' :: Connection
-> Statement
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Statement
stmt [PersistValue]
vals = do
Statement
_ <- IO Statement -> (Statement -> IO ()) -> Acquire Statement
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire
(Statement -> [PersistValue] -> IO ()
Sqlite.bind Statement
stmt [PersistValue]
vals IO () -> IO Statement -> IO Statement
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
stmt)
(Connection -> Statement -> IO ()
Sqlite.reset Connection
conn)
ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ConduitM () [PersistValue] m ()
pull
where
pull :: ConduitM () [PersistValue] m ()
pull = do
StepResult
x <- IO StepResult -> ConduitT () [PersistValue] m StepResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StepResult -> ConduitT () [PersistValue] m StepResult)
-> IO StepResult -> ConduitT () [PersistValue] m StepResult
forall a b. (a -> b) -> a -> b
$ Connection -> Statement -> IO StepResult
Sqlite.stepConn Connection
conn Statement
stmt
case StepResult
x of
StepResult
Sqlite.Done -> () -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
StepResult
Sqlite.Row -> do
[PersistValue]
cols <- IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue])
-> IO [PersistValue] -> ConduitT () [PersistValue] m [PersistValue]
forall a b. (a -> b) -> a -> b
$ Statement -> IO [PersistValue]
Sqlite.columns Statement
stmt
[PersistValue] -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [PersistValue]
cols
ConduitM () [PersistValue] m ()
pull
showSqlType :: SqlType -> Text
showSqlType :: SqlType -> Text
showSqlType SqlType
SqlString = Text
"VARCHAR"
showSqlType SqlType
SqlInt32 = Text
"INTEGER"
showSqlType SqlType
SqlInt64 = Text
"INTEGER"
showSqlType SqlType
SqlReal = Text
"REAL"
showSqlType (SqlNumeric Word32
precision Word32
scale) = [Text] -> Text
T.concat [ Text
"NUMERIC(", String -> Text
T.pack (Word32 -> String
forall a. Show a => a -> String
show Word32
precision), Text
",", String -> Text
T.pack (Word32 -> String
forall a. Show a => a -> String
show Word32
scale), Text
")" ]
showSqlType SqlType
SqlDay = Text
"DATE"
showSqlType SqlType
SqlTime = Text
"TIME"
showSqlType SqlType
SqlDayTime = Text
"TIMESTAMP"
showSqlType SqlType
SqlBlob = Text
"BLOB"
showSqlType SqlType
SqlBool = Text
"BOOLEAN"
showSqlType (SqlOther Text
t) = Text
t
sqliteMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
t = [EntityDef]
-> EntityDef
-> BackendSpecificOverrides
-> ([Column], [UniqueDef], [ForeignDef])
mkColumns [EntityDef]
allDefs EntityDef
t BackendSpecificOverrides
emptyBackendSpecificOverrides
migrate'
:: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
val = do
let ([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
val
let newSql :: Text
newSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
False EntityDef
def ((Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Column -> Bool) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
val (FieldNameDB -> Bool) -> (Column -> FieldNameDB) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs)
Statement
stmt <- Text -> IO Statement
getter Text
"SELECT sql FROM sqlite_master WHERE type='table' AND name=?"
Maybe Text
oldSql' <- Acquire (ConduitM () [PersistValue] IO ())
-> (ConduitM () [PersistValue] IO () -> IO (Maybe Text))
-> IO (Maybe Text)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] IO ())
Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [Text -> PersistValue
PersistText (Text -> PersistValue) -> Text -> PersistValue
forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
table])
(\ConduitM () [PersistValue] IO ()
src -> ConduitT () Void IO (Maybe Text) -> IO (Maybe Text)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO (Maybe Text) -> IO (Maybe Text))
-> ConduitT () Void IO (Maybe Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src ConduitM () [PersistValue] IO ()
-> ConduitM [PersistValue] Void IO (Maybe Text)
-> ConduitT () Void IO (Maybe Text)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM [PersistValue] Void IO (Maybe Text)
forall o. ConduitT [PersistValue] o IO (Maybe Text)
go)
case Maybe Text
oldSql' of
Maybe Text
Nothing -> Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right [(Bool
False, Text
newSql)]
Just Text
oldSql -> do
if Text
oldSql Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
newSql
then Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right []
else do
[(Bool, Text)]
sql <- [EntityDef]
-> (Text -> IO Statement) -> EntityDef -> IO [(Bool, Text)]
getCopyTable [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
val
Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] [(Bool, Text)] -> IO (Either [Text] [(Bool, Text)]))
-> Either [Text] [(Bool, Text)]
-> IO (Either [Text] [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Either [Text] [(Bool, Text)]
forall a b. b -> Either a b
Right [(Bool, Text)]
sql
where
def :: EntityDef
def = EntityDef
val
table :: EntityNameDB
table = EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
go :: ConduitT [PersistValue] o IO (Maybe Text)
go = do
Maybe [PersistValue]
x <- ConduitT [PersistValue] o IO (Maybe [PersistValue])
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
case Maybe [PersistValue]
x of
Maybe [PersistValue]
Nothing -> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
Just [PersistText Text
y] -> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text))
-> Maybe Text -> ConduitT [PersistValue] o IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
y
Just [PersistValue]
y -> String -> ConduitT [PersistValue] o IO (Maybe Text)
forall a. HasCallStack => String -> a
error (String -> ConduitT [PersistValue] o IO (Maybe Text))
-> String -> ConduitT [PersistValue] o IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ String
"Unexpected result from sqlite_master: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
y
mockMigration :: Migration -> IO ()
mockMigration :: Migration -> IO ()
mockMigration Migration
mig = do
IORef (Map Text Statement)
smap <- Map Text Statement -> IO (IORef (Map Text Statement))
forall a. a -> IO (IORef a)
newIORef (Map Text Statement -> IO (IORef (Map Text Statement)))
-> Map Text Statement -> IO (IORef (Map Text Statement))
forall a b. (a -> b) -> a -> b
$ Map Text Statement
forall k a. Map k a
Map.empty
let sqlbackend :: SqlBackend
sqlbackend =
Int -> SqlBackend -> SqlBackend
setConnMaxParams Int
999 (SqlBackend -> SqlBackend) -> SqlBackend -> SqlBackend
forall a b. (a -> b) -> a -> b
$
MkSqlBackendArgs -> SqlBackend
mkSqlBackend MkSqlBackendArgs :: (Text -> IO Statement)
-> (EntityDef -> [PersistValue] -> InsertSqlResult)
-> IORef (Map Text Statement)
-> IO ()
-> ([EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)]))
-> ((Text -> IO Statement) -> Maybe IsolationLevel -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (FieldNameDB -> Text)
-> (EntityDef -> Text)
-> (Text -> Text)
-> Text
-> Text
-> (CharPos -> Text -> Text)
-> LogFunc
-> MkSqlBackendArgs
MkSqlBackendArgs
{ connPrepare :: Text -> IO Statement
connPrepare = \Text
_ -> do
Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement :: IO ()
-> IO ()
-> ([PersistValue] -> IO Int64)
-> (forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ()))
-> Statement
Statement
{ stmtFinalize :: IO ()
stmtFinalize = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtReset :: IO ()
stmtReset = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = [PersistValue] -> IO Int64
forall a. HasCallStack => a
undefined
, stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = \[PersistValue]
_ -> ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ()))
-> ConduitM () [PersistValue] m ()
-> Acquire (ConduitM () [PersistValue] m ())
forall a b. (a -> b) -> a -> b
$ () -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
, connStmtMap :: IORef (Map Text Statement)
connStmtMap = IORef (Map Text Statement)
smap
, connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql = EntityDef -> [PersistValue] -> InsertSqlResult
insertSql'
, connClose :: IO ()
connClose = IO ()
forall a. HasCallStack => a
undefined
, connMigrateSql :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
connMigrateSql = [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate'
, connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin = \Text -> IO Statement
f Maybe IsolationLevel
_ -> Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"BEGIN" Text -> IO Statement
f
, connCommit :: (Text -> IO Statement) -> IO ()
connCommit = Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"COMMIT"
, connRollback :: (Text -> IO Statement) -> IO ()
connRollback = IO () -> IO ()
ignoreExceptions (IO () -> IO ())
-> ((Text -> IO Statement) -> IO ())
-> (Text -> IO Statement)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text -> IO Statement) -> IO ()
forall t. t -> (t -> IO Statement) -> IO ()
helper Text
"ROLLBACK"
, connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = Text -> Text
escape (Text -> Text) -> (FieldNameDB -> Text) -> FieldNameDB -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameDB -> Text
unFieldNameDB
, connEscapeTableName :: EntityDef -> Text
connEscapeTableName = Text -> Text
escape (Text -> Text) -> (EntityDef -> Text) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
, connEscapeRawName :: Text -> Text
connEscapeRawName = Text -> Text
escape
, connNoLimit :: Text
connNoLimit = Text
"LIMIT -1"
, connRDBMS :: Text
connRDBMS = Text
"sqlite"
, connLimitOffset :: CharPos -> Text -> Text
connLimitOffset = Text -> CharPos -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT -1"
, connLogFunc :: LogFunc
connLogFunc = LogFunc
forall a. HasCallStack => a
undefined
}
result :: SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result = ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
-> SqlBackend -> IO (((), [Text]), [(Bool, Text)])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
-> SqlBackend -> IO (((), [Text]), [(Bool, Text)]))
-> (Migration
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)]))
-> Migration
-> SqlBackend
-> IO (((), [Text]), [(Bool, Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)]))
-> (Migration
-> WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text]))
-> Migration
-> ReaderT SqlBackend IO (((), [Text]), [(Bool, Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration
-> WriterT [(Bool, Text)] (ReaderT SqlBackend IO) ((), [Text])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Migration -> SqlBackend -> IO (((), [Text]), [(Bool, Text)]))
-> Migration -> SqlBackend -> IO (((), [Text]), [(Bool, Text)])
forall a b. (a -> b) -> a -> b
$ Migration
mig
(((), [Text]), [(Bool, Text)])
resp <- SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result SqlBackend
sqlbackend
(Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
TIO.putStrLn ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Bool, Text) -> Text) -> [(Bool, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Text) -> Text
forall a b. (a, b) -> b
snd ([(Bool, Text)] -> [Text]) -> [(Bool, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ (((), [Text]), [(Bool, Text)]) -> [(Bool, Text)]
forall a b. (a, b) -> b
snd (((), [Text]), [(Bool, Text)])
resp
where
helper :: t -> (t -> IO Statement) -> IO ()
helper t
t t -> IO Statement
getter = do
Statement
stmt <- t -> IO Statement
getter t
t
Int64
_ <- Statement -> [PersistValue] -> IO Int64
stmtExecute Statement
stmt []
Statement -> IO ()
stmtReset Statement
stmt
ignoreExceptions :: IO () -> IO ()
ignoreExceptions =
(SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\(SomeException
_ :: E.SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def (FieldNameDB Text
colName)
= (FieldDef -> Bool) -> [FieldDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FieldAttr -> [FieldAttr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FieldAttr
FieldAttrSafeToRemove ([FieldAttr] -> Bool)
-> (FieldDef -> [FieldAttr]) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [FieldAttr]
fieldAttrs)
([FieldDef] -> Bool) -> [FieldDef] -> Bool
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Bool) -> [FieldDef] -> [FieldDef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldNameDB -> FieldNameDB -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameDB
FieldNameDB Text
colName) (FieldNameDB -> Bool)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB)
([FieldDef] -> [FieldDef]) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ [FieldDef]
allEntityFields
where
allEntityFields :: [FieldDef]
allEntityFields =
EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
def [FieldDef] -> [FieldDef] -> [FieldDef]
forall a. Semigroup a => a -> a -> a
<> case EntityDef -> EntityIdDef
getEntityId EntityDef
def of
EntityIdField FieldDef
fdef ->
[FieldDef
fdef]
EntityIdDef
_ ->
[]
getCopyTable :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO [(Bool, Text)]
getCopyTable :: [EntityDef]
-> (Text -> IO Statement) -> EntityDef -> IO [(Bool, Text)]
getCopyTable [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
def = do
Statement
stmt <- Text -> IO Statement
getter (Text -> IO Statement) -> Text -> IO Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ Text
"PRAGMA table_info(", EntityNameDB -> Text
escapeE EntityNameDB
table, Text
")" ]
[Text]
oldCols' <- Acquire (ConduitM () [PersistValue] IO ())
-> (ConduitM () [PersistValue] IO () -> IO [Text]) -> IO [Text]
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> [PersistValue] -> Acquire (ConduitM () [PersistValue] IO ())
Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt []) (\ConduitM () [PersistValue] IO ()
src -> ConduitT () Void IO [Text] -> IO [Text]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO [Text] -> IO [Text])
-> ConduitT () Void IO [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src ConduitM () [PersistValue] IO ()
-> ConduitM [PersistValue] Void IO [Text]
-> ConduitT () Void IO [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM [PersistValue] Void IO [Text]
forall o. ConduitT [PersistValue] o IO [Text]
getCols)
let oldCols :: [FieldNameDB]
oldCols = (Text -> FieldNameDB) -> [Text] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FieldNameDB
FieldNameDB [Text]
oldCols'
let newCols :: [FieldNameDB]
newCols = (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FieldNameDB -> Bool) -> FieldNameDB -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def) ([FieldNameDB] -> [FieldNameDB]) -> [FieldNameDB] -> [FieldNameDB]
forall a b. (a -> b) -> a -> b
$ (Column -> FieldNameDB) -> [Column] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map Column -> FieldNameDB
cName [Column]
cols
let common :: [FieldNameDB]
common = (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldNameDB -> [FieldNameDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldNameDB]
oldCols) [FieldNameDB]
newCols
[(Bool, Text)] -> IO [(Bool, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Bool
False, Text
tmpSql)
, (Bool
False, [FieldNameDB] -> Text
copyToTemp [FieldNameDB]
common)
, ([FieldNameDB]
common [FieldNameDB] -> [FieldNameDB] -> Bool
forall a. Eq a => a -> a -> Bool
/= (FieldNameDB -> Bool) -> [FieldNameDB] -> [FieldNameDB]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FieldNameDB -> Bool) -> FieldNameDB -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def) [FieldNameDB]
oldCols, Text
dropOld)
, (Bool
False, Text
newSql)
, (Bool
False, [FieldNameDB] -> Text
copyToFinal [FieldNameDB]
newCols)
, (Bool
False, Text
dropTmp)
]
where
getCols :: ConduitT [PersistValue] o IO [Text]
getCols = do
Maybe [PersistValue]
x <- ConduitT [PersistValue] o IO (Maybe [PersistValue])
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
case Maybe [PersistValue]
x of
Maybe [PersistValue]
Nothing -> [Text] -> ConduitT [PersistValue] o IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (PersistValue
_:PersistText Text
name:[PersistValue]
_) -> do
[Text]
names <- ConduitT [PersistValue] o IO [Text]
getCols
[Text] -> ConduitT [PersistValue] o IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> ConduitT [PersistValue] o IO [Text])
-> [Text] -> ConduitT [PersistValue] o IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
names
Just [PersistValue]
y -> String -> ConduitT [PersistValue] o IO [Text]
forall a. HasCallStack => String -> a
error (String -> ConduitT [PersistValue] o IO [Text])
-> String -> ConduitT [PersistValue] o IO [Text]
forall a b. (a -> b) -> a -> b
$ String
"Invalid result from PRAGMA table_info: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
y
table :: EntityNameDB
table = EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
tableTmp :: EntityNameDB
tableTmp = Text -> EntityNameDB
EntityNameDB (Text -> EntityNameDB) -> Text -> EntityNameDB
forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_backup"
([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdef) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
sqliteMkColumns [EntityDef]
allDefs EntityDef
def
cols' :: [Column]
cols' = (Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Column -> Bool) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def (FieldNameDB -> Bool) -> (Column -> FieldNameDB) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
cols
newSql :: Text
newSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
False EntityDef
def ([Column]
cols', [UniqueDef]
uniqs, [ForeignDef]
fdef)
tmpSql :: Text
tmpSql = Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
True (EntityNameDB -> EntityDef -> EntityDef
setEntityDBName EntityNameDB
tableTmp EntityDef
def) ([Column]
cols', [UniqueDef]
uniqs, [])
dropTmp :: Text
dropTmp = Text
"DROP TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
dropOld :: Text
dropOld = Text
"DROP TABLE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
table
copyToTemp :: [FieldNameDB] -> Text
copyToTemp [FieldNameDB]
common = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
common
, Text
") SELECT "
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
common
, Text
" FROM "
, EntityNameDB -> Text
escapeE EntityNameDB
table
]
copyToFinal :: [FieldNameDB] -> Text
copyToFinal [FieldNameDB]
newCols = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" SELECT "
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> [FieldNameDB] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
newCols
, Text
" FROM "
, EntityNameDB -> Text
escapeE EntityNameDB
tableTmp
]
mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -> Text
mkCreateTable Bool
isTemp EntityDef
entity ([Column]
cols, [UniqueDef]
uniqs, [ForeignDef]
fdefs) =
[Text] -> Text
T.concat ([Text]
header [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
columns [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
footer)
where
header :: [Text]
header =
[ Text
"CREATE"
, if Bool
isTemp then Text
" TEMP" else Text
""
, Text
" TABLE "
, EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
, Text
"("
]
footer :: [Text]
footer =
[ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (UniqueDef -> Text) -> [UniqueDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> Text
sqlUnique [UniqueDef]
uniqs
, [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ForeignDef -> Text) -> [ForeignDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ForeignDef -> Text
sqlForeign [ForeignDef]
fdefs
, Text
")"
]
columns :: [Text]
columns = case EntityDef -> EntityIdDef
getEntityId EntityDef
entity of
EntityIdNaturalKey CompositeDef
pdef ->
[ Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Column -> Text) -> [Column] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Column -> Text
sqlColumn Bool
isTemp) [Column]
cols
, Text
", PRIMARY KEY "
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) ([FieldDef] -> [Text]) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldDef -> [FieldDef])
-> NonEmpty FieldDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
, Text
")"
]
EntityIdField FieldDef
fd ->
[ FieldNameDB -> Text
escapeF (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
fd
, Text
" "
, SqlType -> Text
showSqlType (SqlType -> Text) -> SqlType -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> SqlType
fieldSqlType FieldDef
fd
, Text
" PRIMARY KEY"
, Maybe Text -> Text
mayDefault (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [FieldAttr] -> Maybe Text
defaultAttribute ([FieldAttr] -> Maybe Text) -> [FieldAttr] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
fd
, [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Column -> Text) -> [Column] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Column -> Text
sqlColumn Bool
isTemp) [Column]
nonIdCols
]
nonIdCols :: [Column]
nonIdCols = (Column -> Bool) -> [Column] -> [Column]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Column
c -> FieldNameDB -> Maybe FieldNameDB
forall a. a -> Maybe a
Just (Column -> FieldNameDB
cName Column
c) Maybe FieldNameDB -> Maybe FieldNameDB -> Bool
forall a. Eq a => a -> a -> Bool
/= (FieldDef -> FieldNameDB) -> Maybe FieldDef -> Maybe FieldNameDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
entity)) [Column]
cols
mayDefault :: Maybe Text -> Text
mayDefault :: Maybe Text -> Text
mayDefault Maybe Text
def = case Maybe Text
def of
Maybe Text
Nothing -> Text
""
Just Text
d -> Text
" DEFAULT " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d
mayGenerated :: Maybe Text -> Text
mayGenerated :: Maybe Text -> Text
mayGenerated Maybe Text
gen = case Maybe Text
gen of
Maybe Text
Nothing -> Text
""
Just Text
g -> Text
" GENERATED ALWAYS AS (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") STORED"
sqlColumn :: Bool -> Column -> Text
sqlColumn :: Bool -> Column -> Text
sqlColumn Bool
noRef (Column FieldNameDB
name Bool
isNull SqlType
typ Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
_cn Maybe Integer
_maxLen Maybe ColumnReference
ref) = [Text] -> Text
T.concat
[ Text
","
, FieldNameDB -> Text
escapeF FieldNameDB
name
, Text
" "
, SqlType -> Text
showSqlType SqlType
typ
, if Bool
isNull then Text
" NULL" else Text
" NOT NULL"
, Maybe Text -> Text
mayDefault Maybe Text
def
, Maybe Text -> Text
mayGenerated Maybe Text
gen
, case Maybe ColumnReference
ref of
Maybe ColumnReference
Nothing -> Text
""
Just ColumnReference {crTableName :: ColumnReference -> EntityNameDB
crTableName=EntityNameDB
table, crFieldCascade :: ColumnReference -> FieldCascade
crFieldCascade=FieldCascade
cascadeOpts} ->
if Bool
noRef then Text
"" else Text
" REFERENCES " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
escapeE EntityNameDB
table
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldCascade -> Text
onDelete FieldCascade
cascadeOpts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldCascade -> Text
onUpdate FieldCascade
cascadeOpts
]
where
onDelete :: FieldCascade -> Text
onDelete FieldCascade
opts = Text -> (CascadeAction -> Text) -> Maybe CascadeAction -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
T.append Text
" ON DELETE " (Text -> Text) -> (CascadeAction -> Text) -> CascadeAction -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CascadeAction -> Text
renderCascadeAction) (FieldCascade -> Maybe CascadeAction
fcOnDelete FieldCascade
opts)
onUpdate :: FieldCascade -> Text
onUpdate FieldCascade
opts = Text -> (CascadeAction -> Text) -> Maybe CascadeAction -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
T.append Text
" ON UPDATE " (Text -> Text) -> (CascadeAction -> Text) -> CascadeAction -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CascadeAction -> Text
renderCascadeAction) (FieldCascade -> Maybe CascadeAction
fcOnUpdate FieldCascade
opts)
sqlForeign :: ForeignDef -> Text
sqlForeign :: ForeignDef -> Text
sqlForeign ForeignDef
fdef = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
[ Text
", CONSTRAINT "
, ConstraintNameDB -> Text
escapeC (ConstraintNameDB -> Text) -> ConstraintNameDB -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef
, Text
" FOREIGN KEY("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Text)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB)
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB))
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB)
forall a b. (a, b) -> a
fst) ([((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text])
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> a -> b
$ ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef
, Text
") REFERENCES "
, EntityNameDB -> Text
escapeE (EntityNameDB -> Text) -> EntityNameDB -> Text
forall a b. (a -> b) -> a -> b
$ ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB)) -> Text)
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB)
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB))
-> ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))
-> (FieldNameHS, FieldNameDB)
forall a b. (a, b) -> b
snd) ([((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text])
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [Text]
forall a b. (a -> b) -> a -> b
$ ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef
, Text
")"
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
onDelete [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
onUpdate
where
onDelete :: [Text]
onDelete =
(Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
T.append Text
" ON DELETE ")
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe CascadeAction -> [Text]
showAction
(Maybe CascadeAction -> [Text]) -> Maybe CascadeAction -> [Text]
forall a b. (a -> b) -> a -> b
$ FieldCascade -> Maybe CascadeAction
fcOnDelete
(FieldCascade -> Maybe CascadeAction)
-> FieldCascade -> Maybe CascadeAction
forall a b. (a -> b) -> a -> b
$ ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef
onUpdate :: [Text]
onUpdate =
(Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
T.append Text
" ON UPDATE ")
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Maybe CascadeAction -> [Text]
showAction
(Maybe CascadeAction -> [Text]) -> Maybe CascadeAction -> [Text]
forall a b. (a -> b) -> a -> b
$ FieldCascade -> Maybe CascadeAction
fcOnUpdate
(FieldCascade -> Maybe CascadeAction)
-> FieldCascade -> Maybe CascadeAction
forall a b. (a -> b) -> a -> b
$ ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef
showAction :: Maybe CascadeAction -> [Text]
showAction = Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Maybe Text -> [Text])
-> (Maybe CascadeAction -> Maybe Text)
-> Maybe CascadeAction
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CascadeAction -> Text) -> Maybe CascadeAction -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CascadeAction -> Text
renderCascadeAction
sqlUnique :: UniqueDef -> Text
sqlUnique :: UniqueDef -> Text
sqlUnique (UniqueDef ConstraintNameHS
_ ConstraintNameDB
cname NonEmpty (FieldNameHS, FieldNameDB)
cols [Text]
_) = [Text] -> Text
T.concat
[ Text
",CONSTRAINT "
, ConstraintNameDB -> Text
escapeC ConstraintNameDB
cname
, Text
" UNIQUE ("
, Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd) ([(FieldNameHS, FieldNameDB)] -> [Text])
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (FieldNameHS, FieldNameDB)
cols
, Text
")"
]
escapeC :: ConstraintNameDB -> Text
escapeC :: ConstraintNameDB -> Text
escapeC = (Text -> Text) -> ConstraintNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escapeE :: EntityNameDB -> Text
escapeE :: EntityNameDB -> Text
escapeE = (Text -> Text) -> EntityNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escapeF :: FieldNameDB -> Text
escapeF :: FieldNameDB -> Text
escapeF = (Text -> Text) -> FieldNameDB -> Text
forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escape :: Text -> Text
escape :: Text -> Text
escape Text
s =
[Text] -> Text
T.concat [Text
q, (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
go Text
s, Text
q]
where
q :: Text
q = Char -> Text
T.singleton Char
'"'
go :: Char -> Text
go Char
'"' = Text
"\"\""
go Char
c = Char -> Text
T.singleton Char
c
putManySql :: EntityDef -> Int -> Text
putManySql :: EntityDef -> Int -> Text
putManySql EntityDef
ent Int
n = [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns ([FieldDef] -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [FieldDef]
fields) EntityDef
ent Int
n
where
fields :: [FieldDef]
fields = EntityDef -> [FieldDef]
getEntityFields EntityDef
ent
conflictColumns :: [Text]
conflictColumns = (UniqueDef -> [Text]) -> [UniqueDef] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd) ([(FieldNameHS, FieldNameDB)] -> [Text])
-> (UniqueDef -> [(FieldNameHS, FieldNameDB)])
-> UniqueDef
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (FieldNameHS, FieldNameDB)
-> [(FieldNameHS, FieldNameDB)])
-> (UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB))
-> UniqueDef
-> [(FieldNameHS, FieldNameDB)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields) (EntityDef -> [UniqueDef]
getEntityUniques EntityDef
ent)
repsertManySql :: EntityDef -> Int -> Text
repsertManySql :: EntityDef -> Int -> Text
repsertManySql EntityDef
ent Int
n = [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns (NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldDef
fields) EntityDef
ent Int
n
where
fields :: NonEmpty FieldDef
fields = EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent
conflictColumns :: [Text]
conflictColumns = FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB (FieldDef -> Text) -> [FieldDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (EntityDef -> NonEmpty FieldDef
getEntityKeyFields EntityDef
ent)
putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns [FieldDef]
fields EntityDef
ent Int
n = Text
q
where
fieldDbToText :: FieldDef -> Text
fieldDbToText = FieldNameDB -> Text
escapeF (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
mkAssignment :: Text -> Text
mkAssignment Text
f = [Text] -> Text
T.concat [Text
f, Text
"=EXCLUDED.", Text
f]
table :: Text
table = EntityNameDB -> Text
escapeE (EntityNameDB -> Text)
-> (EntityDef -> EntityNameDB) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName (EntityDef -> Text) -> EntityDef -> Text
forall a b. (a -> b) -> a -> b
$ EntityDef
ent
columns :: Text
columns = [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText [FieldDef]
fields
placeholders :: [Text]
placeholders = (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldDef -> Text
forall a b. a -> b -> a
const Text
"?") [FieldDef]
fields
updates :: [Text]
updates = (FieldDef -> Text) -> [FieldDef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
mkAssignment (Text -> Text) -> (FieldDef -> Text) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> Text
fieldDbToText) [FieldDef]
fields
q :: Text
q = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, Text
table
, Text -> Text
Util.parenWrapped Text
columns
, Text
" VALUES "
, [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
n
(Text -> [Text]) -> ([Text] -> Text) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.parenWrapped (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
placeholders
, Text
" ON CONFLICT "
, Text -> Text
Util.parenWrapped (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
conflictColumns
, Text
" DO UPDATE SET "
, [Text] -> Text
Util.commaSeparated [Text]
updates
]
data SqliteConf = SqliteConf
{ SqliteConf -> Text
sqlDatabase :: Text
, SqliteConf -> Int
sqlPoolSize :: Int
}
| SqliteConfInfo
{ SqliteConf -> SqliteConnectionInfo
sqlConnInfo :: SqliteConnectionInfo
, sqlPoolSize :: Int
} deriving Int -> SqliteConf -> String -> String
[SqliteConf] -> String -> String
SqliteConf -> String
(Int -> SqliteConf -> String -> String)
-> (SqliteConf -> String)
-> ([SqliteConf] -> String -> String)
-> Show SqliteConf
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SqliteConf] -> String -> String
$cshowList :: [SqliteConf] -> String -> String
show :: SqliteConf -> String
$cshow :: SqliteConf -> String
showsPrec :: Int -> SqliteConf -> String -> String
$cshowsPrec :: Int -> SqliteConf -> String -> String
Show
instance FromJSON SqliteConf where
parseJSON :: Value -> Parser SqliteConf
parseJSON Value
v = (String -> String) -> Parser SqliteConf -> Parser SqliteConf
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (String
"Persistent: error loading Sqlite conf: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Parser SqliteConf -> Parser SqliteConf)
-> Parser SqliteConf -> Parser SqliteConf
forall a b. (a -> b) -> a -> b
$ ((Object -> Parser SqliteConf) -> Value -> Parser SqliteConf)
-> Value -> (Object -> Parser SqliteConf) -> Parser SqliteConf
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser SqliteConf) -> Value -> Parser SqliteConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SqliteConf") Value
v Object -> Parser SqliteConf
parser where
parser :: Object -> Parser SqliteConf
parser Object
o = if Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
"database" Object
o
then Text -> Int -> SqliteConf
SqliteConf
(Text -> Int -> SqliteConf)
-> Parser Text -> Parser (Int -> SqliteConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"database"
Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"poolsize"
else SqliteConnectionInfo -> Int -> SqliteConf
SqliteConfInfo
(SqliteConnectionInfo -> Int -> SqliteConf)
-> Parser SqliteConnectionInfo -> Parser (Int -> SqliteConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser SqliteConnectionInfo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"connInfo"
Parser (Int -> SqliteConf) -> Parser Int -> Parser SqliteConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"poolsize"
instance PersistConfig SqliteConf where
type PersistConfigBackend SqliteConf = SqlPersistT
type PersistConfigPool SqliteConf = ConnectionPool
createPoolConfig :: SqliteConf -> IO (PersistConfigPool SqliteConf)
createPoolConfig (SqliteConf Text
cs Int
size) = NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend))
-> NoLoggingT IO (Pool SqlBackend) -> IO (Pool SqlBackend)
forall a b. (a -> b) -> a -> b
$ SqliteConnectionInfo -> Int -> NoLoggingT IO (Pool SqlBackend)
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
SqliteConnectionInfo -> Int -> m (Pool SqlBackend)
createSqlitePoolFromInfo (Text -> SqliteConnectionInfo
conStringToInfo Text
cs) Int
size
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
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
-> m b
-> 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 #-}
mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo
mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo
mkSqliteConnectionInfo Text
fp = Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo
SqliteConnectionInfo Text
fp Bool
True Bool
True []
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)
data SqliteConnectionInfo = SqliteConnectionInfo
{ SqliteConnectionInfo -> Text
_sqlConnectionStr :: Text
, SqliteConnectionInfo -> Bool
_walEnabled :: Bool
, SqliteConnectionInfo -> Bool
_fkEnabled :: Bool
, :: [Text]
} deriving Int -> SqliteConnectionInfo -> String -> String
[SqliteConnectionInfo] -> String -> String
SqliteConnectionInfo -> String
(Int -> SqliteConnectionInfo -> String -> String)
-> (SqliteConnectionInfo -> String)
-> ([SqliteConnectionInfo] -> String -> String)
-> Show SqliteConnectionInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SqliteConnectionInfo] -> String -> String
$cshowList :: [SqliteConnectionInfo] -> String -> String
show :: SqliteConnectionInfo -> String
$cshow :: SqliteConnectionInfo -> String
showsPrec :: Int -> SqliteConnectionInfo -> String -> String
$cshowsPrec :: Int -> SqliteConnectionInfo -> String -> String
Show
instance FromJSON SqliteConnectionInfo where
parseJSON :: Value -> Parser SqliteConnectionInfo
parseJSON Value
v = (String -> String)
-> Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (String
"Persistent: error loading SqliteConnectionInfo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo -> Parser SqliteConnectionInfo
forall a b. (a -> b) -> a -> b
$
((Object -> Parser SqliteConnectionInfo)
-> Value -> Parser SqliteConnectionInfo)
-> Value
-> (Object -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser SqliteConnectionInfo)
-> Value
-> Parser SqliteConnectionInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SqliteConnectionInfo") Value
v ((Object -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo)
-> (Object -> Parser SqliteConnectionInfo)
-> Parser SqliteConnectionInfo
forall a b. (a -> b) -> a -> b
$ \Object
o -> Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo
SqliteConnectionInfo
(Text -> Bool -> Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Text
-> Parser (Bool -> Bool -> [Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"connectionString"
Parser (Bool -> Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Bool -> Parser (Bool -> [Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"walEnabled"
Parser (Bool -> [Text] -> SqliteConnectionInfo)
-> Parser Bool -> Parser ([Text] -> SqliteConnectionInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"fkEnabled"
Parser ([Text] -> SqliteConnectionInfo)
-> Parser [Text] -> Parser SqliteConnectionInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"extraPragmas" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
data ForeignKeyViolation = ForeignKeyViolation
{ ForeignKeyViolation -> Text
foreignKeyTable :: Text
, ForeignKeyViolation -> Text
foreignKeyColumn :: Text
, ForeignKeyViolation -> Int64
foreignKeyRowId :: Int64
} 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)
checkForeignKeys
:: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env)
=> ConduitM () ForeignKeyViolation m ()
checkForeignKeys :: ConduitM () ForeignKeyViolation m ()
checkForeignKeys = Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
forall (m :: * -> *) env.
(MonadResource m, MonadReader env m,
BackendCompatible SqlBackend env) =>
Text -> [PersistValue] -> ConduitM () [PersistValue] m ()
rawQuery Text
query [] ConduitM () [PersistValue] m ()
-> ConduitM [PersistValue] ForeignKeyViolation m ()
-> ConduitM () ForeignKeyViolation m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ([PersistValue] -> m ForeignKeyViolation)
-> ConduitM [PersistValue] ForeignKeyViolation m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
C.mapM [PersistValue] -> m ForeignKeyViolation
forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> m ForeignKeyViolation
parse
where
parse :: [PersistValue] -> m ForeignKeyViolation
parse [PersistValue]
l = case [PersistValue]
l of
[ PersistInt64 Int64
rowid , PersistText Text
table , PersistText Text
column ] ->
ForeignKeyViolation -> m ForeignKeyViolation
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignKeyViolation :: Text -> Text -> Int64 -> ForeignKeyViolation
ForeignKeyViolation
{ foreignKeyTable :: Text
foreignKeyTable = Text
table
, foreignKeyColumn :: Text
foreignKeyColumn = Text
column
, foreignKeyRowId :: Int64
foreignKeyRowId = Int64
rowid
}
[PersistValue]
_ -> IO ForeignKeyViolation -> m ForeignKeyViolation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignKeyViolation -> m ForeignKeyViolation)
-> (Text -> IO ForeignKeyViolation)
-> Text
-> m ForeignKeyViolation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistException -> IO ForeignKeyViolation
forall e a. Exception e => e -> IO a
E.throwIO (PersistException -> IO ForeignKeyViolation)
-> (Text -> PersistException) -> Text -> IO ForeignKeyViolation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PersistException
PersistMarshalError (Text -> m ForeignKeyViolation) -> Text -> m ForeignKeyViolation
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Text
"Unexpected result from foreign key check:\n", String -> Text
T.pack ([PersistValue] -> String
forall a. Show a => a -> String
show [PersistValue]
l) ]
query :: Text
query = [Text] -> Text
T.unlines
[ Text
"SELECT origin.rowid, origin.\"table\", group_concat(foreignkeys.\"from\")"
, Text
"FROM pragma_foreign_key_check() AS origin"
, Text
"INNER JOIN pragma_foreign_key_list(origin.\"table\") AS foreignkeys"
, Text
"ON origin.fkid = foreignkeys.id AND origin.parent = foreignkeys.\"table\""
, Text
"GROUP BY origin.rowid"
]
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
createRawSqlitePoolFromInfo
:: (MonadLoggerIO m, MonadUnliftIO m)
=> SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> 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
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 ()))
withRawSqlitePoolInfo
:: (MonadUnliftIO m, MonadLoggerIO m)
=> SqliteConnectionInfo
-> (RawSqlite SqlBackend -> m ())
-> Int
-> (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
withRawSqlitePoolInfo_
:: (MonadUnliftIO m, MonadLoggerIO m)
=> SqliteConnectionInfo
-> Int
-> (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 ()))
data RawSqlite backend = RawSqlite
{ RawSqlite backend -> backend
_persistentBackend :: backend
, RawSqlite backend -> Connection
_rawSqliteConnection :: 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