{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
#if MIN_VERSION_base(4,12,0)
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
#endif
module Database.Persist.Postgresql
( withPostgresqlPool
, withPostgresqlPoolWithVersion
, withPostgresqlPoolWithConf
, withPostgresqlPoolModified
, withPostgresqlPoolModifiedWithVersion
, withPostgresqlConn
, withPostgresqlConnWithVersion
, createPostgresqlPool
, createPostgresqlPoolModified
, createPostgresqlPoolModifiedWithVersion
, createPostgresqlPoolWithConf
, module Database.Persist.Sql
, ConnectionString
, HandleUpdateCollision
, copyField
, copyUnlessNull
, copyUnlessEmpty
, copyUnlessEq
, excludeNotEqualToOriginal
, PostgresConf (..)
, PgInterval (..)
, upsertWhere
, upsertManyWhere
, openSimpleConn
, openSimpleConnWithVersion
, getSimpleConn
, tableName
, fieldName
, mockMigration
, migrateEnableExtension
, PostgresConfHooks(..)
, defaultPostgresConfHooks
, RawPostgresql(..)
, createRawPostgresqlPool
, createRawPostgresqlPoolModified
, createRawPostgresqlPoolModifiedWithVersion
, createRawPostgresqlPoolWithConf
) where
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.FromField as PGFF
import qualified Database.PostgreSQL.Simple.Internal as PG
import Database.PostgreSQL.Simple.Ok (Ok(..))
import qualified Database.PostgreSQL.Simple.Transaction as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import Control.Arrow
import Control.Exception (Exception, throw, throwIO)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO)
import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT)
import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT)
import Control.Monad.Trans.Class (lift)
#if !MIN_VERSION_base(4,12,0)
import Control.Monad.Trans.Reader (withReaderT)
#endif
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import qualified Data.List.NonEmpty as NEL
import Data.Proxy (Proxy(..))
import Data.Acquire (Acquire, mkAcquire, with)
import Data.Aeson
import Data.Aeson.Types (modifyFailure)
import qualified Data.Attoparsec.Text as AT
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Data (Data)
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.IORef
import Data.Int (Int64)
import Data.List (find, foldl', groupBy, sort)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.Monoid as Monoid
import Data.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Text.Read (rational)
import System.Environment (getEnvironment)
#if MIN_VERSION_base(4,12,0)
import Database.Persist.Compatible
#endif
import Database.Persist.Postgresql.Internal
import Database.Persist.Sql
import qualified Database.Persist.Sql.Util as Util
import Database.Persist.SqlBackend
import Database.Persist.SqlBackend.StatementCache (StatementCache, mkSimpleStatementCache, mkStatementCache)
import qualified Data.Vault.Strict as Vault
import System.IO.Unsafe (unsafePerformIO)
type ConnectionString = ByteString
data PostgresServerVersionError = PostgresServerVersionError String
instance Show PostgresServerVersionError where
show :: PostgresServerVersionError -> [Char]
show (PostgresServerVersionError [Char]
uniqueMsg) =
[Char]
"Unexpected PostgreSQL server version, got " forall a. Semigroup a => a -> a -> a
<> [Char]
uniqueMsg
instance Exception PostgresServerVersionError
withPostgresqlPool :: (MonadLoggerIO m, MonadUnliftIO m)
=> ConnectionString
-> Int
-> (Pool SqlBackend -> m a)
-> m a
withPostgresqlPool :: forall (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m) =>
ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPool ConnectionString
ci = forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPoolWithVersion Connection -> IO (Maybe Double)
getServerVersion ConnectionString
ci
withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO (Maybe Double))
-> ConnectionString
-> Int
-> (Pool SqlBackend -> m a)
-> m a
withPostgresqlPoolWithVersion :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPoolWithVersion Connection -> IO (Maybe Double)
getVerDouble ConnectionString
ci = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool forall a b. (a -> b) -> a -> b
$ forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) Connection -> IO (NonEmpty Word)
getVer forall a. a -> a
id ConnectionString
ci
withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLoggerIO m)
=> PostgresConf
-> PostgresConfHooks
-> (Pool SqlBackend -> m a)
-> m a
withPostgresqlPoolWithConf :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
PostgresConf
-> PostgresConfHooks -> (Pool SqlBackend -> m a) -> m a
withPostgresqlPoolWithConf PostgresConf
conf PostgresConfHooks
hooks = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = PostgresConfHooks -> Connection -> IO (NonEmpty Word)
pgConfHooksGetServerVersion PostgresConfHooks
hooks
modConn :: Connection -> IO ()
modConn = PostgresConfHooks -> Connection -> IO ()
pgConfHooksAfterCreate PostgresConfHooks
hooks
let logFuncToBackend :: LogFunc -> IO SqlBackend
logFuncToBackend = forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer forall a. a -> a
id (PostgresConf -> ConnectionString
pgConnStr PostgresConf
conf)
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend)
-> ConnectionPoolConfig -> (Pool backend -> m a) -> m a
withSqlPoolWithConfig LogFunc -> IO SqlBackend
logFuncToBackend (PostgresConf -> ConnectionPoolConfig
postgresConfToConnectionPoolConfig PostgresConf
conf)
withPostgresqlPoolModified
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> (Pool SqlBackend -> m t)
-> m t
withPostgresqlPoolModified :: forall (m :: * -> *) t.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO ())
-> ConnectionString -> Int -> (Pool SqlBackend -> m t) -> m t
withPostgresqlPoolModified = forall (m :: * -> *) t.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> (Pool SqlBackend -> m t)
-> m t
withPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getServerVersion
withPostgresqlPoolModifiedWithVersion
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO (Maybe Double))
-> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> (Pool SqlBackend -> m t)
-> m t
withPostgresqlPoolModifiedWithVersion :: forall (m :: * -> *) t.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> (Pool SqlBackend -> m t)
-> m t
withPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getVerDouble Connection -> IO ()
modConn ConnectionString
ci = do
forall backend (m :: * -> *) a.
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> (Pool backend -> m a) -> m a
withSqlPool (forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn ((Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble) forall a. a -> a
id ConnectionString
ci)
createPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m)
=> ConnectionString
-> Int
-> m (Pool SqlBackend)
createPostgresqlPool :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
ConnectionString -> Int -> m (Pool SqlBackend)
createPostgresqlPool = forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO ())
-> ConnectionString -> Int -> m (Pool SqlBackend)
createPostgresqlPoolModified (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
createPostgresqlPoolModified
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool SqlBackend)
createPostgresqlPoolModified :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO ())
-> ConnectionString -> Int -> m (Pool SqlBackend)
createPostgresqlPoolModified = forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool SqlBackend)
createPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getServerVersion
createPostgresqlPoolModifiedWithVersion
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO (Maybe Double))
-> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool SqlBackend)
createPostgresqlPoolModifiedWithVersion :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool SqlBackend)
createPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getVerDouble Connection -> IO ()
modConn ConnectionString
ci = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble
forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool forall a b. (a -> b) -> a -> b
$ forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer forall a. a -> a
id ConnectionString
ci
createPostgresqlPoolWithConf
:: (MonadUnliftIO m, MonadLoggerIO m)
=> PostgresConf
-> PostgresConfHooks
-> m (Pool SqlBackend)
createPostgresqlPoolWithConf :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PostgresConf -> PostgresConfHooks -> m (Pool SqlBackend)
createPostgresqlPoolWithConf PostgresConf
conf PostgresConfHooks
hooks = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = PostgresConfHooks -> Connection -> IO (NonEmpty Word)
pgConfHooksGetServerVersion PostgresConfHooks
hooks
modConn :: Connection -> IO ()
modConn = PostgresConfHooks -> Connection -> IO ()
pgConfHooksAfterCreate PostgresConfHooks
hooks
forall (m :: * -> *) backend.
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig (forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer forall a. a -> a
id (PostgresConf -> ConnectionString
pgConnStr PostgresConf
conf)) (PostgresConf -> ConnectionPoolConfig
postgresConfToConnectionPoolConfig PostgresConf
conf)
postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig
postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig
postgresConfToConnectionPoolConfig PostgresConf
conf =
ConnectionPoolConfig
{ connectionPoolConfigStripes :: Int
connectionPoolConfigStripes = PostgresConf -> Int
pgPoolStripes PostgresConf
conf
, connectionPoolConfigIdleTimeout :: NominalDiffTime
connectionPoolConfigIdleTimeout = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ PostgresConf -> Integer
pgPoolIdleTimeout PostgresConf
conf
, connectionPoolConfigSize :: Int
connectionPoolConfigSize = PostgresConf -> Int
pgPoolSize PostgresConf
conf
}
withPostgresqlConn :: (MonadUnliftIO m, MonadLoggerIO m)
=> ConnectionString -> (SqlBackend -> m a) -> m a
withPostgresqlConn :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
ConnectionString -> (SqlBackend -> m a) -> m a
withPostgresqlConn = forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> ConnectionString -> (SqlBackend -> m a) -> m a
withPostgresqlConnWithVersion Connection -> IO (Maybe Double)
getServerVersion
withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO (Maybe Double))
-> ConnectionString
-> (SqlBackend -> m a)
-> m a
withPostgresqlConnWithVersion :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> ConnectionString -> (SqlBackend -> m a) -> m a
withPostgresqlConnWithVersion Connection -> IO (Maybe Double)
getVerDouble = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble
forall backend (m :: * -> *) a.
(MonadUnliftIO m, MonadLoggerIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> (backend -> m a) -> m a
withSqlConn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) Connection -> IO (NonEmpty Word)
getVer forall a. a -> a
id
open'
:: (PG.Connection -> IO ())
-> (PG.Connection -> IO (NonEmpty Word))
-> ((PG.Connection -> SqlBackend) -> PG.Connection -> backend)
-> ConnectionString -> LogFunc -> IO backend
open' :: forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer (Connection -> SqlBackend) -> Connection -> backend
constructor ConnectionString
cstr LogFunc
logFunc = do
Connection
conn <- ConnectionString -> IO Connection
PG.connectPostgreSQL ConnectionString
cstr
Connection -> IO ()
modConn Connection
conn
NonEmpty Word
ver <- Connection -> IO (NonEmpty Word)
getVer Connection
conn
IORef (Map Text Statement)
smap <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Connection -> SqlBackend) -> Connection -> backend
constructor (LogFunc
-> NonEmpty Word
-> IORef (Map Text Statement)
-> Connection
-> SqlBackend
createBackend LogFunc
logFunc NonEmpty Word
ver IORef (Map Text Statement)
smap) Connection
conn
getServerVersion :: PG.Connection -> IO (Maybe Double)
getServerVersion :: Connection -> IO (Maybe Double)
getServerVersion Connection
conn = do
[PG.Only Text
version] <- forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn Query
"show server_version";
let version' :: Either [Char] (Double, Text)
version' = forall a. Fractional a => Reader a
rational Text
version
case Either [Char] (Double, Text)
version' of
Right (Double
a,Text
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Double
a
Left [Char]
err -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> PostgresServerVersionError
PostgresServerVersionError [Char]
err
getServerVersionNonEmpty :: PG.Connection -> IO (NonEmpty Word)
getServerVersionNonEmpty :: Connection -> IO (NonEmpty Word)
getServerVersionNonEmpty Connection
conn = do
[PG.Only [Char]
version] <- forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn Query
"show server_version";
case forall a. Parser a -> Text -> Either [Char] a
AT.parseOnly Parser Text [Word]
parseVersion ([Char] -> Text
T.pack [Char]
version) of
Left [Char]
err -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> PostgresServerVersionError
PostgresServerVersionError forall a b. (a -> b) -> a -> b
$ [Char]
"Parse failure on: " forall a. Semigroup a => a -> a -> a
<> [Char]
version forall a. Semigroup a => a -> a -> a
<> [Char]
". Error: " forall a. Semigroup a => a -> a -> a
<> [Char]
err
Right [Word]
versionComponents -> case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Word]
versionComponents of
Maybe (NonEmpty Word)
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [Char] -> PostgresServerVersionError
PostgresServerVersionError forall a b. (a -> b) -> a -> b
$ [Char]
"Empty Postgres version string: " forall a. Semigroup a => a -> a -> a
<> [Char]
version
Just NonEmpty Word
neVersion -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty Word
neVersion
where
parseVersion :: Parser Text [Word]
parseVersion = forall a. Integral a => Parser a
AT.decimal forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`AT.sepBy` Char -> Parser Char
AT.char Char
'.'
upsertFunction :: a -> NonEmpty Word -> Maybe a
upsertFunction :: forall a. a -> NonEmpty Word -> Maybe a
upsertFunction a
f NonEmpty Word
version = if (NonEmpty Word
version forall a. Ord a => a -> a -> Bool
>= NonEmpty Word
postgres9dot5)
then forall a. a -> Maybe a
Just a
f
else forall a. Maybe a
Nothing
where
postgres9dot5 :: NonEmpty Word
postgres9dot5 :: NonEmpty Word
postgres9dot5 = Word
9 forall a. a -> [a] -> NonEmpty a
NEL.:| [Word
5]
minimumPostgresVersion :: NonEmpty Word
minimumPostgresVersion :: NonEmpty Word
minimumPostgresVersion = Word
9 forall a. a -> [a] -> NonEmpty a
NEL.:| [Word
4]
oldGetVersionToNew :: (PG.Connection -> IO (Maybe Double)) -> (PG.Connection -> IO (NonEmpty Word))
oldGetVersionToNew :: (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
oldFn = \Connection
conn -> do
Maybe Double
mDouble <- Connection -> IO (Maybe Double)
oldFn Connection
conn
case Maybe Double
mDouble of
Maybe Double
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty Word
minimumPostgresVersion
Just Double
double -> do
let (Word
major, Double
minor) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
double
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word
major forall a. a -> [a] -> NonEmpty a
NEL.:| [forall a b. (RealFrac a, Integral b) => a -> b
floor Double
minor]
openSimpleConn :: LogFunc -> PG.Connection -> IO SqlBackend
openSimpleConn :: LogFunc -> Connection -> IO SqlBackend
openSimpleConn = (Connection -> IO (Maybe Double))
-> LogFunc -> Connection -> IO SqlBackend
openSimpleConnWithVersion Connection -> IO (Maybe Double)
getServerVersion
openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend
openSimpleConnWithVersion :: (Connection -> IO (Maybe Double))
-> LogFunc -> Connection -> IO SqlBackend
openSimpleConnWithVersion Connection -> IO (Maybe Double)
getVerDouble LogFunc
logFunc Connection
conn = do
IORef (Map Text Statement)
smap <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
NonEmpty Word
serverVersion <- (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble Connection
conn
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LogFunc
-> NonEmpty Word
-> IORef (Map Text Statement)
-> Connection
-> SqlBackend
createBackend LogFunc
logFunc NonEmpty Word
serverVersion IORef (Map Text Statement)
smap Connection
conn
underlyingConnectionKey :: Vault.Key PG.Connection
underlyingConnectionKey :: Key Connection
underlyingConnectionKey = forall a. IO a -> a
unsafePerformIO forall a. IO (Key a)
Vault.newKey
{-# NOINLINE underlyingConnectionKey #-}
getSimpleConn :: (BackendCompatible SqlBackend backend) => backend -> Maybe PG.Connection
getSimpleConn :: forall backend.
BackendCompatible SqlBackend backend =>
backend -> Maybe Connection
getSimpleConn = forall a. Key a -> Vault -> Maybe a
Vault.lookup Key Connection
underlyingConnectionKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend (m :: * -> *).
(BackendCompatible SqlBackend backend, MonadReader backend m) =>
m Vault
getConnVault
createBackend :: LogFunc -> NonEmpty Word
-> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend
createBackend :: LogFunc
-> NonEmpty Word
-> IORef (Map Text Statement)
-> Connection
-> SqlBackend
createBackend LogFunc
logFunc NonEmpty Word
serverVersion IORef (Map Text Statement)
smap Connection
conn =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnPutManySql (forall a. a -> NonEmpty Word -> Maybe a
upsertFunction EntityDef -> Int -> Text
putManySql NonEmpty Word
serverVersion) forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)
-> SqlBackend -> SqlBackend
setConnUpsertSql (forall a. a -> NonEmpty Word -> Maybe a
upsertFunction EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql' NonEmpty Word
serverVersion) forall a b. (a -> b) -> a -> b
$
(EntityDef -> [[PersistValue]] -> InsertSqlResult)
-> SqlBackend -> SqlBackend
setConnInsertManySql EntityDef -> [[PersistValue]] -> InsertSqlResult
insertManySql' forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend
setConnRepsertManySql (forall a. a -> NonEmpty Word -> Maybe a
upsertFunction EntityDef -> Int -> Text
repsertManySql NonEmpty Word
serverVersion) forall a b. (a -> b) -> a -> b
$
(Vault -> Vault) -> SqlBackend -> SqlBackend
modifyConnVault (forall a. Key a -> a -> Vault -> Vault
Vault.insert Key Connection
underlyingConnectionKey Connection
conn) forall a b. (a -> b) -> a -> b
$ MkSqlBackendArgs -> SqlBackend
mkSqlBackend 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 ()
PG.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
_ Maybe IsolationLevel
mIsolation -> case Maybe IsolationLevel
mIsolation of
Maybe IsolationLevel
Nothing -> Connection -> IO ()
PG.begin Connection
conn
Just IsolationLevel
iso -> IsolationLevel -> Connection -> IO ()
PG.beginLevel (case IsolationLevel
iso of
IsolationLevel
ReadUncommitted -> IsolationLevel
PG.ReadCommitted
IsolationLevel
ReadCommitted -> IsolationLevel
PG.ReadCommitted
IsolationLevel
RepeatableRead -> IsolationLevel
PG.RepeatableRead
IsolationLevel
Serializable -> IsolationLevel
PG.Serializable) Connection
conn
, connCommit :: (Text -> IO Statement) -> IO ()
connCommit = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
PG.commit Connection
conn
, connRollback :: (Text -> IO Statement) -> IO ()
connRollback = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Connection -> IO ()
PG.rollback Connection
conn
, connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = FieldNameDB -> Text
escapeF
, connEscapeTableName :: EntityDef -> Text
connEscapeTableName = EntityNameDB -> Text
escapeE 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 ALL"
, connRDBMS :: Text
connRDBMS = Text
"postgresql"
, connLimitOffset :: (Int, Int) -> Text -> Text
connLimitOffset = Text -> (Int, Int) -> Text -> Text
decorateSQLWithLimitOffset Text
"LIMIT ALL"
, connLogFunc :: LogFunc
connLogFunc = LogFunc
logFunc
}
prepare' :: PG.Connection -> Text -> IO Statement
prepare' :: Connection -> Text -> IO Statement
prepare' Connection
conn Text
sql = do
let query :: Query
query = ConnectionString -> Query
PG.Query (Text -> ConnectionString
T.encodeUtf8 Text
sql)
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
{ stmtFinalize :: IO ()
stmtFinalize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtReset :: IO ()
stmtReset = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = Connection -> Query -> [PersistValue] -> IO Int64
execute' Connection
conn Query
query
, stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = forall (m :: * -> *).
MonadIO m =>
Connection
-> Query
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Query
query
}
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
insertSql' EntityDef
ent [PersistValue]
vals =
case EntityDef -> EntityIdDef
getEntityId EntityDef
ent of
EntityIdNaturalKey CompositeDef
_pdef ->
Text -> [PersistValue] -> InsertSqlResult
ISRManyKeys Text
sql [PersistValue]
vals
EntityIdField FieldDef
field ->
Text -> InsertSqlResult
ISRSingle (Text
sql forall a. Semigroup a => a -> a -> a
<> Text
" RETURNING " forall a. Semigroup a => a -> a -> a
<> FieldNameDB -> Text
escapeF (FieldDef -> FieldNameDB
fieldDB FieldDef
field))
where
([Text]
fieldNames, [Text]
placeholders) = forall a b. [(a, b)] -> ([a], [b])
unzip (EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
Util.mkInsertPlaceholders EntityDef
ent FieldNameDB -> Text
escapeF)
sql :: Text
sql = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EntityDef -> [FieldDef]
getEntityFields EntityDef
ent)
then Text
" DEFAULT VALUES"
else [Text] -> Text
T.concat
[ Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fieldNames
, Text
") VALUES("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
placeholders
, Text
")"
]
]
upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text
upsertSql' EntityDef
ent NonEmpty (FieldNameHS, FieldNameDB)
uniqs Text
updateVal =
[Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE (EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent)
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fieldNames
, Text
") VALUES ("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
placeholders
, Text
") ON CONFLICT ("
, Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (FieldNameHS, FieldNameDB)
uniqs)
, Text
") DO UPDATE SET "
, Text
updateVal
, Text
" WHERE "
, Text
wher
, Text
" RETURNING ??"
]
where
([Text]
fieldNames, [Text]
placeholders) = forall a b. [(a, b)] -> ([a], [b])
unzip (EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
Util.mkInsertPlaceholders EntityDef
ent FieldNameDB -> Text
escapeF)
wher :: Text
wher = Text -> [Text] -> Text
T.intercalate Text
" AND " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
singleClause forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (FieldNameHS, FieldNameDB)
uniqs
singleClause :: FieldNameDB -> Text
singleClause :: FieldNameDB -> Text
singleClause FieldNameDB
field = EntityNameDB -> Text
escapeE (EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent) forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> (FieldNameDB -> Text
escapeF FieldNameDB
field) forall a. Semigroup a => a -> a -> a
<> Text
" =?"
insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult
insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult
insertManySql' EntityDef
ent [[PersistValue]]
valss =
Text -> InsertSqlResult
ISRSingle Text
sql
where
([Text]
fieldNames, [Text]
placeholders)= forall a b. [(a, b)] -> ([a], [b])
unzip (EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
Util.mkInsertPlaceholders EntityDef
ent FieldNameDB -> Text
escapeF)
sql :: Text
sql = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, EntityNameDB -> Text
escapeE (EntityDef -> EntityNameDB
getEntityDBName EntityDef
ent)
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
fieldNames
, Text
") VALUES ("
, Text -> [Text] -> Text
T.intercalate Text
"),(" forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[PersistValue]]
valss) forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"," [Text]
placeholders
, Text
") RETURNING "
, [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
Util.dbIdColumnsEsc FieldNameDB -> Text
escapeF EntityDef
ent
]
execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64
execute' :: Connection -> Query -> [PersistValue] -> IO Int64
execute' Connection
conn Query
query [PersistValue]
vals = forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
conn Query
query (forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> P
P [PersistValue]
vals)
withStmt' :: MonadIO m
=> PG.Connection
-> PG.Query
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' :: forall (m :: * -> *).
MonadIO m =>
Connection
-> Query
-> [PersistValue]
-> Acquire (ConduitM () [PersistValue] m ())
withStmt' Connection
conn Query
query [PersistValue]
vals =
(Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
-> ConduitM () [PersistValue] m ()
pull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO
(Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
openS forall {b} {c} {d}. (Result, b, c, d) -> IO ()
closeS
where
openS :: IO
(Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
openS = do
ConnectionString
rawquery <- forall q.
ToRow q =>
Connection -> Query -> q -> IO ConnectionString
PG.formatQuery Connection
conn Query
query (forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> P
P [PersistValue]
vals)
(Result
rt, IORef Row
rr, Row
rc, [(Column, Oid)]
ids) <- forall a. Connection -> (Connection -> IO a) -> IO a
PG.withConnection Connection
conn forall a b. (a -> b) -> a -> b
$ \Connection
rawconn -> do
Maybe Result
mret <- Connection -> ConnectionString -> IO (Maybe Result)
LibPQ.exec Connection
rawconn ConnectionString
rawquery
case Maybe Result
mret of
Maybe Result
Nothing -> do
Maybe ConnectionString
merr <- Connection -> IO (Maybe ConnectionString)
LibPQ.errorMessage Connection
rawconn
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ case Maybe ConnectionString
merr of
Maybe ConnectionString
Nothing -> [Char]
"Postgresql.withStmt': unknown error"
Just ConnectionString
e -> [Char]
"Postgresql.withStmt': " forall a. [a] -> [a] -> [a]
++ ConnectionString -> [Char]
B8.unpack ConnectionString
e
Just Result
ret -> do
ExecStatus
status <- Result -> IO ExecStatus
LibPQ.resultStatus Result
ret
case ExecStatus
status of
ExecStatus
LibPQ.TuplesOk -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExecStatus
_ -> forall a. ConnectionString -> Result -> ExecStatus -> IO a
PG.throwResultError ConnectionString
"Postgresql.withStmt': bad result status " Result
ret ExecStatus
status
Column
cols <- Result -> IO Column
LibPQ.nfields Result
ret
[(Column, Oid)]
oids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Column
0..Column
colsforall a. Num a => a -> a -> a
-Column
1] forall a b. (a -> b) -> a -> b
$ \Column
col -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Column
col) (Result -> Column -> IO Oid
LibPQ.ftype Result
ret Column
col)
IORef Row
rowRef <- forall a. a -> IO (IORef a)
newIORef (CInt -> Row
LibPQ.Row CInt
0)
Row
rowCount <- Result -> IO Row
LibPQ.ntuples Result
ret
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
ret, IORef Row
rowRef, Row
rowCount, [(Column, Oid)]
oids)
let getters :: [Maybe ConnectionString -> Conversion PersistValue]
getters
= forall a b. (a -> b) -> [a] -> [b]
map (\(Column
col, Oid
oid) -> Oid -> Getter PersistValue
getGetter Oid
oid forall a b. (a -> b) -> a -> b
$ Result -> Column -> Oid -> Field
PG.Field Result
rt Column
col Oid
oid) [(Column, Oid)]
ids
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
rt, IORef Row
rr, Row
rc, [Maybe ConnectionString -> Conversion PersistValue]
getters)
closeS :: (Result, b, c, d) -> IO ()
closeS (Result
ret, b
_, c
_, d
_) = Result -> IO ()
LibPQ.unsafeFreeResult Result
ret
pull :: (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
-> ConduitM () [PersistValue] m ()
pull (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
x = do
Maybe [PersistValue]
y <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
-> IO (Maybe [PersistValue])
pullS (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
x
case Maybe [PersistValue]
y of
Maybe [PersistValue]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [PersistValue]
z -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [PersistValue]
z forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
-> ConduitM () [PersistValue] m ()
pull (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
x
pullS :: (Result, IORef Row, Row,
[Maybe ConnectionString -> Conversion PersistValue])
-> IO (Maybe [PersistValue])
pullS (Result
ret, IORef Row
rowRef, Row
rowCount, [Maybe ConnectionString -> Conversion PersistValue]
getters) = do
Row
row <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Row
rowRef (\Row
r -> (Row
rforall a. Num a => a -> a -> a
+Row
1, Row
r))
if Row
row forall a. Eq a => a -> a -> Bool
== Row
rowCount
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe ConnectionString -> Conversion PersistValue]
getters [Column
0..]) forall a b. (a -> b) -> a -> b
$ \(Maybe ConnectionString -> Conversion PersistValue
getter, Column
col) -> do
Maybe ConnectionString
mbs <- Result -> Row -> Column -> IO (Maybe ConnectionString)
LibPQ.getvalue' Result
ret Row
row Column
col
case Maybe ConnectionString
mbs of
Maybe ConnectionString
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return PersistValue
PersistNull
Just ConnectionString
bs -> do
Ok PersistValue
ok <- forall a. Conversion a -> Connection -> IO (Ok a)
PGFF.runConversion (Maybe ConnectionString -> Conversion PersistValue
getter Maybe ConnectionString
mbs) Connection
conn
ConnectionString
bs seq :: forall a b. a -> b -> b
`seq` case Ok PersistValue
ok of
Errors (SomeException
exc:[SomeException]
_) -> forall a e. Exception e => e -> a
throw SomeException
exc
Errors [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"Got an Errors, but no exceptions"
Ok PersistValue
v -> forall (m :: * -> *) a. Monad m => a -> m a
return PersistValue
v
doesTableExist :: (Text -> IO Statement)
-> EntityNameDB
-> IO Bool
doesTableExist :: (Text -> IO Statement) -> EntityNameDB -> IO Bool
doesTableExist Text -> IO Statement
getter (EntityNameDB Text
name) = do
Statement
stmt <- Text -> IO Statement
getter Text
sql
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [PersistValue]
vals) (\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT [PersistValue] o IO Bool
start)
where
sql :: Text
sql = Text
"SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'"
forall a. Semigroup a => a -> a -> a
<> Text
" AND schemaname != 'information_schema' AND tablename=?"
vals :: [PersistValue]
vals = [Text -> PersistValue
PersistText Text
name]
start :: ConduitT [PersistValue] o IO Bool
start = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error [Char]
"No results when checking doesTableExist") forall {m :: * -> *} {i} {o}.
Monad m =>
[PersistValue] -> ConduitT i o m Bool
start'
start' :: [PersistValue] -> ConduitT i o m Bool
start' [PersistInt64 Int64
0] = forall {m :: * -> *} {b} {i} {o}. Monad m => b -> ConduitT i o m b
finish Bool
False
start' [PersistInt64 Int64
1] = forall {m :: * -> *} {b} {i} {o}. Monad m => b -> ConduitT i o m b
finish Bool
True
start' [PersistValue]
res = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"doesTableExist returned unexpected result: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
res
finish :: b -> ConduitT i o m b
finish b
x = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return b
x) (forall a. HasCallStack => [Char] -> a
error [Char]
"Too many rows returned in doesTableExist")
migrate' :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] CautiousMigration)
migrate' :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
migrate' [EntityDef]
allDefs Text -> IO Statement
getter EntityDef
entity = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> (Bool, Text)
showAlterDb) forall a b. (a -> b) -> a -> b
$ do
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old <- (Text -> IO Statement)
-> EntityDef
-> [Column]
-> IO
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns Text -> IO Statement
getter EntityDef
entity [Column]
newcols'
case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old of
([], [Either Column (ConstraintNameDB, [FieldNameDB])]
old'') -> do
Bool
exists' <-
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
old
then (Text -> IO Statement) -> EntityNameDB -> IO Bool
doesTableExist Text -> IO Statement
getter EntityNameDB
name
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool
-> [Either Column (ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
migrationText Bool
exists' [Either Column (ConstraintNameDB, [FieldNameDB])]
old''
([Text]
errs, [Either Column (ConstraintNameDB, [FieldNameDB])]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Text]
errs
where
name :: EntityNameDB
name = EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
([Column]
newcols', [UniqueDef]
udefs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
postgresMkColumns [EntityDef]
allDefs EntityDef
entity
migrationText :: Bool
-> [Either Column (ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
migrationText Bool
exists' [Either Column (ConstraintNameDB, [FieldNameDB])]
old''
| Bool -> Bool
not Bool
exists' =
[Column]
-> [ForeignDef] -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
createText [Column]
newcols [ForeignDef]
fdefs [(ConstraintNameDB, [FieldNameDB])]
udspair
| Bool
otherwise =
let ([AlterColumn]
acs, [AlterTable]
ats) =
[EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters [EntityDef]
allDefs EntityDef
entity ([Column]
newcols, [(ConstraintNameDB, [FieldNameDB])]
udspair) ([Column], [(ConstraintNameDB, [FieldNameDB])])
old'
acs' :: [AlterDB]
acs' = forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
name) [AlterColumn]
acs
ats' :: [AlterDB]
ats' = forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name) [AlterTable]
ats
in
[AlterDB]
acs' forall a. [a] -> [a] -> [a]
++ [AlterDB]
ats'
where
old' :: ([Column], [(ConstraintNameDB, [FieldNameDB])])
old' = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Column (ConstraintNameDB, [FieldNameDB])]
old''
newcols :: [Column]
newcols = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
entity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
newcols'
udspair :: [(ConstraintNameDB, [FieldNameDB])]
udspair = forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair [UniqueDef]
udefs
createText :: [Column]
-> [ForeignDef] -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
createText [Column]
newcols [ForeignDef]
fdefs_ [(ConstraintNameDB, [FieldNameDB])]
udspair =
([Column] -> EntityDef -> AlterDB
addTable [Column]
newcols EntityDef
entity) forall a. a -> [a] -> [a]
: [AlterDB]
uniques forall a. [a] -> [a] -> [a]
++ [AlterDB]
references forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreignsAlt
where
uniques :: [AlterDB]
uniques = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(ConstraintNameDB, [FieldNameDB])]
udspair forall a b. (a -> b) -> a -> b
$ \(ConstraintNameDB
uname, [FieldNameDB]
ucols) ->
[EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name forall a b. (a -> b) -> a -> b
$ ConstraintNameDB -> [FieldNameDB] -> AlterTable
AddUniqueConstraint ConstraintNameDB
uname [FieldNameDB]
ucols]
references :: [AlterDB]
references =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\Column { FieldNameDB
cName :: FieldNameDB
cName :: Column -> FieldNameDB
cName, Maybe ColumnReference
cReference :: Column -> Maybe ColumnReference
cReference :: Maybe ColumnReference
cReference } ->
[EntityDef]
-> EntityDef -> FieldNameDB -> ColumnReference -> Maybe AlterDB
getAddReference [EntityDef]
allDefs EntityDef
entity FieldNameDB
cName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ColumnReference
cReference
)
[Column]
newcols
foreignsAlt :: [AlterDB]
foreignsAlt = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (EntityDef -> ForeignDef -> Maybe AlterDB
mkForeignAlt EntityDef
entity) [ForeignDef]
fdefs_
mkForeignAlt
:: EntityDef
-> ForeignDef
-> Maybe AlterDB
mkForeignAlt :: EntityDef -> ForeignDef -> Maybe AlterDB
mkForeignAlt EntityDef
entity ForeignDef
fdef = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
tableName_ AlterColumn
addReference
where
tableName_ :: EntityNameDB
tableName_ = EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
addReference :: AlterColumn
addReference =
EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [Text]
-> FieldCascade
-> AlterColumn
AddReference
(ForeignDef -> EntityNameDB
foreignRefTableDBName ForeignDef
fdef)
ConstraintNameDB
constraintName
[FieldNameDB]
childfields
[Text]
escapedParentFields
(ForeignDef -> FieldCascade
foreignFieldCascade ForeignDef
fdef)
constraintName :: ConstraintNameDB
constraintName =
ForeignDef -> ConstraintNameDB
foreignConstraintNameDBName ForeignDef
fdef
([FieldNameDB]
childfields, [FieldNameDB]
parentfields) =
forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (\((FieldNameHS
_,FieldNameDB
b),(FieldNameHS
_,FieldNameDB
d)) -> (FieldNameDB
b,FieldNameDB
d)) (ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields ForeignDef
fdef))
escapedParentFields :: [Text]
escapedParentFields =
forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
parentfields
addTable :: [Column] -> EntityDef -> AlterDB
addTable :: [Column] -> EntityDef -> AlterDB
addTable [Column]
cols EntityDef
entity =
Text -> AlterDB
AddTable forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"CREATe TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
name
, Text
"("
, Text
idtxt
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Column]
nonIdCols then Text
"" else Text
","
, Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Column -> Text
showColumn [Column]
nonIdCols
, Text
")"
]
where
nonIdCols :: [Column]
nonIdCols =
case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
entity of
Just CompositeDef
_ ->
[Column]
cols
Maybe CompositeDef
_ ->
forall a. (a -> Bool) -> [a] -> [a]
filter Column -> Bool
keepField [Column]
cols
where
keepField :: Column -> Bool
keepField Column
c =
forall a. a -> Maybe a
Just (Column -> FieldNameDB
cName Column
c) forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
entity)
Bool -> Bool -> Bool
&& Bool -> Bool
not (EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
entity (Column -> FieldNameDB
cName Column
c))
name :: EntityNameDB
name =
EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
idtxt :: Text
idtxt =
case EntityDef -> EntityIdDef
getEntityId EntityDef
entity of
EntityIdNaturalKey CompositeDef
pdef ->
[Text] -> Text
T.concat
[ Text
" PRIMARY KEY ("
, Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
, Text
")"
]
EntityIdField FieldDef
field ->
let defText :: Maybe Text
defText = [FieldAttr] -> Maybe Text
defaultAttribute forall a b. (a -> b) -> a -> b
$ FieldDef -> [FieldAttr]
fieldAttrs FieldDef
field
sType :: SqlType
sType = FieldDef -> SqlType
fieldSqlType FieldDef
field
in [Text] -> Text
T.concat
[ FieldNameDB -> Text
escapeF forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB FieldDef
field
, SqlType -> Maybe Text -> Text
maySerial SqlType
sType Maybe Text
defText
, Text
" PRIMARY KEY UNIQUE"
, Maybe Text -> Text
mayDefault Maybe Text
defText
]
maySerial :: SqlType -> Maybe Text -> Text
maySerial :: SqlType -> Maybe Text -> Text
maySerial SqlType
SqlInt64 Maybe Text
Nothing = Text
" SERIAL8 "
maySerial SqlType
sType Maybe Text
_ = Text
" " forall a. Semigroup a => a -> a -> a
<> SqlType -> Text
showSqlType SqlType
sType
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 " forall a. Semigroup a => a -> a -> a
<> Text
d
type SafeToRemove = Bool
data AlterColumn
= ChangeType Column SqlType Text
| IsNull Column
| NotNull Column
| Add' Column
| Drop Column SafeToRemove
| Default Column Text
| NoDefault Column
| Update' Column Text
| AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [Text] FieldCascade
| DropReference ConstraintNameDB
deriving Int -> AlterColumn -> ShowS
[AlterColumn] -> ShowS
AlterColumn -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AlterColumn] -> ShowS
$cshowList :: [AlterColumn] -> ShowS
show :: AlterColumn -> [Char]
$cshow :: AlterColumn -> [Char]
showsPrec :: Int -> AlterColumn -> ShowS
$cshowsPrec :: Int -> AlterColumn -> ShowS
Show
data AlterTable
= AddUniqueConstraint ConstraintNameDB [FieldNameDB]
| DropConstraint ConstraintNameDB
deriving Int -> AlterTable -> ShowS
[AlterTable] -> ShowS
AlterTable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AlterTable] -> ShowS
$cshowList :: [AlterTable] -> ShowS
show :: AlterTable -> [Char]
$cshow :: AlterTable -> [Char]
showsPrec :: Int -> AlterTable -> ShowS
$cshowsPrec :: Int -> AlterTable -> ShowS
Show
data AlterDB = AddTable Text
| AlterColumn EntityNameDB AlterColumn
| AlterTable EntityNameDB AlterTable
deriving Int -> AlterDB -> ShowS
[AlterDB] -> ShowS
AlterDB -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AlterDB] -> ShowS
$cshowList :: [AlterDB] -> ShowS
show :: AlterDB -> [Char]
$cshow :: AlterDB -> [Char]
showsPrec :: Int -> AlterDB -> ShowS
$cshowsPrec :: Int -> AlterDB -> ShowS
Show
getColumns :: (Text -> IO Statement)
-> EntityDef -> [Column]
-> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns :: (Text -> IO Statement)
-> EntityDef
-> [Column]
-> IO
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
getColumns Text -> IO Statement
getter EntityDef
def [Column]
cols = do
let sqlv :: Text
sqlv = [Text] -> Text
T.concat
[ Text
"SELECT "
, Text
"column_name "
, Text
",is_nullable "
, Text
",COALESCE(domain_name, udt_name)"
, Text
",column_default "
, Text
",generation_expression "
, Text
",numeric_precision "
, Text
",numeric_scale "
, Text
",character_maximum_length "
, Text
"FROM information_schema.columns "
, Text
"WHERE table_catalog=current_database() "
, Text
"AND table_schema=current_schema() "
, Text
"AND table_name=? "
]
Statement
stmt <- Text -> IO Statement
getter Text
sqlv
let vals :: [PersistValue]
vals =
[ Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB forall a b. (a -> b) -> a -> b
$ EntityDef -> EntityNameDB
getEntityDBName EntityDef
def
]
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
columns <- forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt [PersistValue]
vals) (\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
[PersistValue]
(Either Text (Either Column (ConstraintNameDB, [FieldNameDB])))
IO
()
processColumns forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
let sqlc :: Text
sqlc = [Text] -> Text
T.concat
[ Text
"SELECT "
, Text
"c.constraint_name, "
, Text
"c.column_name "
, Text
"FROM information_schema.key_column_usage AS c, "
, Text
"information_schema.table_constraints AS k "
, Text
"WHERE c.table_catalog=current_database() "
, Text
"AND c.table_catalog=k.table_catalog "
, Text
"AND c.table_schema=current_schema() "
, Text
"AND c.table_schema=k.table_schema "
, Text
"AND c.table_name=? "
, Text
"AND c.table_name=k.table_name "
, Text
"AND c.constraint_name=k.constraint_name "
, Text
"AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') "
, Text
"ORDER BY c.constraint_name, c.column_name"
]
Statement
stmt' <- Text -> IO Statement
getter Text
sqlc
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
us <- forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt' [PersistValue]
vals) (\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
[PersistValue]
Void
IO
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
helperU)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
columns forall a. [a] -> [a] -> [a]
++ [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
us
where
refMap :: Map Text (EntityNameDB, ConstraintNameDB)
refMap =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ColumnReference
cr -> (ColumnReference -> EntityNameDB
crTableName ColumnReference
cr, ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cr))
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(Text, ColumnReference)] -> Column -> [(Text, ColumnReference)]
ref [] [Column]
cols
where
ref :: [(Text, ColumnReference)] -> Column -> [(Text, ColumnReference)]
ref [(Text, ColumnReference)]
rs Column
c =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Text, ColumnReference)]
rs (\ColumnReference
r -> (FieldNameDB -> Text
unFieldNameDB forall a b. (a -> b) -> a -> b
$ Column -> FieldNameDB
cName Column
c, ColumnReference
r) forall a. a -> [a] -> [a]
: [(Text, ColumnReference)]
rs) (Column -> Maybe ColumnReference
cReference Column
c)
getAll :: ConduitT [PersistValue] (Text, Text) IO ()
getAll =
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall a b. (a -> b) -> a -> b
$ \[PersistValue]
x ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case [PersistValue]
x of
[PersistText Text
con, PersistText Text
col] ->
(Text
con, Text
col)
[PersistByteString ConnectionString
con, PersistByteString ConnectionString
col] ->
(ConnectionString -> Text
T.decodeUtf8 ConnectionString
con, ConnectionString -> Text
T.decodeUtf8 ConnectionString
col)
[PersistValue]
o ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected datatype returned for postgres o="forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show [PersistValue]
o
helperU :: ConduitT
[PersistValue]
Void
IO
[Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))]
helperU = do
[(Text, Text)]
rows <- ConduitT [PersistValue] (Text, Text) IO ()
getAll forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ConstraintNameDB
ConstraintNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldNameDB
FieldNameDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)))
forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [(Text, Text)]
rows
processColumns :: ConduitT
[PersistValue]
(Either Text (Either Column (ConstraintNameDB, [FieldNameDB])))
IO
()
processColumns =
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall a b. (a -> b) -> a -> b
$ \x' :: [PersistValue]
x'@((PersistText Text
cname) : [PersistValue]
_) -> do
Either Text Column
col <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (Text -> IO Statement)
-> EntityNameDB
-> [PersistValue]
-> Maybe (EntityNameDB, ConstraintNameDB)
-> IO (Either Text Column)
getColumn Text -> IO Statement
getter (EntityDef -> EntityNameDB
getEntityDBName EntityDef
def) [PersistValue]
x' (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
cname Map Text (EntityNameDB, ConstraintNameDB)
refMap)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either Text Column
col of
Left Text
e -> forall a b. a -> Either a b
Left Text
e
Right Column
c -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Column
c
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove :: EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def (FieldNameDB Text
colName)
= forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FieldAttr
FieldAttrSafeToRemove forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> [FieldAttr]
fieldAttrs)
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Text -> FieldNameDB
FieldNameDB Text
colName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB)
forall a b. (a -> b) -> a -> b
$ [FieldDef]
allEntityFields
where
allEntityFields :: [FieldDef]
allEntityFields =
EntityDef -> [FieldDef]
getEntityFieldsDatabase EntityDef
def forall a. Semigroup a => a -> a -> a
<> case EntityDef -> EntityIdDef
getEntityId EntityDef
def of
EntityIdField FieldDef
fdef ->
[FieldDef
fdef]
EntityIdDef
_ ->
[]
getAlters :: [EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters :: [EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters [EntityDef]
defs EntityDef
def ([Column]
c1, [(ConstraintNameDB, [FieldNameDB])]
u1) ([Column]
c2, [(ConstraintNameDB, [FieldNameDB])]
u2) =
([Column] -> [Column] -> [AlterColumn]
getAltersC [Column]
c1 [Column]
c2, [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
u1 [(ConstraintNameDB, [FieldNameDB])]
u2)
where
getAltersC :: [Column] -> [Column] -> [AlterColumn]
getAltersC [] [Column]
old =
forall a b. (a -> b) -> [a] -> [b]
map (\Column
x -> Column -> Bool -> AlterColumn
Drop Column
x forall a b. (a -> b) -> a -> b
$ EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
def forall a b. (a -> b) -> a -> b
$ Column -> FieldNameDB
cName Column
x) [Column]
old
getAltersC (Column
new:[Column]
news) [Column]
old =
let ([AlterColumn]
alters, [Column]
old') = [EntityDef]
-> EntityDef -> Column -> [Column] -> ([AlterColumn], [Column])
findAlters [EntityDef]
defs EntityDef
def Column
new [Column]
old
in [AlterColumn]
alters forall a. [a] -> [a] -> [a]
++ [Column] -> [Column] -> [AlterColumn]
getAltersC [Column]
news [Column]
old'
getAltersU
:: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])]
-> [AlterTable]
getAltersU :: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [] [(ConstraintNameDB, [FieldNameDB])]
old =
forall a b. (a -> b) -> [a] -> [b]
map ConstraintNameDB -> AlterTable
DropConstraint forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintNameDB -> Bool
isManual) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ConstraintNameDB, [FieldNameDB])]
old
getAltersU ((ConstraintNameDB
name, [FieldNameDB]
cols):[(ConstraintNameDB, [FieldNameDB])]
news) [(ConstraintNameDB, [FieldNameDB])]
old =
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ConstraintNameDB
name [(ConstraintNameDB, [FieldNameDB])]
old of
Maybe [FieldNameDB]
Nothing ->
ConstraintNameDB -> [FieldNameDB] -> AlterTable
AddUniqueConstraint ConstraintNameDB
name [FieldNameDB]
cols forall a. a -> [a] -> [a]
: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old
Just [FieldNameDB]
ocols ->
let old' :: [(ConstraintNameDB, [FieldNameDB])]
old' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ConstraintNameDB
x, [FieldNameDB]
_) -> ConstraintNameDB
x forall a. Eq a => a -> a -> Bool
/= ConstraintNameDB
name) [(ConstraintNameDB, [FieldNameDB])]
old
in if forall a. Ord a => [a] -> [a]
sort [FieldNameDB]
cols forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
sort [FieldNameDB]
ocols
then [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old'
else ConstraintNameDB -> AlterTable
DropConstraint ConstraintNameDB
name
forall a. a -> [a] -> [a]
: ConstraintNameDB -> [FieldNameDB] -> AlterTable
AddUniqueConstraint ConstraintNameDB
name [FieldNameDB]
cols
forall a. a -> [a] -> [a]
: [(ConstraintNameDB, [FieldNameDB])]
-> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable]
getAltersU [(ConstraintNameDB, [FieldNameDB])]
news [(ConstraintNameDB, [FieldNameDB])]
old'
isManual :: ConstraintNameDB -> Bool
isManual (ConstraintNameDB Text
x) = Text
"__manual_" Text -> Text -> Bool
`T.isPrefixOf` Text
x
getColumn
:: (Text -> IO Statement)
-> EntityNameDB
-> [PersistValue]
-> Maybe (EntityNameDB, ConstraintNameDB)
-> IO (Either Text Column)
getColumn :: (Text -> IO Statement)
-> EntityNameDB
-> [PersistValue]
-> Maybe (EntityNameDB, ConstraintNameDB)
-> IO (Either Text Column)
getColumn Text -> IO Statement
getter EntityNameDB
tableName' [ PersistText Text
columnName
, PersistText Text
isNullable
, PersistText Text
typeName
, PersistValue
defaultValue
, PersistValue
generationExpression
, PersistValue
numericPrecision
, PersistValue
numericScale
, PersistValue
maxlen
] Maybe (EntityNameDB, ConstraintNameDB)
refName_ = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
Maybe Text
defaultValue' <-
case PersistValue
defaultValue of
PersistValue
PersistNull ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
PersistText Text
t ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
t
PersistValue
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid default column: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
defaultValue
Maybe Text
generationExpression' <-
case PersistValue
generationExpression of
PersistValue
PersistNull ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
PersistText Text
t ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
t
PersistValue
_ ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid generated column: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
generationExpression
let typeStr :: Text
typeStr =
case PersistValue
maxlen of
PersistInt64 Int64
n ->
[Text] -> Text
T.concat [Text
typeName, Text
"(", [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int64
n), Text
")"]
PersistValue
_ ->
Text
typeName
SqlType
t <- Text -> ExceptT Text IO SqlType
getType Text
typeStr
let cname :: FieldNameDB
cname = Text -> FieldNameDB
FieldNameDB Text
columnName
Maybe (EntityNameDB, ConstraintNameDB, Text, Text)
ref <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FieldNameDB
-> (EntityNameDB, ConstraintNameDB)
-> IO (Maybe (EntityNameDB, ConstraintNameDB, Text, Text))
getRef FieldNameDB
cname) Maybe (EntityNameDB, ConstraintNameDB)
refName_
forall (m :: * -> *) a. Monad m => a -> m a
return Column
{ cName :: FieldNameDB
cName = FieldNameDB
cname
, cNull :: Bool
cNull = Text
isNullable forall a. Eq a => a -> a -> Bool
== Text
"YES"
, cSqlType :: SqlType
cSqlType = SqlType
t
, cDefault :: Maybe Text
cDefault = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
stripSuffixes Maybe Text
defaultValue'
, cGenerated :: Maybe Text
cGenerated = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
stripSuffixes Maybe Text
generationExpression'
, cDefaultConstraintName :: Maybe ConstraintNameDB
cDefaultConstraintName = forall a. Maybe a
Nothing
, cMaxLen :: Maybe Integer
cMaxLen = forall a. Maybe a
Nothing
, cReference :: Maybe ColumnReference
cReference = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(EntityNameDB
a,ConstraintNameDB
b,Text
c,Text
d) -> EntityNameDB -> ConstraintNameDB -> FieldCascade -> ColumnReference
ColumnReference EntityNameDB
a ConstraintNameDB
b (forall {a} {a}.
(Eq a, Eq a, IsString a, IsString a, Show a, Show a) =>
a -> a -> FieldCascade
mkCascade Text
c Text
d)) Maybe (EntityNameDB, ConstraintNameDB, Text, Text)
ref
}
where
mkCascade :: a -> a -> FieldCascade
mkCascade a
updText a
delText =
FieldCascade
{ fcOnUpdate :: Maybe CascadeAction
fcOnUpdate = forall {a}. (Eq a, IsString a, Show a) => a -> Maybe CascadeAction
parseCascade a
updText
, fcOnDelete :: Maybe CascadeAction
fcOnDelete = forall {a}. (Eq a, IsString a, Show a) => a -> Maybe CascadeAction
parseCascade a
delText
}
parseCascade :: a -> Maybe CascadeAction
parseCascade a
txt =
case a
txt of
a
"NO ACTION" ->
forall a. Maybe a
Nothing
a
"CASCADE" ->
forall a. a -> Maybe a
Just CascadeAction
Cascade
a
"SET NULL" ->
forall a. a -> Maybe a
Just CascadeAction
SetNull
a
"SET DEFAULT" ->
forall a. a -> Maybe a
Just CascadeAction
SetDefault
a
"RESTRICT" ->
forall a. a -> Maybe a
Just CascadeAction
Restrict
a
_ ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value in parseCascade: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
txt
stripSuffixes :: Text -> Text
stripSuffixes Text
t =
[Text] -> Text
loop'
[ Text
"::character varying"
, Text
"::text"
]
where
loop' :: [Text] -> Text
loop' [] = Text
t
loop' (Text
p:[Text]
ps) =
case Text -> Text -> Maybe Text
T.stripSuffix Text
p Text
t of
Maybe Text
Nothing -> [Text] -> Text
loop' [Text]
ps
Just Text
t' -> Text
t'
getRef :: FieldNameDB
-> (EntityNameDB, ConstraintNameDB)
-> IO (Maybe (EntityNameDB, ConstraintNameDB, Text, Text))
getRef FieldNameDB
cname (EntityNameDB
_, ConstraintNameDB
refName') = do
let sql :: Text
sql = [Text] -> Text
T.concat
[ Text
"SELECT DISTINCT "
, Text
"ccu.table_name, "
, Text
"tc.constraint_name, "
, Text
"rc.update_rule, "
, Text
"rc.delete_rule "
, Text
"FROM information_schema.constraint_column_usage ccu "
, Text
"INNER JOIN information_schema.key_column_usage kcu "
, Text
" ON ccu.constraint_name = kcu.constraint_name "
, Text
"INNER JOIN information_schema.table_constraints tc "
, Text
" ON tc.constraint_name = kcu.constraint_name "
, Text
"LEFT JOIN information_schema.referential_constraints AS rc"
, Text
" ON rc.constraint_name = ccu.constraint_name "
, Text
"WHERE tc.constraint_type='FOREIGN KEY' "
, Text
"AND kcu.ordinal_position=1 "
, Text
"AND kcu.table_name=? "
, Text
"AND kcu.column_name=? "
, Text
"AND tc.constraint_name=?"
]
Statement
stmt <- Text -> IO Statement
getter Text
sql
[[PersistValue]]
cntrs <-
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with
(Statement
-> forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery Statement
stmt
[ Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ EntityNameDB -> Text
unEntityNameDB EntityNameDB
tableName'
, Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ FieldNameDB -> Text
unFieldNameDB FieldNameDB
cname
, Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ ConstraintNameDB -> Text
unConstraintNameDB ConstraintNameDB
refName'
]
)
(\ConduitM () [PersistValue] IO ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () [PersistValue] IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
case [[PersistValue]]
cntrs of
[] ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
[[PersistText Text
table, PersistText Text
constraint, PersistText Text
updRule, PersistText Text
delRule]] ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text -> EntityNameDB
EntityNameDB Text
table, Text -> ConstraintNameDB
ConstraintNameDB Text
constraint, Text
updRule, Text
delRule)
[[PersistValue]]
xs ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ [Char]
"Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: "
, Text -> [Char]
T.unpack (EntityNameDB -> Text
unEntityNameDB EntityNameDB
tableName')
, [Char]
" and column: "
, Text -> [Char]
T.unpack (FieldNameDB -> Text
unFieldNameDB FieldNameDB
cname)
, [Char]
" but got: "
, forall a. Show a => a -> [Char]
show [[PersistValue]]
xs
]
getType :: Text -> ExceptT Text IO SqlType
getType Text
"int4" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlInt32
getType Text
"int8" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlInt64
getType Text
"varchar" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlString
getType Text
"text" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlString
getType Text
"date" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlDay
getType Text
"bool" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlBool
getType Text
"timestamptz" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlDayTime
getType Text
"float4" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlReal
getType Text
"float8" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlReal
getType Text
"bytea" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlBlob
getType Text
"time" = forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlType
SqlTime
getType Text
"numeric" = PersistValue -> PersistValue -> ExceptT Text IO SqlType
getNumeric PersistValue
numericPrecision PersistValue
numericScale
getType Text
a = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> SqlType
SqlOther Text
a
getNumeric :: PersistValue -> PersistValue -> ExceptT Text IO SqlType
getNumeric (PersistInt64 Int64
a) (PersistInt64 Int64
b) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> SqlType
SqlNumeric (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
a) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
b)
getNumeric PersistValue
PersistNull PersistValue
PersistNull = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"No precision and scale were specified for the column: "
, Text
columnName
, Text
" in table: "
, EntityNameDB -> Text
unEntityNameDB EntityNameDB
tableName'
, Text
". Postgres defaults to a maximum scale of 147,455 and precision of 16383,"
, Text
" which is probably not what you intended."
, Text
" Specify the values as numeric(total_digits, digits_after_decimal_place)."
]
getNumeric PersistValue
a PersistValue
b = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Can not get numeric field precision for the column: "
, Text
columnName
, Text
" in table: "
, EntityNameDB -> Text
unEntityNameDB EntityNameDB
tableName'
, Text
". Expected an integer for both precision and scale, "
, Text
"got: "
, [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PersistValue
a
, Text
" and "
, [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PersistValue
b
, Text
", respectively."
, Text
" Specify the values as numeric(total_digits, digits_after_decimal_place)."
]
getColumn Text -> IO Statement
_ EntityNameDB
_ [PersistValue]
columnName Maybe (EntityNameDB, ConstraintNameDB)
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid result from information_schema: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
columnName
sqlTypeEq :: SqlType -> SqlType -> Bool
sqlTypeEq :: SqlType -> SqlType -> Bool
sqlTypeEq SqlType
x SqlType
y =
Text -> Text
T.toCaseFold (SqlType -> Text
showSqlType SqlType
x) forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toCaseFold (SqlType -> Text
showSqlType SqlType
y)
findAlters
:: [EntityDef]
-> EntityDef
-> Column
-> [Column]
-> ([AlterColumn], [Column])
findAlters :: [EntityDef]
-> EntityDef -> Column -> [Column] -> ([AlterColumn], [Column])
findAlters [EntityDef]
defs EntityDef
edef col :: Column
col@(Column FieldNameDB
name Bool
isNull SqlType
sqltype Maybe Text
def Maybe Text
_gen Maybe ConstraintNameDB
_defConstraintName Maybe Integer
_maxLen Maybe ColumnReference
ref) [Column]
cols =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\Column
c -> Column -> FieldNameDB
cName Column
c forall a. Eq a => a -> a -> Bool
== FieldNameDB
name) [Column]
cols of
Maybe Column
Nothing ->
([Column -> AlterColumn
Add' Column
col], [Column]
cols)
Just (Column FieldNameDB
_oldName Bool
isNull' SqlType
sqltype' Maybe Text
def' Maybe Text
_gen' Maybe ConstraintNameDB
_defConstraintName' Maybe Integer
_maxLen' Maybe ColumnReference
ref') ->
let refDrop :: Maybe ColumnReference -> [AlterColumn]
refDrop Maybe ColumnReference
Nothing = []
refDrop (Just ColumnReference {crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName=ConstraintNameDB
cname}) =
[ConstraintNameDB -> AlterColumn
DropReference ConstraintNameDB
cname]
refAdd :: Maybe ColumnReference -> [AlterColumn]
refAdd Maybe ColumnReference
Nothing = []
refAdd (Just ColumnReference
colRef) =
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== ColumnReference -> EntityNameDB
crTableName ColumnReference
colRef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName) [EntityDef]
defs of
Just EntityDef
refdef
| forall a. a -> Maybe a
Just FieldNameDB
_oldName forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
edef)
->
[EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [Text]
-> FieldCascade
-> AlterColumn
AddReference
(ColumnReference -> EntityNameDB
crTableName ColumnReference
colRef)
(ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
colRef)
[FieldNameDB
name]
(forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
Util.dbIdColumnsEsc FieldNameDB -> Text
escapeF EntityDef
refdef)
(ColumnReference -> FieldCascade
crFieldCascade ColumnReference
colRef)
]
Just EntityDef
_ -> []
Maybe EntityDef
Nothing ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"could not find the entityDef for reftable["
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ColumnReference -> EntityNameDB
crTableName ColumnReference
colRef) forall a. [a] -> [a] -> [a]
++ [Char]
"]"
modRef :: [AlterColumn]
modRef =
if Maybe ColumnReference -> Maybe ColumnReference -> Bool
equivalentRef Maybe ColumnReference
ref Maybe ColumnReference
ref'
then []
else Maybe ColumnReference -> [AlterColumn]
refDrop Maybe ColumnReference
ref' forall a. [a] -> [a] -> [a]
++ Maybe ColumnReference -> [AlterColumn]
refAdd Maybe ColumnReference
ref
modNull :: [AlterColumn]
modNull = case (Bool
isNull, Bool
isNull') of
(Bool
True, Bool
False) -> do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FieldNameDB
name forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
edef)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Column -> AlterColumn
IsNull Column
col)
(Bool
False, Bool
True) ->
let up :: [AlterColumn] -> [AlterColumn]
up = case Maybe Text
def of
Maybe Text
Nothing -> forall a. a -> a
id
Just Text
s -> (:) (Column -> Text -> AlterColumn
Update' Column
col Text
s)
in [AlterColumn] -> [AlterColumn]
up [Column -> AlterColumn
NotNull Column
col]
(Bool, Bool)
_ -> []
modType :: [AlterColumn]
modType
| SqlType -> SqlType -> Bool
sqlTypeEq SqlType
sqltype SqlType
sqltype' = []
| SqlType
sqltype forall a. Eq a => a -> a -> Bool
== SqlType
SqlDayTime Bool -> Bool -> Bool
&& SqlType
sqltype' forall a. Eq a => a -> a -> Bool
== Text -> SqlType
SqlOther Text
"timestamp" =
[Column -> SqlType -> Text -> AlterColumn
ChangeType Column
col SqlType
sqltype forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
" USING "
, FieldNameDB -> Text
escapeF FieldNameDB
name
, Text
" AT TIME ZONE 'UTC'"
]]
| Bool
otherwise = [Column -> SqlType -> Text -> AlterColumn
ChangeType Column
col SqlType
sqltype Text
""]
modDef :: [AlterColumn]
modDef =
if Maybe Text
def forall a. Eq a => a -> a -> Bool
== Maybe Text
def'
Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust (Text -> Text -> Maybe Text
T.stripPrefix Text
"nextval" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
def')
then []
else
case Maybe Text
def of
Maybe Text
Nothing -> [Column -> AlterColumn
NoDefault Column
col]
Just Text
s -> [Column -> Text -> AlterColumn
Default Column
col Text
s]
dropSafe :: [AlterColumn]
dropSafe =
if EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
edef FieldNameDB
name
then forall a. HasCallStack => [Char] -> a
error [Char]
"wtf" [Column -> Bool -> AlterColumn
Drop Column
col Bool
True]
else []
in
( [AlterColumn]
modRef forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modDef forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modNull forall a. [a] -> [a] -> [a]
++ [AlterColumn]
modType forall a. [a] -> [a] -> [a]
++ [AlterColumn]
dropSafe
, forall a. (a -> Bool) -> [a] -> [a]
filter (\Column
c -> Column -> FieldNameDB
cName Column
c forall a. Eq a => a -> a -> Bool
/= FieldNameDB
name) [Column]
cols
)
equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool
equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool
equivalentRef Maybe ColumnReference
Nothing Maybe ColumnReference
Nothing = Bool
True
equivalentRef (Just ColumnReference
cr1) (Just ColumnReference
cr2) =
ColumnReference -> EntityNameDB
crTableName ColumnReference
cr1 forall a. Eq a => a -> a -> Bool
== ColumnReference -> EntityNameDB
crTableName ColumnReference
cr2
Bool -> Bool -> Bool
&& ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cr1 forall a. Eq a => a -> a -> Bool
== ColumnReference -> ConstraintNameDB
crConstraintName ColumnReference
cr2
Bool -> Bool -> Bool
&& Maybe CascadeAction -> Maybe CascadeAction -> Bool
eqCascade (FieldCascade -> Maybe CascadeAction
fcOnUpdate forall a b. (a -> b) -> a -> b
$ ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr1) (FieldCascade -> Maybe CascadeAction
fcOnUpdate forall a b. (a -> b) -> a -> b
$ ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr2)
Bool -> Bool -> Bool
&& Maybe CascadeAction -> Maybe CascadeAction -> Bool
eqCascade (FieldCascade -> Maybe CascadeAction
fcOnDelete forall a b. (a -> b) -> a -> b
$ ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr1) (FieldCascade -> Maybe CascadeAction
fcOnDelete forall a b. (a -> b) -> a -> b
$ ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr2)
where
eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool
eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool
eqCascade Maybe CascadeAction
Nothing Maybe CascadeAction
Nothing = Bool
True
eqCascade Maybe CascadeAction
Nothing (Just CascadeAction
Restrict) = Bool
True
eqCascade (Just CascadeAction
Restrict) Maybe CascadeAction
Nothing = Bool
True
eqCascade (Just CascadeAction
cs1) (Just CascadeAction
cs2) = CascadeAction
cs1 forall a. Eq a => a -> a -> Bool
== CascadeAction
cs2
eqCascade Maybe CascadeAction
_ Maybe CascadeAction
_ = Bool
False
equivalentRef Maybe ColumnReference
_ Maybe ColumnReference
_ = Bool
False
getAddReference
:: [EntityDef]
-> EntityDef
-> FieldNameDB
-> ColumnReference
-> Maybe AlterDB
getAddReference :: [EntityDef]
-> EntityDef -> FieldNameDB -> ColumnReference -> Maybe AlterDB
getAddReference [EntityDef]
allDefs EntityDef
entity FieldNameDB
cname cr :: ColumnReference
cr@ColumnReference {crTableName :: ColumnReference -> EntityNameDB
crTableName = EntityNameDB
s, crConstraintName :: ColumnReference -> ConstraintNameDB
crConstraintName=ConstraintNameDB
constraintName} = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FieldNameDB
cname forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameDB
fieldDB (EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
entity)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ EntityNameDB -> AlterColumn -> AlterDB
AlterColumn
EntityNameDB
table
(EntityNameDB
-> ConstraintNameDB
-> [FieldNameDB]
-> [Text]
-> FieldCascade
-> AlterColumn
AddReference EntityNameDB
s ConstraintNameDB
constraintName [FieldNameDB
cname] [Text]
id_ (ColumnReference -> FieldCascade
crFieldCascade ColumnReference
cr)
)
where
table :: EntityNameDB
table = EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
id_ :: [Text]
id_ =
forall a. a -> Maybe a -> a
fromMaybe
(forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find ID of entity " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show EntityNameDB
s)
forall a b. (a -> b) -> a -> b
$ do
EntityDef
entDef <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== EntityNameDB
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName) [EntityDef]
allDefs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
Util.dbIdColumnsEsc FieldNameDB -> Text
escapeF EntityDef
entDef
showColumn :: Column -> Text
showColumn :: Column -> Text
showColumn (Column FieldNameDB
n Bool
nu SqlType
sqlType' Maybe Text
def Maybe Text
gen Maybe ConstraintNameDB
_defConstraintName Maybe Integer
_maxLen Maybe ColumnReference
_ref) = [Text] -> Text
T.concat
[ FieldNameDB -> Text
escapeF FieldNameDB
n
, Text
" "
, SqlType -> Text
showSqlType SqlType
sqlType'
, Text
" "
, if Bool
nu then Text
"NULL" else Text
"NOT NULL"
, case Maybe Text
def of
Maybe Text
Nothing -> Text
""
Just Text
s -> Text
" DEFAULT " forall a. Semigroup a => a -> a -> a
<> Text
s
, case Maybe Text
gen of
Maybe Text
Nothing -> Text
""
Just Text
s -> Text
" GENERATED ALWAYS AS (" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
") STORED"
]
showSqlType :: SqlType -> Text
showSqlType :: SqlType -> Text
showSqlType SqlType
SqlString = Text
"VARCHAR"
showSqlType SqlType
SqlInt32 = Text
"INT4"
showSqlType SqlType
SqlInt64 = Text
"INT8"
showSqlType SqlType
SqlReal = Text
"DOUBLE PRECISION"
showSqlType (SqlNumeric Word32
s Word32
prec) = [Text] -> Text
T.concat [ Text
"NUMERIC(", [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Word32
s), Text
",", [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Word32
prec), Text
")" ]
showSqlType SqlType
SqlDay = Text
"DATE"
showSqlType SqlType
SqlTime = Text
"TIME"
showSqlType SqlType
SqlDayTime = Text
"TIMESTAMP WITH TIME ZONE"
showSqlType SqlType
SqlBlob = Text
"BYTEA"
showSqlType SqlType
SqlBool = Text
"BOOLEAN"
showSqlType (SqlOther (Text -> Text
T.toLower -> Text
"integer")) = Text
"INT4"
showSqlType (SqlOther Text
t) = Text
t
showAlterDb :: AlterDB -> (Bool, Text)
showAlterDb :: AlterDB -> (Bool, Text)
showAlterDb (AddTable Text
s) = (Bool
False, Text
s)
showAlterDb (AlterColumn EntityNameDB
t AlterColumn
ac) =
(AlterColumn -> Bool
isUnsafe AlterColumn
ac, EntityNameDB -> AlterColumn -> Text
showAlter EntityNameDB
t AlterColumn
ac)
where
isUnsafe :: AlterColumn -> Bool
isUnsafe (Drop Column
_ Bool
safeRemove) = Bool -> Bool
not Bool
safeRemove
isUnsafe AlterColumn
_ = Bool
False
showAlterDb (AlterTable EntityNameDB
t AlterTable
at) = (Bool
False, EntityNameDB -> AlterTable -> Text
showAlterTable EntityNameDB
t AlterTable
at)
showAlterTable :: EntityNameDB -> AlterTable -> Text
showAlterTable :: EntityNameDB -> AlterTable -> Text
showAlterTable EntityNameDB
table (AddUniqueConstraint ConstraintNameDB
cname [FieldNameDB]
cols) = [Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ADD CONSTRAINT "
, ConstraintNameDB -> Text
escapeC ConstraintNameDB
cname
, Text
" UNIQUE("
, Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
cols
, Text
")"
]
showAlterTable EntityNameDB
table (DropConstraint ConstraintNameDB
cname) = [Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" DROP CONSTRAINT "
, ConstraintNameDB -> Text
escapeC ConstraintNameDB
cname
]
showAlter :: EntityNameDB -> AlterColumn -> Text
showAlter :: EntityNameDB -> AlterColumn -> Text
showAlter EntityNameDB
table (ChangeType Column
c SqlType
t Text
extra) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ALTER COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" TYPE "
, SqlType -> Text
showSqlType SqlType
t
, Text
extra
]
showAlter EntityNameDB
table (IsNull Column
c) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ALTER COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" DROP NOT NULL"
]
showAlter EntityNameDB
table (NotNull Column
c) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ALTER COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" SET NOT NULL"
]
showAlter EntityNameDB
table (Add' Column
col) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ADD COLUMN "
, Column -> Text
showColumn Column
col
]
showAlter EntityNameDB
table (Drop Column
c Bool
_) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" DROP COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
]
showAlter EntityNameDB
table (Default Column
c Text
s) =
[Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ALTER COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" SET DEFAULT "
, Text
s
]
showAlter EntityNameDB
table (NoDefault Column
c) = [Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ALTER COLUMN "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" DROP DEFAULT"
]
showAlter EntityNameDB
table (Update' Column
c Text
s) = [Text] -> Text
T.concat
[ Text
"UPDATE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" SET "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
"="
, Text
s
, Text
" WHERE "
, FieldNameDB -> Text
escapeF (Column -> FieldNameDB
cName Column
c)
, Text
" IS NULL"
]
showAlter EntityNameDB
table (AddReference EntityNameDB
reftable ConstraintNameDB
fkeyname [FieldNameDB]
t2 [Text]
id2 FieldCascade
cascade) = [Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" ADD CONSTRAINT "
, ConstraintNameDB -> Text
escapeC ConstraintNameDB
fkeyname
, Text
" FOREIGN KEY("
, Text -> [Text] -> Text
T.intercalate Text
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldNameDB -> Text
escapeF [FieldNameDB]
t2
, Text
") REFERENCES "
, EntityNameDB -> Text
escapeE EntityNameDB
reftable
, Text
"("
, Text -> [Text] -> Text
T.intercalate Text
"," [Text]
id2
, Text
")"
] forall a. Semigroup a => a -> a -> a
<> FieldCascade -> Text
renderFieldCascade FieldCascade
cascade
showAlter EntityNameDB
table (DropReference ConstraintNameDB
cname) = [Text] -> Text
T.concat
[ Text
"ALTER TABLE "
, EntityNameDB -> Text
escapeE EntityNameDB
table
, Text
" DROP CONSTRAINT "
, ConstraintNameDB -> Text
escapeC ConstraintNameDB
cname
]
tableName :: (PersistEntity record) => record -> Text
tableName :: forall record. PersistEntity record => record -> Text
tableName = EntityNameDB -> Text
escapeE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. PersistEntity record => record -> EntityNameDB
tableDBName
fieldName :: (PersistEntity record) => EntityField record typ -> Text
fieldName :: forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName = FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record typ.
PersistEntity record =>
EntityField record typ -> FieldNameDB
fieldDBName
escapeC :: ConstraintNameDB -> Text
escapeC :: ConstraintNameDB -> Text
escapeC = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escapeE :: EntityNameDB -> Text
escapeE :: EntityNameDB -> Text
escapeE = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escapeF :: FieldNameDB -> Text
escapeF :: FieldNameDB -> Text
escapeF = forall a str. DatabaseName a => (Text -> str) -> a -> str
escapeWith Text -> Text
escape
escape :: Text -> Text
escape :: Text -> Text
escape Text
s =
[Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Char
'"' forall a. a -> [a] -> [a]
: ShowS
go (Text -> [Char]
T.unpack Text
s) forall a. [a] -> [a] -> [a]
++ [Char]
"\""
where
go :: ShowS
go [Char]
"" = [Char]
""
go (Char
'"':[Char]
xs) = [Char]
"\"\"" forall a. [a] -> [a] -> [a]
++ ShowS
go [Char]
xs
go (Char
x:[Char]
xs) = Char
x forall a. a -> [a] -> [a]
: ShowS
go [Char]
xs
data PostgresConf = PostgresConf
{ PostgresConf -> ConnectionString
pgConnStr :: ConnectionString
, PostgresConf -> Int
pgPoolStripes :: Int
, PostgresConf -> Integer
pgPoolIdleTimeout :: Integer
, PostgresConf -> Int
pgPoolSize :: Int
} deriving (Int -> PostgresConf -> ShowS
[PostgresConf] -> ShowS
PostgresConf -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PostgresConf] -> ShowS
$cshowList :: [PostgresConf] -> ShowS
show :: PostgresConf -> [Char]
$cshow :: PostgresConf -> [Char]
showsPrec :: Int -> PostgresConf -> ShowS
$cshowsPrec :: Int -> PostgresConf -> ShowS
Show, ReadPrec [PostgresConf]
ReadPrec PostgresConf
Int -> ReadS PostgresConf
ReadS [PostgresConf]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PostgresConf]
$creadListPrec :: ReadPrec [PostgresConf]
readPrec :: ReadPrec PostgresConf
$creadPrec :: ReadPrec PostgresConf
readList :: ReadS [PostgresConf]
$creadList :: ReadS [PostgresConf]
readsPrec :: Int -> ReadS PostgresConf
$creadsPrec :: Int -> ReadS PostgresConf
Read, Typeable PostgresConf
PostgresConf -> DataType
PostgresConf -> Constr
(forall b. Data b => b -> b) -> PostgresConf -> PostgresConf
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PostgresConf -> u
forall u. (forall d. Data d => d -> u) -> PostgresConf -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PostgresConf
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PostgresConf -> c PostgresConf
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PostgresConf)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PostgresConf)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PostgresConf -> m PostgresConf
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PostgresConf -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PostgresConf -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> PostgresConf -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PostgresConf -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PostgresConf -> r
gmapT :: (forall b. Data b => b -> b) -> PostgresConf -> PostgresConf
$cgmapT :: (forall b. Data b => b -> b) -> PostgresConf -> PostgresConf
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PostgresConf)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PostgresConf)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PostgresConf)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PostgresConf)
dataTypeOf :: PostgresConf -> DataType
$cdataTypeOf :: PostgresConf -> DataType
toConstr :: PostgresConf -> Constr
$ctoConstr :: PostgresConf -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PostgresConf
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PostgresConf
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PostgresConf -> c PostgresConf
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PostgresConf -> c PostgresConf
Data)
instance FromJSON PostgresConf where
parseJSON :: Value -> Parser PostgresConf
parseJSON Value
v = forall a. ShowS -> Parser a -> Parser a
modifyFailure ([Char]
"Persistent: error loading PostgreSQL conf: " forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"PostgresConf") Value
v forall a b. (a -> b) -> a -> b
$ \Object
o -> do
let defaultPoolConfig :: ConnectionPoolConfig
defaultPoolConfig = ConnectionPoolConfig
defaultConnectionPoolConfig
[Char]
database <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"database"
[Char]
host <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"
Word16
port <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" forall a. Parser (Maybe a) -> a -> Parser a
.!= Word16
5432
[Char]
user <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user"
[Char]
password <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password"
Int
poolSize <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"poolsize" forall a. Parser (Maybe a) -> a -> Parser a
.!= (ConnectionPoolConfig -> Int
connectionPoolConfigSize ConnectionPoolConfig
defaultPoolConfig)
Int
poolStripes <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"stripes" forall a. Parser (Maybe a) -> a -> Parser a
.!= (ConnectionPoolConfig -> Int
connectionPoolConfigStripes ConnectionPoolConfig
defaultPoolConfig)
Integer
poolIdleTimeout <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"idleTimeout" forall a. Parser (Maybe a) -> a -> Parser a
.!= (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ ConnectionPoolConfig -> NominalDiffTime
connectionPoolConfigIdleTimeout ConnectionPoolConfig
defaultPoolConfig)
let ci :: ConnectInfo
ci = PG.ConnectInfo
{ connectHost :: [Char]
PG.connectHost = [Char]
host
, connectPort :: Word16
PG.connectPort = Word16
port
, connectUser :: [Char]
PG.connectUser = [Char]
user
, connectPassword :: [Char]
PG.connectPassword = [Char]
password
, connectDatabase :: [Char]
PG.connectDatabase = [Char]
database
}
cstr :: ConnectionString
cstr = ConnectInfo -> ConnectionString
PG.postgreSQLConnectionString ConnectInfo
ci
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConnectionString -> Int -> Integer -> Int -> PostgresConf
PostgresConf ConnectionString
cstr Int
poolStripes Integer
poolIdleTimeout Int
poolSize
instance PersistConfig PostgresConf where
type PersistConfigBackend PostgresConf = SqlPersistT
type PersistConfigPool PostgresConf = ConnectionPool
createPoolConfig :: PostgresConf -> IO (PersistConfigPool PostgresConf)
createPoolConfig PostgresConf
conf = forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PostgresConf -> PostgresConfHooks -> m (Pool SqlBackend)
createPostgresqlPoolWithConf PostgresConf
conf PostgresConfHooks
defaultPostgresConfHooks
runPool :: forall (m :: * -> *) a.
MonadUnliftIO m =>
PostgresConf
-> PersistConfigBackend PostgresConf m a
-> PersistConfigPool PostgresConf
-> m a
runPool PostgresConf
_ = forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
runSqlPool
loadConfig :: Value -> Parser PostgresConf
loadConfig = forall a. FromJSON a => Value -> Parser a
parseJSON
applyEnv :: PostgresConf -> IO PostgresConf
applyEnv PostgresConf
c0 = do
[([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> PostgresConf -> PostgresConf
addUser [([Char], [Char])]
env
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> PostgresConf -> PostgresConf
addPass [([Char], [Char])]
env
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> PostgresConf -> PostgresConf
addDatabase [([Char], [Char])]
env
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> PostgresConf -> PostgresConf
addPort [([Char], [Char])]
env
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])] -> PostgresConf -> PostgresConf
addHost [([Char], [Char])]
env PostgresConf
c0
where
addParam :: ConnectionString -> [Char] -> PostgresConf -> PostgresConf
addParam ConnectionString
param [Char]
val PostgresConf
c =
PostgresConf
c { pgConnStr :: ConnectionString
pgConnStr = [ConnectionString] -> ConnectionString
B8.concat [PostgresConf -> ConnectionString
pgConnStr PostgresConf
c, ConnectionString
" ", ConnectionString
param, ConnectionString
"='", [Char] -> ConnectionString
pgescape [Char]
val, ConnectionString
"'"] }
pgescape :: [Char] -> ConnectionString
pgescape = [Char] -> ConnectionString
B8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
go
where
go :: ShowS
go (Char
'\'':[Char]
rest) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'\'' forall a. a -> [a] -> [a]
: ShowS
go [Char]
rest
go (Char
'\\':[Char]
rest) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'\\' forall a. a -> [a] -> [a]
: ShowS
go [Char]
rest
go ( Char
x :[Char]
rest) = Char
x forall a. a -> [a] -> [a]
: ShowS
go [Char]
rest
go [] = []
maybeAddParam :: ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
param a
envvar [(a, [Char])]
env =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (ConnectionString -> [Char] -> PostgresConf -> PostgresConf
addParam ConnectionString
param) forall a b. (a -> b) -> a -> b
$
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
envvar [(a, [Char])]
env
addHost :: [([Char], [Char])] -> PostgresConf -> PostgresConf
addHost = forall {a}.
Eq a =>
ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
"host" [Char]
"PGHOST"
addPort :: [([Char], [Char])] -> PostgresConf -> PostgresConf
addPort = forall {a}.
Eq a =>
ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
"port" [Char]
"PGPORT"
addUser :: [([Char], [Char])] -> PostgresConf -> PostgresConf
addUser = forall {a}.
Eq a =>
ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
"user" [Char]
"PGUSER"
addPass :: [([Char], [Char])] -> PostgresConf -> PostgresConf
addPass = forall {a}.
Eq a =>
ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
"password" [Char]
"PGPASS"
addDatabase :: [([Char], [Char])] -> PostgresConf -> PostgresConf
addDatabase = forall {a}.
Eq a =>
ConnectionString
-> a -> [(a, [Char])] -> PostgresConf -> PostgresConf
maybeAddParam ConnectionString
"dbname" [Char]
"PGDATABASE"
data PostgresConfHooks = PostgresConfHooks
{ PostgresConfHooks -> Connection -> IO (NonEmpty Word)
pgConfHooksGetServerVersion :: PG.Connection -> IO (NonEmpty Word)
, PostgresConfHooks -> Connection -> IO ()
pgConfHooksAfterCreate :: PG.Connection -> IO ()
}
defaultPostgresConfHooks :: PostgresConfHooks
defaultPostgresConfHooks :: PostgresConfHooks
defaultPostgresConfHooks = PostgresConfHooks
{ pgConfHooksGetServerVersion :: Connection -> IO (NonEmpty Word)
pgConfHooksGetServerVersion = Connection -> IO (NonEmpty Word)
getServerVersionNonEmpty
, pgConfHooksAfterCreate :: Connection -> IO ()
pgConfHooksAfterCreate = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName (EntityNameDB Text
table) (FieldNameDB Text
column) =
let overhead :: Int
overhead = Text -> Int
T.length forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"_", Text
"_fkey"]
(Int
fromTable, Int
fromColumn) = Int -> (Int, Int) -> (Int, Int)
shortenNames Int
overhead (Text -> Int
T.length Text
table, Text -> Int
T.length Text
column)
in Text -> ConstraintNameDB
ConstraintNameDB forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Int -> Text -> Text
T.take Int
fromTable Text
table, Text
"_", Int -> Text -> Text
T.take Int
fromColumn Text
column, Text
"_fkey"]
where
shortenNames :: Int -> (Int, Int) -> (Int, Int)
shortenNames :: Int -> (Int, Int) -> (Int, Int)
shortenNames Int
overhead (Int
x, Int
y)
| Int
x forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
+ Int
overhead forall a. Ord a => a -> a -> Bool
<= Int
maximumIdentifierLength = (Int
x, Int
y)
| Int
x forall a. Ord a => a -> a -> Bool
> Int
y = Int -> (Int, Int) -> (Int, Int)
shortenNames Int
overhead (Int
x forall a. Num a => a -> a -> a
- Int
1, Int
y)
| Bool
otherwise = Int -> (Int, Int) -> (Int, Int)
shortenNames Int
overhead (Int
x, Int
y forall a. Num a => a -> a -> a
- Int
1)
maximumIdentifierLength :: Int
maximumIdentifierLength :: Int
maximumIdentifierLength = Int
63
udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair UniqueDef
ud = (UniqueDef -> ConstraintNameDB
uniqueDBName UniqueDef
ud, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields UniqueDef
ud)
mockMigrate :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
mockMigrate :: [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] [(Bool, Text)])
mockMigrate [EntityDef]
allDefs Text -> IO Statement
_ EntityDef
entity = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AlterDB -> (Bool, Text)
showAlterDb) forall a b. (a -> b) -> a -> b
$ do
case forall a b. [Either a b] -> ([a], [b])
partitionEithers [] of
([], [Either Column (ConstraintNameDB, [FieldNameDB])]
old'') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool
-> [Either Column (ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
migrationText Bool
False [Either Column (ConstraintNameDB, [FieldNameDB])]
old''
([Text]
errs, [Either Column (ConstraintNameDB, [FieldNameDB])]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Text]
errs
where
name :: EntityNameDB
name = EntityDef -> EntityNameDB
getEntityDBName EntityDef
entity
migrationText :: Bool
-> [Either Column (ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
migrationText Bool
exists' [Either Column (ConstraintNameDB, [FieldNameDB])]
old'' =
if Bool -> Bool
not Bool
exists'
then [Column]
-> [ForeignDef] -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
createText [Column]
newcols [ForeignDef]
fdefs [(ConstraintNameDB, [FieldNameDB])]
udspair
else let ([AlterColumn]
acs, [AlterTable]
ats) = [EntityDef]
-> EntityDef
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([Column], [(ConstraintNameDB, [FieldNameDB])])
-> ([AlterColumn], [AlterTable])
getAlters [EntityDef]
allDefs EntityDef
entity ([Column]
newcols, [(ConstraintNameDB, [FieldNameDB])]
udspair) ([Column], [(ConstraintNameDB, [FieldNameDB])])
old'
acs' :: [AlterDB]
acs' = forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterColumn -> AlterDB
AlterColumn EntityNameDB
name) [AlterColumn]
acs
ats' :: [AlterDB]
ats' = forall a b. (a -> b) -> [a] -> [b]
map (EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name) [AlterTable]
ats
in [AlterDB]
acs' forall a. [a] -> [a] -> [a]
++ [AlterDB]
ats'
where
old' :: ([Column], [(ConstraintNameDB, [FieldNameDB])])
old' = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Column (ConstraintNameDB, [FieldNameDB])]
old''
([Column]
newcols', [UniqueDef]
udefs, [ForeignDef]
fdefs) = [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
postgresMkColumns [EntityDef]
allDefs EntityDef
entity
newcols :: [Column]
newcols = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> FieldNameDB -> Bool
safeToRemove EntityDef
entity forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> FieldNameDB
cName) [Column]
newcols'
udspair :: [(ConstraintNameDB, [FieldNameDB])]
udspair = forall a b. (a -> b) -> [a] -> [b]
map UniqueDef -> (ConstraintNameDB, [FieldNameDB])
udToPair [UniqueDef]
udefs
createText :: [Column]
-> [ForeignDef] -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterDB]
createText [Column]
newcols [ForeignDef]
fdefs [(ConstraintNameDB, [FieldNameDB])]
udspair =
([Column] -> EntityDef -> AlterDB
addTable [Column]
newcols EntityDef
entity) forall a. a -> [a] -> [a]
: [AlterDB]
uniques forall a. [a] -> [a] -> [a]
++ [AlterDB]
references forall a. [a] -> [a] -> [a]
++ [AlterDB]
foreignsAlt
where
uniques :: [AlterDB]
uniques = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(ConstraintNameDB, [FieldNameDB])]
udspair forall a b. (a -> b) -> a -> b
$ \(ConstraintNameDB
uname, [FieldNameDB]
ucols) ->
[EntityNameDB -> AlterTable -> AlterDB
AlterTable EntityNameDB
name forall a b. (a -> b) -> a -> b
$ ConstraintNameDB -> [FieldNameDB] -> AlterTable
AddUniqueConstraint ConstraintNameDB
uname [FieldNameDB]
ucols]
references :: [AlterDB]
references =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\Column { FieldNameDB
cName :: FieldNameDB
cName :: Column -> FieldNameDB
cName, Maybe ColumnReference
cReference :: Maybe ColumnReference
cReference :: Column -> Maybe ColumnReference
cReference } ->
[EntityDef]
-> EntityDef -> FieldNameDB -> ColumnReference -> Maybe AlterDB
getAddReference [EntityDef]
allDefs EntityDef
entity FieldNameDB
cName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ColumnReference
cReference
)
[Column]
newcols
foreignsAlt :: [AlterDB]
foreignsAlt = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (EntityDef -> ForeignDef -> Maybe AlterDB
mkForeignAlt EntityDef
entity) [ForeignDef]
fdefs
mockMigration :: Migration -> IO ()
mockMigration :: Migration -> IO ()
mockMigration Migration
mig = do
IORef (Map Text Statement)
smap <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
let sqlbackend :: SqlBackend
sqlbackend =
MkSqlBackendArgs -> SqlBackend
mkSqlBackend MkSqlBackendArgs
{ connPrepare :: Text -> IO Statement
connPrepare = \Text
_ -> do
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
{ stmtFinalize :: IO ()
stmtFinalize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtReset :: IO ()
stmtReset = forall (m :: * -> *) a. Monad m => a -> m a
return ()
, stmtExecute :: [PersistValue] -> IO Int64
stmtExecute = forall a. HasCallStack => a
undefined
, stmtQuery :: forall (m :: * -> *).
MonadIO m =>
[PersistValue] -> Acquire (ConduitM () [PersistValue] m ())
stmtQuery = \[PersistValue]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
, connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult
connInsertSql = forall a. HasCallStack => a
undefined
, connStmtMap :: IORef (Map Text Statement)
connStmtMap = IORef (Map Text Statement)
smap
, connClose :: IO ()
connClose = 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)])
mockMigrate
, connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO ()
connBegin = forall a. HasCallStack => a
undefined
, connCommit :: (Text -> IO Statement) -> IO ()
connCommit = forall a. HasCallStack => a
undefined
, connRollback :: (Text -> IO Statement) -> IO ()
connRollback = forall a. HasCallStack => a
undefined
, connEscapeFieldName :: FieldNameDB -> Text
connEscapeFieldName = FieldNameDB -> Text
escapeF
, connEscapeTableName :: EntityDef -> Text
connEscapeTableName = EntityNameDB -> Text
escapeE forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName
, connEscapeRawName :: Text -> Text
connEscapeRawName = Text -> Text
escape
, connNoLimit :: Text
connNoLimit = forall a. HasCallStack => a
undefined
, connRDBMS :: Text
connRDBMS = forall a. HasCallStack => a
undefined
, connLimitOffset :: (Int, Int) -> Text -> Text
connLimitOffset = forall a. HasCallStack => a
undefined
, connLogFunc :: LogFunc
connLogFunc = forall a. HasCallStack => a
undefined
}
result :: SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT Migration
mig
(((), [Text]), [(Bool, Text)])
resp <- SqlBackend -> IO (((), [Text]), [(Bool, Text)])
result SqlBackend
sqlbackend
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (((), [Text]), [(Bool, Text)])
resp
putManySql :: EntityDef -> Int -> Text
putManySql :: EntityDef -> Int -> Text
putManySql EntityDef
ent Int
n = [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns [FieldDef]
fields EntityDef
ent Int
n
where
fields :: [FieldDef]
fields = EntityDef -> [FieldDef]
getEntityFields EntityDef
ent
conflictColumns :: [Text]
conflictColumns = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList 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 [FieldDef]
fields EntityDef
ent Int
n
where
fields :: [FieldDef]
fields = forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent
conflictColumns :: [Text]
conflictColumns = forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntityDef -> NonEmpty FieldDef
getEntityKeyFields EntityDef
ent
data HandleUpdateCollision record where
CopyField :: EntityField record typ -> HandleUpdateCollision record
CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record
copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record
copyUnlessNull :: forall typ record.
PersistField typ =>
EntityField record (Maybe typ) -> HandleUpdateCollision record
copyUnlessNull EntityField record (Maybe typ)
field = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq EntityField record (Maybe typ)
field forall a. Maybe a
Nothing
copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record
copyUnlessEmpty :: forall typ record.
(Monoid typ, PersistField typ) =>
EntityField record typ -> HandleUpdateCollision record
copyUnlessEmpty EntityField record typ
field = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq EntityField record typ
field forall a. Monoid a => a
Monoid.mempty
copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record
copyUnlessEq :: forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
copyUnlessEq = forall typ record.
PersistField typ =>
EntityField record typ -> typ -> HandleUpdateCollision record
CopyUnlessEq
copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record
copyField :: forall typ record.
PersistField typ =>
EntityField record typ -> HandleUpdateCollision record
copyField = forall record typ.
EntityField record typ -> HandleUpdateCollision record
CopyField
upsertWhere
:: ( backend ~ PersistEntityBackend record
, PersistEntity record
, PersistEntityBackend record ~ SqlBackend
, MonadIO m
, PersistStore backend
, BackendCompatible SqlBackend backend
, OnlyOneUniqueKey record
)
=> record
-> [Update record]
-> [Filter record]
-> ReaderT backend m ()
upsertWhere :: forall backend record (m :: * -> *).
(backend ~ PersistEntityBackend record, PersistEntity record,
PersistEntityBackend record ~ SqlBackend, MonadIO m,
PersistStore backend, BackendCompatible SqlBackend backend,
OnlyOneUniqueKey record) =>
record
-> [Update record] -> [Filter record] -> ReaderT backend m ()
upsertWhere record
record [Update record]
updates [Filter record]
filts =
forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
BackendCompatible SqlBackend backend,
PersistEntityBackend record ~ SqlBackend, PersistEntity record,
OnlyOneUniqueKey record, MonadIO m) =>
[record]
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> ReaderT backend m ()
upsertManyWhere [record
record] [] [Update record]
updates [Filter record]
filts
upsertManyWhere
:: forall record backend m.
( backend ~ PersistEntityBackend record
, BackendCompatible SqlBackend backend
, PersistEntityBackend record ~ SqlBackend
, PersistEntity record
, OnlyOneUniqueKey record
, MonadIO m
)
=> [record]
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> ReaderT backend m ()
upsertManyWhere :: forall record backend (m :: * -> *).
(backend ~ PersistEntityBackend record,
BackendCompatible SqlBackend backend,
PersistEntityBackend record ~ SqlBackend, PersistEntity record,
OnlyOneUniqueKey record, MonadIO m) =>
[record]
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> ReaderT backend m ()
upsertManyWhere [] [HandleUpdateCollision record]
_ [Update record]
_ [Filter record]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
upsertManyWhere [record]
records [HandleUpdateCollision record]
fieldValues [Update record]
updates [Filter record]
filters = do
SqlBackend
conn <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall sup sub. BackendCompatible sup sub => sub -> sup
projectBackend
let uniqDef :: UniqueDef
uniqDef = forall record (proxy :: * -> *).
(OnlyOneUniqueKey record, Monad proxy) =>
proxy record -> UniqueDef
onlyOneUniqueDef (forall {k} (t :: k). Proxy t
Proxy :: Proxy record)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute forall a b. (a -> b) -> a -> b
$
forall record.
(PersistEntity record, PersistEntityBackend record ~ SqlBackend,
OnlyOneUniqueKey record) =>
[record]
-> SqlBackend
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> UniqueDef
-> (Text, [PersistValue])
mkBulkUpsertQuery [record]
records SqlBackend
conn [HandleUpdateCollision record]
fieldValues [Update record]
updates [Filter record]
filters UniqueDef
uniqDef
excludeNotEqualToOriginal
:: (PersistField typ, PersistEntity rec)
=> EntityField rec typ
-> Filter rec
excludeNotEqualToOriginal :: forall typ rec.
(PersistField typ, PersistEntity rec) =>
EntityField rec typ -> Filter rec
excludeNotEqualToOriginal EntityField rec typ
field =
Filter
{ filterField :: EntityField rec typ
filterField =
EntityField rec typ
field
, filterFilter :: PersistFilter
filterFilter =
PersistFilter
Ne
, filterValue :: FilterValue typ
filterValue =
forall a typ. PersistField a => a -> FilterValue typ
UnsafeValue forall a b. (a -> b) -> a -> b
$
LiteralType -> ConnectionString -> PersistValue
PersistLiteral_
LiteralType
Unescaped
ConnectionString
bsForExcludedField
}
where
bsForExcludedField :: ConnectionString
bsForExcludedField =
Text -> ConnectionString
T.encodeUtf8
forall a b. (a -> b) -> a -> b
$ Text
"EXCLUDED."
forall a. Semigroup a => a -> a -> a
<> forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField rec typ
field
mkBulkUpsertQuery
:: (PersistEntity record, PersistEntityBackend record ~ SqlBackend, OnlyOneUniqueKey record)
=> [record]
-> SqlBackend
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> UniqueDef
-> (Text, [PersistValue])
mkBulkUpsertQuery :: forall record.
(PersistEntity record, PersistEntityBackend record ~ SqlBackend,
OnlyOneUniqueKey record) =>
[record]
-> SqlBackend
-> [HandleUpdateCollision record]
-> [Update record]
-> [Filter record]
-> UniqueDef
-> (Text, [PersistValue])
mkBulkUpsertQuery [record]
records SqlBackend
conn [HandleUpdateCollision record]
fieldValues [Update record]
updates [Filter record]
filters UniqueDef
uniqDef =
(Text
q, [PersistValue]
recordValues forall a. Semigroup a => a -> a -> a
<> [PersistValue]
updsValues forall a. Semigroup a => a -> a -> a
<> [PersistValue]
copyUnlessValues forall a. Semigroup a => a -> a -> a
<> [PersistValue]
whereVals)
where
mfieldDef :: HandleUpdateCollision record -> Either (Text, PersistValue) Text
mfieldDef HandleUpdateCollision record
x = case HandleUpdateCollision record
x of
CopyField EntityField record typ
rec -> forall a b. b -> Either a b
Right (FieldDef -> Text
fieldDbToText (forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
rec))
CopyUnlessEq EntityField record typ
rec typ
val -> forall a b. a -> Either a b
Left (FieldDef -> Text
fieldDbToText (forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
rec), forall a. PersistField a => a -> PersistValue
toPersistValue typ
val)
([(Text, PersistValue)]
fieldsToMaybeCopy, [Text]
updateFieldNames) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {record}.
PersistEntity record =>
HandleUpdateCollision record -> Either (Text, PersistValue) Text
mfieldDef [HandleUpdateCollision record]
fieldValues
fieldDbToText :: FieldDef -> Text
fieldDbToText = FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
entityDef' :: EntityDef
entityDef' = forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef [record]
records
conflictColumns :: [Text]
conflictColumns =
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
escapeF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ UniqueDef -> NonEmpty (FieldNameHS, FieldNameDB)
uniqueFields UniqueDef
uniqDef
firstField :: Text
firstField = case [Text]
entityFieldNames of
[] -> forall a. HasCallStack => [Char] -> a
error [Char]
"The entity you're trying to insert does not have any fields."
(Text
field:[Text]
_) -> Text
field
entityFieldNames :: [Text]
entityFieldNames = forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText (EntityDef -> [FieldDef]
getEntityFields EntityDef
entityDef')
nameOfTable :: Text
nameOfTable = EntityNameDB -> Text
escapeE forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName forall a b. (a -> b) -> a -> b
$ EntityDef
entityDef'
copyUnlessValues :: [PersistValue]
copyUnlessValues = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, PersistValue)]
fieldsToMaybeCopy
recordValues :: [PersistValue]
recordValues = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. PersistEntity record => record -> [PersistValue]
toPersistFields) [record]
records
recordPlaceholders :: Text
recordPlaceholders =
[Text] -> Text
Util.commaSeparated
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Text
"?") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. PersistEntity record => record -> [PersistValue]
toPersistFields)
forall a b. (a -> b) -> a -> b
$ [record]
records
mkCondFieldSet :: Text -> PersistValue -> Text
mkCondFieldSet Text
n PersistValue
_ =
[Text] -> Text
T.concat
[ Text
n
, Text
"=COALESCE("
, Text
"NULLIF("
, Text
"EXCLUDED."
, Text
n
, Text
","
, Text
"?"
, Text
")"
, Text
","
, Text
nameOfTable
, Text
"."
, Text
n
,Text
")"
]
condFieldSets :: [Text]
condFieldSets = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> PersistValue -> Text
mkCondFieldSet) [(Text, PersistValue)]
fieldsToMaybeCopy
fieldSets :: [Text]
fieldSets = forall a b. (a -> b) -> [a] -> [b]
map (\Text
n -> [Text] -> Text
T.concat [Text
n, Text
"=EXCLUDED.", Text
n, Text
""]) [Text]
updateFieldNames
upds :: [Text]
upds = forall a b. (a -> b) -> [a] -> [b]
map (forall record.
PersistEntity record =>
(FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
Util.mkUpdateText' (FieldNameDB -> Text
escapeF) (\Text
n -> [Text] -> Text
T.concat [Text
nameOfTable, Text
".", Text
n])) [Update record]
updates
updsValues :: [PersistValue]
updsValues = forall a b. (a -> b) -> [a] -> [b]
map (\(Update EntityField record typ
_ typ
val PersistUpdate
_) -> forall a. PersistField a => a -> PersistValue
toPersistValue typ
val) [Update record]
updates
(Text
wher, [PersistValue]
whereVals) =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Filter record]
filters
then (Text
"", [])
else (forall val.
PersistEntity val =>
Maybe FilterTablePrefix
-> SqlBackend -> [Filter val] -> (Text, [PersistValue])
filterClauseWithVals (forall a. a -> Maybe a
Just FilterTablePrefix
PrefixTableName) SqlBackend
conn [Filter record]
filters)
updateText :: Text
updateText =
case [Text]
fieldSets forall a. Semigroup a => a -> a -> a
<> [Text]
upds forall a. Semigroup a => a -> a -> a
<> [Text]
condFieldSets of
[] ->
[Text] -> Text
T.concat [Text
firstField, Text
"=", Text
nameOfTable, Text
".", Text
firstField]
[Text]
xs ->
[Text] -> Text
Util.commaSeparated [Text]
xs
q :: Text
q = [Text] -> Text
T.concat
[ Text
"INSERT INTO "
, Text
nameOfTable
, Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ [Text]
entityFieldNames
, Text
" VALUES "
, Text
recordPlaceholders
, Text
" ON CONFLICT "
, Text -> Text
Util.parenWrapped forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ [Text]
conflictColumns
, Text
" DO UPDATE SET "
, Text
updateText
, Text
wher
]
putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text
putManySql' [Text]
conflictColumns (forall a. (a -> Bool) -> [a] -> [a]
filter FieldDef -> Bool
isFieldNotGenerated -> [FieldDef]
fields) EntityDef
ent Int
n = Text
q
where
fieldDbToText :: FieldDef -> Text
fieldDbToText = FieldNameDB -> Text
escapeF 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName forall a b. (a -> b) -> a -> b
$ EntityDef
ent
columns :: Text
columns = [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Text
fieldDbToText [FieldDef]
fields
placeholders :: [Text]
placeholders = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Text
"?") [FieldDef]
fields
updates :: [Text]
updates = forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
mkAssignment 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ [Text]
placeholders
, Text
" ON CONFLICT "
, Text -> Text
Util.parenWrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Util.commaSeparated forall a b. (a -> b) -> a -> b
$ [Text]
conflictColumns
, Text
" DO UPDATE SET "
, [Text] -> Text
Util.commaSeparated [Text]
updates
]
migrateEnableExtension :: Text -> Migration
migrateEnableExtension :: Text -> Migration
migrateEnableExtension Text
extName = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT forall a b. (a -> b) -> a -> b
$ do
[Single Int]
res :: [Single Int] <-
forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
"SELECT COUNT(*) FROM pg_catalog.pg_extension WHERE extname = ?" [Text -> PersistValue
PersistText Text
extName]
if [Single Int]
res forall a. Eq a => a -> a -> Bool
== [forall a. a -> Single a
Single Int
0]
then forall (m :: * -> *) a. Monad m => a -> m a
return (((), []) , [(Bool
False, Text
"CREATe EXTENSION \"" forall a. Semigroup a => a -> a -> a
<> Text
extName forall a. Semigroup a => a -> a -> a
<> Text
"\"")])
else forall (m :: * -> *) a. Monad m => a -> m a
return (((), []), [])
postgresMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
postgresMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef])
postgresMkColumns [EntityDef]
allDefs EntityDef
t =
[EntityDef]
-> EntityDef
-> BackendSpecificOverrides
-> ([Column], [UniqueDef], [ForeignDef])
mkColumns [EntityDef]
allDefs EntityDef
t
forall a b. (a -> b) -> a -> b
$ (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
-> BackendSpecificOverrides -> BackendSpecificOverrides
setBackendSpecificForeignKeyName EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName BackendSpecificOverrides
emptyBackendSpecificOverrides
data RawPostgresql backend = RawPostgresql
{ forall backend. RawPostgresql backend -> backend
persistentBackend :: backend
, forall backend. RawPostgresql backend -> Connection
rawPostgresqlConnection :: PG.Connection
}
instance BackendCompatible (RawPostgresql b) (RawPostgresql b) where
projectBackend :: RawPostgresql b -> RawPostgresql b
projectBackend = forall a. a -> a
id
instance BackendCompatible b (RawPostgresql b) where
projectBackend :: RawPostgresql b -> b
projectBackend = forall backend. RawPostgresql backend -> backend
persistentBackend
withRawConnection
:: (PG.Connection -> SqlBackend)
-> PG.Connection
-> RawPostgresql SqlBackend
withRawConnection :: (Connection -> SqlBackend)
-> Connection -> RawPostgresql SqlBackend
withRawConnection Connection -> SqlBackend
f Connection
conn = RawPostgresql
{ persistentBackend :: SqlBackend
persistentBackend = Connection -> SqlBackend
f Connection
conn
, rawPostgresqlConnection :: Connection
rawPostgresqlConnection = Connection
conn
}
createRawPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m)
=> ConnectionString
-> Int
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPool :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
ConnectionString -> Int -> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPool = forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO ())
-> ConnectionString -> Int -> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModified (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
createRawPostgresqlPoolModified
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModified :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO ())
-> ConnectionString -> Int -> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModified = forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getServerVersion
createRawPostgresqlPoolModifiedWithVersion
:: (MonadUnliftIO m, MonadLoggerIO m)
=> (PG.Connection -> IO (Maybe Double))
-> (PG.Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModifiedWithVersion :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
(Connection -> IO (Maybe Double))
-> (Connection -> IO ())
-> ConnectionString
-> Int
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolModifiedWithVersion Connection -> IO (Maybe Double)
getVerDouble Connection -> IO ()
modConn ConnectionString
ci = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = (Connection -> IO (Maybe Double))
-> Connection -> IO (NonEmpty Word)
oldGetVersionToNew Connection -> IO (Maybe Double)
getVerDouble
forall backend (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> Int -> m (Pool backend)
createSqlPool forall a b. (a -> b) -> a -> b
$ forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer (Connection -> SqlBackend)
-> Connection -> RawPostgresql SqlBackend
withRawConnection ConnectionString
ci
createRawPostgresqlPoolWithConf
:: (MonadUnliftIO m, MonadLoggerIO m)
=> PostgresConf
-> PostgresConfHooks
-> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolWithConf :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
PostgresConf
-> PostgresConfHooks -> m (Pool (RawPostgresql SqlBackend))
createRawPostgresqlPoolWithConf PostgresConf
conf PostgresConfHooks
hooks = do
let getVer :: Connection -> IO (NonEmpty Word)
getVer = PostgresConfHooks -> Connection -> IO (NonEmpty Word)
pgConfHooksGetServerVersion PostgresConfHooks
hooks
modConn :: Connection -> IO ()
modConn = PostgresConfHooks -> Connection -> IO ()
pgConfHooksAfterCreate PostgresConfHooks
hooks
forall (m :: * -> *) backend.
(MonadLoggerIO m, MonadUnliftIO m,
BackendCompatible SqlBackend backend) =>
(LogFunc -> IO backend) -> ConnectionPoolConfig -> m (Pool backend)
createSqlPoolWithConfig (forall backend.
(Connection -> IO ())
-> (Connection -> IO (NonEmpty Word))
-> ((Connection -> SqlBackend) -> Connection -> backend)
-> ConnectionString
-> LogFunc
-> IO backend
open' Connection -> IO ()
modConn Connection -> IO (NonEmpty Word)
getVer (Connection -> SqlBackend)
-> Connection -> RawPostgresql SqlBackend
withRawConnection (PostgresConf -> ConnectionString
pgConnStr PostgresConf
conf)) (PostgresConf -> ConnectionPoolConfig
postgresConfToConnectionPoolConfig PostgresConf
conf)
#if MIN_VERSION_base(4,12,0)
instance (PersistCore b) => PersistCore (RawPostgresql b) where
newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { forall b.
BackendKey (RawPostgresql b)
-> BackendKey (Compatible b (RawPostgresql b))
unRawPostgresqlKey :: BackendKey (Compatible b (RawPostgresql b)) }
makeCompatibleKeyInstances [t| forall b. Compatible b (RawPostgresql b) |]
#else
instance (PersistCore b) => PersistCore (RawPostgresql b) where
newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (RawPostgresql b) }
deriving instance (Show (BackendKey b)) => Show (BackendKey (RawPostgresql b))
deriving instance (Read (BackendKey b)) => Read (BackendKey (RawPostgresql b))
deriving instance (Eq (BackendKey b)) => Eq (BackendKey (RawPostgresql b))
deriving instance (Ord (BackendKey b)) => Ord (BackendKey (RawPostgresql b))
deriving instance (Num (BackendKey b)) => Num (BackendKey (RawPostgresql b))
deriving instance (Integral (BackendKey b)) => Integral (BackendKey (RawPostgresql b))
deriving instance (PersistField (BackendKey b)) => PersistField (BackendKey (RawPostgresql b))
deriving instance (PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (RawPostgresql b))
deriving instance (Real (BackendKey b)) => Real (BackendKey (RawPostgresql b))
deriving instance (Enum (BackendKey b)) => Enum (BackendKey (RawPostgresql b))
deriving instance (Bounded (BackendKey b)) => Bounded (BackendKey (RawPostgresql b))
deriving instance (ToJSON (BackendKey b)) => ToJSON (BackendKey (RawPostgresql b))
deriving instance (FromJSON (BackendKey b)) => FromJSON (BackendKey (RawPostgresql b))
#endif
#if MIN_VERSION_base(4,12,0)
$(pure [])
makeCompatibleInstances [t| forall b. Compatible b (RawPostgresql b) |]
#else
instance HasPersistBackend b => HasPersistBackend (RawPostgresql b) where
type BaseBackend (RawPostgresql b) = BaseBackend b
persistBackend = persistBackend . persistentBackend
instance (PersistStoreRead b) => PersistStoreRead (RawPostgresql b) where
get = withReaderT persistentBackend . get
getMany = withReaderT persistentBackend . getMany
instance (PersistQueryRead b) => PersistQueryRead (RawPostgresql 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 (RawPostgresql b) where
updateWhere filts updates = withReaderT persistentBackend $ updateWhere filts updates
deleteWhere = withReaderT persistentBackend . deleteWhere
instance (PersistUniqueRead b) => PersistUniqueRead (RawPostgresql b) where
getBy = withReaderT persistentBackend . getBy
instance (PersistStoreWrite b) => PersistStoreWrite (RawPostgresql 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 (RawPostgresql 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