Commit 1a292d63 authored by Sophie Herold's avatar Sophie Herold 🌼

Unfinished new diff approach

parent 4b840d51
HS = $(shell find app/ src/ test/ -name '*.hs')
VERSION = 0.9.90.0
HPCDIRS = --hpcdir dist/hpc/vanilla/mix/hamsql --hpcdir dist/hpc/vanilla/mix/hamsql-${VERSION}
.PHONY: test $(HS)
......@@ -13,6 +11,10 @@ update:
cabal install -ffast --only-dependencies --disable-optimization
test:
cabal configure --disable-optimization --enable-tests
cabal test --show-details=direct --test-option=--color=always
test-coverage:
cabal configure --disable-optimization --enable-coverage --enable-tests
cabal test --show-details=direct --test-option=--color=always
......
......@@ -9,6 +9,7 @@ module Database.HamSql.Cli
) where
import Control.Monad (when)
import Control.Monad.Trans.Reader (runReaderT)
import Data.List
import Data.Maybe
import qualified Data.Text as T
......@@ -22,7 +23,9 @@ import System.Environment (getArgs)
import Paths_hamsql (version)
import Database.HamSql
import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.Stmt.Database
import Database.HamSql.Setup
import Database.YamSql
parserPrefs :: ParserPrefs
......@@ -35,6 +38,17 @@ parseThisArgv :: [String] -> IO Command
parseThisArgv xs =
handleParseResult $ execParserPure parserPrefs parserInfoHamsql xs
newSetup' :: [Schema] -> Setup
newSetup' s =
Setup
{ setupSchemas = []
, setupSchemaDirs = Nothing
, setupRolePrefix = Just "hamsql-test_"
, setupPreCode = Nothing
, setupPostCode = Nothing
, setupSchemaData = Just s
}
run :: Command -> IO ()
-- Install
run (Install optCommon optDb optInstall)
......@@ -44,7 +58,6 @@ run (Install optCommon optDb optInstall)
"must be supplied or non of them."
| otherwise = do
setup <- loadSetup (optSetup optCommon)
let stmts = pgsqlGetFullStatements setup
let dbname = SqlName $ T.pack $ tail $ uriPath $ getConUrl optDb
if not (optEmulate optDb || optPrint optDb)
then close =<<
......@@ -60,17 +73,24 @@ run (Install optCommon optDb optInstall)
"database exists for those commands to make sense."
dropRoleStmts <-
if optDeleteResidualRoles optInstall
then pgsqlDropAllRoleStmts optDb setup
then return [] --TODO: pgsqlDropAllRoleStmts optDb setup
else return []
useSqlStmts optCommon optDb $ sort $ stmts ++ dropRoleStmts
useSqlStmts optCommon optDb $ sort $ (stmtsInstall setup) ++ dropRoleStmts
-- Upgrade
run (Upgrade optCommon optDb) = do
setup <- loadSetup (optSetup optCommon)
sourceSetup <- loadSetup (optSetup optCommon)
conn <- pgsqlConnectUrl (getConUrl optDb)
deleteStmts <- pgsqlDeleteAllStmt conn
let createStmts = pgsqlGetFullStatements setup
fragile <- pgsqlUpdateFragile setup conn createStmts
let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
targetModules <- runReaderT deployedSchemas conn
let sourceStmts = stmtsInstall sourceSetup
let targetStmts = stmtsInstall $ newSetup' targetModules
let stmts =
sort $
(sourceStmts \\ targetStmts) ++
stmtsUpdateDrop (targetStmts \\ sourceStmts)
--deleteStmts <- pgsqlDeleteAllStmt conn
--fragile <- pgsqlUpdateFragile setup conn (stmtsInstall setup)
--let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
print $ stmts
useSqlStmts optCommon optDb stmts
-- Doc
run (Doc optCommon optDoc) = do
......
......@@ -65,7 +65,6 @@ deployedSchemas = do
FROM pg_catalog.pg_namespace
WHERE nspname <> 'information_schema' AND nspname NOT LIKE 'pg\_%'
-- TODO: do public right
AND nspname <> 'public'
|]
deployedTables :: SqlName -> SqlT [Table]
......@@ -417,8 +416,9 @@ deployedSequences schema = do
seqs <- psqlQry qry1 (Only $ toSqlCode schema)
(map toSequence . head) . sequence <$> mapM doQry2 seqs
where
doQry2 (n, desc) = psqlQry (qry2 (n :: Text)) (Only (desc :: Maybe Text))
toSequence (seqname, seqstartvalue, seqincrementby, seqmaxvalue, seqminvalue, seqcachevalue, seqiscycled, seqdesc) =
doQry2 (n, desc, ownedby) =
psqlQry (qry2 (n :: Text)) (desc :: Maybe Text, ownedby :: Maybe Text)
toSequence (seqname, seqstartvalue, seqincrementby, seqmaxvalue, seqminvalue, seqcachevalue, seqiscycled, seqdesc, ownedby) =
Sequence
{ sequenceName = seqname
, sequenceDescription = fromMaybe "" seqdesc
......@@ -428,13 +428,23 @@ deployedSequences schema = do
, sequenceStartValue = preset 1 seqstartvalue
, sequenceCache = preset 1 seqcachevalue
, sequenceCycle = preset False seqiscycled
, sequenceOwnedByColumn = Nothing
, sequenceOwnedByColumn = ownedby
}
qry1 =
[sql|
SELECT
oid::regclass::text,
pg_catalog.obj_description(oid, 'pg_class')::text AS seqdesc
pg_catalog.obj_description(oid, 'pg_class')::text AS seqdesc,
(
SELECT d.refobjid::regclass::text || '."' || a.attname || '"'
FROM pg_depend d
JOIN pg_catalog.pg_attribute a
ON a.attrelid = d.refobjid AND a.attnum = d.refobjsubid
WHERE
d.classid = 'pg_class'::regclass
AND d.objid = pg_class.oid
)
AS ownedby
FROM pg_class
WHERE
relkind = 'S'
......@@ -443,7 +453,7 @@ deployedSequences schema = do
qry2 n =
toQry $
"SELECT sequence_name, start_value, increment_by, max_value," <\>
"min_value, cache_value, is_cycled::bool, ?::text AS desc FROM " <>
"min_value, cache_value, is_cycled::bool, ?::text AS desc, ?::text AS ownedby FROM " <>
n
deployedTypes :: SqlName -> SqlT [Type]
......@@ -476,149 +486,3 @@ deployedTypes schema = do
WHERE c.oid = typrelid)
AND typnamespace = ?::regnamespace::oid
|]
sqlManageSchemaJoin :: Text -> Text
sqlManageSchemaJoin schemaid =
" JOIN pg_namespace AS n " <\> " ON" <-> schemaid <-> "= n.oid AND " <\>
" NOT n.nspname LIKE 'pg_%' AND " <\>
" n.nspname NOT IN ('information_schema') "
deployedTableConstrIds ::
Connection -> IO [SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)]
deployedTableConstrIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (schema, table, constraint) =
SqlObj SQL_TABLE_CONSTRAINT (schema, table, constraint)
qry =
toQry $
"SELECT n.nspname, t.relname, c.conname" <\> "FROM pg_constraint AS c" <\>
"JOIN pg_class AS t" <\>
" ON c.conrelid = t.oid" <->
sqlManageSchemaJoin "c.connamespace"
deployedDomainConstrIds ::
Connection -> IO [SqlObj SQL_DOMAIN_CONSTRAINT (SqlName, SqlName)]
deployedDomainConstrIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (schema, table, constraint) =
SqlObj SQL_DOMAIN_CONSTRAINT (schema <.> table, constraint)
qry =
toQry $
"SELECT n.nspname, d.typname, c.conname" <\> "FROM pg_constraint AS c " <\>
"JOIN pg_type AS d " <\>
" ON c.contypid = d.oid" <->
sqlManageSchemaJoin "c.connamespace"
-- | List SCHEMA
deployedSchemaIds :: Connection -> IO [SqlObj SQL_SCHEMA SqlName]
deployedSchemaIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (Only s) = SqlObj SQL_SCHEMA s
qry =
toQry $
"SELECT s.nspname FROM pg_namespace AS s" <\> sqlManageSchemaJoin "s.oid"
-- | List SEQUENCE
deployedSequenceIds :: Connection -> IO [SqlObj SQL_SEQUENCE SqlName]
deployedSequenceIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (s, t) = SqlObj SQL_SEQUENCE (s <.> t)
qry =
toQry $
"SELECT sequence_schema, sequence_name" <\>
"FROM information_schema.sequences"
-- | List TABLE
deployedTableIds :: Connection -> IO [SqlObj SQL_TABLE SqlName]
deployedTableIds conn = do
dat <-
query_ conn $
toQry $
"SELECT table_schema, table_name" <\> "FROM information_schema.tables" <\>
"WHERE table_type = 'BASE TABLE'" <\>
" AND table_schema NOT IN ('information_schema', 'pg_catalog')"
return $ map toSqlCodeId dat
where
toSqlCodeId (s, t) = SqlObj SQL_TABLE (s <.> t)
-- | List TABLE COLUMN
deployedTableColumnIds ::
Connection -> IO [SqlObj SQL_COLUMN (SqlName, SqlName)]
deployedTableColumnIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (s, t, u) = SqlObj SQL_COLUMN (s <.> t, u)
qry =
toQry $
"SELECT table_schema, table_name, column_name" <\>
" FROM information_schema.columns" <\>
--" WHERE table_type = 'BASE TABLE'" ++
" WHERE table_schema NOT IN ('information_schema', 'pg_catalog')"
-- | List TYPE
deployedTypeIds :: Connection -> IO [SqlObj SQL_TYPE SqlName]
deployedTypeIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (s, t) = SqlObj SQL_TYPE (s <.> t)
qry =
toQry $
"SELECT user_defined_type_schema, user_defined_type_name" <\>
" FROM information_schema.user_defined_types" <\>
" WHERE user_defined_type_schema NOT IN ('information_schema', 'pg_catalog')"
-- | List ROLE
deployedRoleIds :: Setup -> Connection -> IO [SqlObj SQL_ROLE SqlName]
deployedRoleIds setup conn =
map toSqlCodeId <$> query conn qry (Only $ prefix <> "%")
where
qry = "SELECT rolname FROM pg_roles WHERE rolname LIKE ?"
prefix = setupRolePrefix' setup
unprefixed =
fromJustReason "Retrived role without prefix from database" .
stripPrefix prefix
toSqlCodeId (Only role) = SqlObj SQL_ROLE (SqlName $ unprefixed role)
deployedRoleMemberIds ::
Setup -> Connection -> IO [SqlObj SQL_ROLE_MEMBERSHIP (SqlName, SqlName)]
deployedRoleMemberIds setup conn =
map toSqlCodeId <$> query conn qry (prefix <> "%", prefix <> "%")
where
prefix = setupRolePrefix' setup
unprefixed =
fromJustReason "Retrived role without prefix from database" .
stripPrefix prefix
toSqlCodeId (role, member) =
SqlObj
SQL_ROLE_MEMBERSHIP
(SqlName $ unprefixed role, SqlName $ unprefixed member)
qry =
toQry $
"SELECT a.rolname, b.rolname FROM pg_catalog.pg_auth_members AS m" <\>
" INNER JOIN pg_catalog.pg_roles AS a ON a.oid=m.roleid" <\>
" INNER JOIN pg_catalog.pg_roles AS b ON b.oid=m.member" <\>
"WHERE a.rolname LIKE ? AND b.rolname LIKE ?"
-- | List DOMAIN
deployedDomainIds :: Connection -> IO [SqlObj SQL_DOMAIN SqlName]
deployedDomainIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (schema, domain) = SqlObj SQL_DOMAIN $ schema <.> domain
qry =
toQry $
"SELECT domain_schema, domain_name" <\> " FROM information_schema.domains" <\>
" WHERE domain_schema NOT IN ('information_schema', 'pg_catalog')"
deployedFunctionIds ::
Connection -> IO [SqlObj SQL_FUNCTION (SqlName, [SqlType])]
deployedFunctionIds conn = map toSqlCodeId <$> query_ conn qry
where
toSqlCodeId (schema, function, args) =
SqlObj SQL_FUNCTION (schema <.> function, fromPGArray args)
qry =
toQry $
"SELECT n.nspname, p.proname, " <>
-- This part of the query includes a workaround for
-- <https://github.com/lpsmith/postgresql-simple/issues/166>
"ARRAY(SELECT UNNEST(p.proargtypes::regtype[]::varchar[]))" <\>
"FROM pg_proc AS p" <->
sqlManageSchemaJoin "p.pronamespace" <\>
"WHERE p.probin IS NULL"
......@@ -65,28 +65,39 @@ CREATE only defines name on demand.
Properties all via ALTER SEQUENCE.
-}
module Database.HamSql.Internal.PostgresCon where
module Database.HamSql.Internal.PostgresCon
( stmtsInstall
, pgsqlExecWithoutTransact
, pgsqlExec
, stmtsUpdateDrop
) where
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.Function
--import Data.Function
import Data.Maybe
import Data.Set (fromList, notMember)
--import Data.Set (fromList, notMember)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Transaction
import Network.URI (URI)
import Database.HamSql.Internal.DbUtils
import Database.HamSql.Internal.InquireDeployed
--import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.Option
import Database.HamSql.Internal.Stmt
import Database.HamSql.Internal.Stmt.Create
import Database.HamSql.Internal.Stmt.Domain
import Database.HamSql.Internal.Stmt.Function
import Database.HamSql.Internal.Stmt.Role
import Database.HamSql.Internal.Stmt.Schema
--import Database.HamSql.Internal.Stmt.Role
import Database.HamSql.Internal.Stmt.Sequence
import Database.HamSql.Internal.Stmt.Table
import Database.HamSql.Internal.Stmt.Trigger
import Database.HamSql.Internal.Stmt.Type
import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
......@@ -95,51 +106,36 @@ import Database.YamSql
sqlErrInvalidFunctionDefinition :: B.ByteString
sqlErrInvalidFunctionDefinition = "42P13"
pgsqlGetFullStatements :: Setup -> [SqlStmt]
pgsqlGetFullStatements setup = catMaybes $ getSetupStatements setup
pgsqlDeleteAllStmt :: Connection -> IO [SqlStmt]
pgsqlDeleteAllStmt conn = do
domainConstrs <- deployedDomainConstrIds conn
tableConstrs <- deployedTableConstrIds conn
return $
catMaybes $
concatMap stmtsDropDomainConstr domainConstrs ++
concatMap stmtsDropTableConstr tableConstrs
pgsqlUpdateFragile :: Setup -> Connection -> [SqlStmt] -> IO [SqlStmt]
pgsqlUpdateFragile setup conn stmts =
stmts & correctStmts SqlAddColumn deployedTableColumnIds stmtsDropTableColumn >>=
correctStmts SqlCreateDomain deployedDomainIds stmtsDropDomain >>=
correctStmts SqlCreateRole (deployedRoleIds setup) (stmtsDropRole setup) >>=
correctStmts SqlCreateSequence deployedSequenceIds stmtsDropSequence >>=
correctStmts SqlCreateTable deployedTableIds stmtsDropTable >>=
correctStmts SqlCreateType deployedTypeIds stmtsDropType >>=
correctStmts
SqlGrantMembership
(deployedRoleMemberIds setup)
(stmtRevokeMembership setup) >>=
dropResidual SqlCreateFunction deployedFunctionIds stmtsDropFunction >>=
revokeAllPrivileges conn setup (deployedRoleIds setup conn)
where
correctStmts ::
ToSqlId a
=> SqlStmtType
-> (Connection -> IO [a])
-> (a -> [Maybe SqlStmt]) -- ^ drop statement generator
-> [SqlStmt]
-> IO [SqlStmt]
correctStmts createType existingInquire =
correctStatements createType (existingInquire conn)
dropResidual ::
ToSqlId a
=> SqlStmtType
-> (Connection -> IO [a])
-> (a -> [Maybe SqlStmt])
-> [SqlStmt]
-> IO [SqlStmt]
dropResidual t isf = addDropResidual t (isf conn)
sqlErrUndefinedTable :: B.ByteString
sqlErrUndefinedTable = "42P01"
stmtsInstall :: Setup -> [SqlStmt]
stmtsInstall setup = catMaybes $ getSetupStatements setup
stmtsUpdateDrop :: [SqlStmt] -> [SqlStmt]
stmtsUpdateDrop = catMaybes . concatMap dropStmt
dropStmt :: SqlStmt -> [Maybe SqlStmt]
dropStmt (SqlStmt (SqlStmtId t i) _) =
let n = SqlName $ toSqlCode i
s = expSqlName n
ncol = ((s !! 0) <.> (s !! 1), s !! 2)
in case t of
SqlAddColumn -> stmtsDropTableColumn (SqlObj SQL_COLUMN ncol)
SqlCreateDomain -> stmtsDropDomain (SqlObj SQL_DOMAIN n)
SqlCreateSequence -> stmtsDropSequence (SqlObj SQL_SEQUENCE n)
SqlCreateTable -> stmtsDropTable (SqlObj SQL_TABLE n)
SqlCreateType -> stmtsDropType (SqlObj SQL_TYPE n)
SqlCreateFunction -> return <$> stmtsDropFunction' i
SqlCreateTrigger -> stmtsDropTrigger (SqlObj SQL_TRIGGER ncol)
SqlCreateTableCheckConstr ->
stmtsDropTableConstr (SqlObj SQL_TABLE_CONSTRAINT ncol)
SqlCreateForeignKeyConstr ->
stmtsDropTableConstr (SqlObj SQL_TABLE_CONSTRAINT ncol)
SqlDropSchema -> stmtsDropSchema (SqlObj SQL_SCHEMA n)
_ -> []
{-
revokeAllPrivileges ::
Connection
-> Setup
......@@ -159,7 +155,7 @@ pgsqlDropAllRoleStmts optDb setup = do
(deployedRoleIds setup conn)
(stmtsDropRole setup)
[]
-}
-- DB Utils
pgsqlExecWithoutTransact :: OptCommonDb -> URI -> [SqlStmt] -> IO Connection
pgsqlExecWithoutTransact opt = pgsqlExecIntern opt PgSqlWithoutTransaction
......@@ -167,11 +163,6 @@ pgsqlExecWithoutTransact opt = pgsqlExecIntern opt PgSqlWithoutTransaction
pgsqlExec :: OptCommonDb -> URI -> [SqlStmt] -> IO Connection
pgsqlExec opt = pgsqlExecIntern opt PgSqlWithTransaction
pgsqlExecAndRollback :: OptCommonDb -> URI -> [SqlStmt] -> IO ()
pgsqlExecAndRollback opt url stmts = do
conn <- pgsqlExecIntern opt PgSqlWithTransaction url stmts
rollback conn
pgsqlExecStmtList ::
OptCommonDb
-> Status
......@@ -182,7 +173,9 @@ pgsqlExecStmtList ::
pgsqlExecStmtList _ Init _ (x:_) _ =
err $ "supplied failed statements to (pgsqlExecStmtList _ Init): " <> tshow x
-- No remaining statements to execute
pgsqlExecStmtList _ _ [] [] conn = commit conn
pgsqlExecStmtList dbOpt _ [] [] conn
| optEmulate dbOpt = rollback conn
| otherwise = commit conn
pgsqlExecStmtList _ Unchanged [] failed conn =
pgsqlExecStmtHandled conn (head failed)
pgsqlExecStmtList opt Changed [] failed conn =
......@@ -205,6 +198,8 @@ pgsqlExecStmtList opt status (x:xs) failed conn = do
handleSqlError savepoint SqlError {sqlState = errCode}
| errCode == sqlErrInvalidFunctionDefinition =
skipQuery savepoint (stmtsDropFunction' (sqlId x) ++ [x])
-- SEQENCEs might be gone allready
| errCode == sqlErrUndefinedTable = skipQuery savepoint []
| otherwise = skipQuery savepoint [x]
handleQueryError savepoint QueryError {} = proceed savepoint
-- action after execution has failed
......@@ -230,55 +225,3 @@ pgsqlExecIntern opt mode connUrl xs = do
pgsqlExecStmtList opt Init xs [] conn
when (mode == PgSqlWithoutTransaction) $ mapM_ (pgsqlExecStmtHandled conn) xs
return conn
addSqlStmtType ::
ToSqlId a
=> SqlStmtType -- ^ statment
-> [a] -- ^ SQL ids that should become a "SqlStmtId" type to use
-> [SqlStmtId]
addSqlStmtType t = map (SqlStmtId t . sqlId)
filterSqlStmtType :: SqlStmtType -> [SqlStmt] -> [SqlStmt]
filterSqlStmtType t xs = [x | x <- xs, stmtIdType x == t]
filterStmtsMatchingIds ::
[SqlStmtId] -- ^ Statement ids to remove
-> [SqlStmt]
-> [SqlStmt]
filterStmtsMatchingIds ids = filter (\x -> stmtId x `notMember` ids')
where
ids' = fromList ids
filterSqlIdBySqlStmts ::
ToSqlId a
=> SqlStmtType -- ^ stmts to be considered by stmt type
-> [SqlStmt] -- ^ stmts that have the forbidden ids
-> [a] -- elements that get filtered
-> [a]
filterSqlIdBySqlStmts t xs = filter (\x -> sqlId x `notMember` ids)
where
ids = fromList . map sqlId $ filterSqlStmtType t xs
-- target set of sql ids
correctStatements ::
ToSqlId a
=> SqlStmtType -- ^ install statements and the stmt type of interest
-> IO [a] -- ^ deployed (existing) elements
-> (a -> [Maybe SqlStmt]) -- ^ drop statment generator
-> [SqlStmt] -- ^ install statements, representing desired state
-> IO [SqlStmt]
correctStatements t iois f xs = do
is <- iois
xs' <- addDropResidual t iois f xs
return $ filterStmtsMatchingIds (addSqlStmtType t is) xs'
addDropResidual ::
ToSqlId a
=> SqlStmtType
-> IO [a]
-> (a -> [Maybe SqlStmt])
-> [SqlStmt]
-> IO [SqlStmt]
addDropResidual t iois f xs = do
is <- iois
return $ xs ++ catMaybes (concatMap f (filterSqlIdBySqlStmts t xs is))
......@@ -23,7 +23,7 @@ instance Show SqlStmtId where
data SqlStmt =
SqlStmt SqlStmtId
Text
deriving (Show)
deriving (Show, Eq, Ord)
stmtId :: SqlStmt -> SqlStmtId
stmtId (SqlStmt x _) = x
......@@ -37,12 +37,10 @@ stmtIdType (SqlStmt x _) = stmtType x
stmtDesc :: SqlStmt -> Text
stmtDesc stmt = sqlIdShowType (sqlId stmt) <-> sqlIdCode stmt
instance Eq SqlStmt where
x == y = stmtId x == stmtId y
instance Ord SqlStmt where
x `compare` y = stmtId x `compare` stmtId y
--instance Eq SqlStmt where
-- x == y = stmtId x == stmtId y
--instance Ord SqlStmt where
-- x `compare` y = stmtId x `compare` stmtId y
instance ToSqlId SqlStmt where
sqlId = stmtSqlId . stmtId
......@@ -95,6 +93,7 @@ data SqlStmtType
| SqlDropTableConstr
| SqlDropDomainConstr
| SqlDropSequence
| SqlDropTrigger
-- DROP FUNCTION
| SqlDropTableColumn
| SqlDropTable
......@@ -115,6 +114,7 @@ data SqlStmtType
-- FUNCTION
| SqlDropDomain
| SqlDropType
| SqlDropSchema
| SqlCreateFunction
| SqlInherit
| SqlAddTableConstr
......@@ -122,6 +122,7 @@ data SqlStmtType
| SqlCreateUniqueConstr
| SqlCreateForeignKeyConstr
| SqlCreateCheckConstr
| SqlCreateTableCheckConstr
| SqlDomainSetDefault
-- TRIGGER
| SqlCreateTrigger
......
......@@ -5,6 +5,7 @@
module Database.HamSql.Internal.Stmt.Database where
import Database.HamSql.Internal.Stmt.Basic
import Database.HamSql.Internal.Stmt.Schema
data SQL_DATABASE =
SQL_DATABASE
......
......@@ -8,6 +8,9 @@ module Database.HamSql.Internal.Stmt.Schema where
import Database.HamSql.Internal.Stmt.Basic
stmtsDropSchema :: SqlObj SQL_SCHEMA SqlName -> [Maybe SqlStmt]
stmtsDropSchema x = [newSqlStmt SqlDropSchema x $ "DROP SCHEMA" <-> toSqlCode x]
instance ToSqlStmts (SqlContext Schema) where
toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext s) =
[ newSqlStmt SqlCreateSchema obj $
......
......@@ -18,11 +18,10 @@ import Database.HamSql.Internal.Stmt.Sequence ()
-- | Assuming that CASCADE will only cause other constraints to be deleted.
-- | Required since foreign keys may depend on other keys.
stmtsDropTableConstr ::
SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName) -> [Maybe SqlStmt]
stmtsDropTableConstr x@(SqlObj _ (s, t, c)) =
SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName) -> [Maybe SqlStmt]
stmtsDropTableConstr x@(SqlObj _ (tbl, c)) =
[ newSqlStmt SqlDropTableConstr x $
"ALTER TABLE" <-> toSqlCode (s <.> t) <-> "DROP CONSTRAINT IF EXISTS" <->
toSqlCode c <->
"ALTER TABLE" <-> toSqlCode tbl <-> "DROP CONSTRAINT" <-> toSqlCode c <->
"CASCADE"
]
......@@ -39,24 +38,27 @@ constrId ::
Schema
-> Table
-> SqlName
-> SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName, SqlName)
constrId s t c = SqlObj SQL_TABLE_CONSTRAINT (schemaName s, tableName t, c)
-> SqlObj SQL_TABLE_CONSTRAINT (SqlName, SqlName)
constrId s t c = SqlObj SQL_TABLE_CONSTRAINT (schemaName s <.> tableName t, c)
-- TODO: prefix with table name
stmtCheck :: ToSqlId a => a -> Check -> [Maybe SqlStmt]
stmtCheck obj c =
[ newSqlStmt SqlCreateCheckConstr obj $
"ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>
toSqlCode (checkName c) <>
" CHECK (" <>
checkCheck c <>
")"
, newSqlStmt SqlComment obj $
"COMMENT ON CONSTRAINT" <-> toSqlCode (checkName c) <-> "ON" <->
sqlIdCode obj <->
"IS" <->
toSqlCodeString (checkDescription c)
]
stmtCheck :: (Schema, Table) -> Check -> [Maybe SqlStmt]
stmtCheck (s, t) c =
let x =
SqlObj SQL_TABLE_CONSTRAINT (schemaName s <.> tableName t, checkName c)
obj = (schemaName s, tableName t)
in [ newSqlStmt SqlCreateTableCheckConstr x $
"ALTER TABLE " <> toSqlCode obj <> " ADD CONSTRAINT " <>
toSqlCode (checkName c) <>
" CHECK (" <>
checkCheck c <>
")"
, newSqlStmt SqlComment x $
"COMMENT ON CONSTRAINT" <-> toSqlCode (checkName c) <-> "ON" <->
toSqlCode obj <->
"IS" <->
toSqlCodeString (checkDescription c)
]
instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
toSqlStmts context obj@(SqlContext (schema, table, rawColumn)) =
......@@ -104,7 +106,8 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
sqlDefault d =
stmtAlterColumn SqlColumnSetDefault $ "SET DEFAULT " <> d
-- [CHECK]
stmtsAddColumnCheck = concat $ maybeMap (stmtCheck tbl) (columnChecks c)
stmtsAddColumnCheck =
concat $ maybeMap (stmtCheck (schema, table)) (columnChecks c)
-- FOREIGN KEY
stmtAddForeignKey =
case columnReferences c of
......@@ -150,7 +153,8 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
{ columnType = SqlType sType
, columnDefault =
Just $
"nextval('" <> toSqlCode (sqlId serialSequenceContext) <> "')"
"nextval('" <> toSqlCode (sqlId serialSequenceContext) <>
"'::regclass)"
}
Nothing -> rawColumn
tblId = sqlIdCode tbl
......@@ -184,7 +188,7 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
-- table comment
, stmtCommentOn obj (tableDescription t)
] ++
concat (maybeMap (stmtCheck obj) (tableChecks t)) ++