Commit a9a0beb7 authored by Sophie Herold's avatar Sophie Herold 🌼

First working self test via schema inquire

parent 168701a9
Pipeline #792 passed with stage
in 4 minutes and 8 seconds
......@@ -134,6 +134,8 @@ test-suite hamsql-tests
safe-exceptions,
postgresql-simple,
transformers,
yaml,
bytestring,
-- test
tasty,
tasty-hunit,
......
......@@ -14,19 +14,62 @@ import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
import Database.YamSql
deployedSchemas :: SqlT [Schema]
deployedSchemas = do
schemas <- psqlQry_ qry
sequence $ map toSchema schemas
where
toSchema (schema, description) = do
tables <- deployedTables schema
return $
Schema
{ schemaName = schema
, schemaDescription = description
, schemaDependencies = Nothing
, schemaFunctions = Nothing
, schemaFunctionTemplates = Nothing
, schemaTables = Just tables
, schemaTableTemplates = Nothing
, schemaRoles = Nothing
, schemaSequences = Nothing
, schemaPrivUsage = Nothing
, schemaPrivSelectAll = Nothing
, schemaPrivInsertAll = Nothing
, schemaPrivUpdateAll = Nothing
, schemaPrivDeleteAll = Nothing
, schemaPrivSequenceAll = Nothing
, schemaPrivExecuteAll = Nothing
, schemaPrivAllAll = Nothing
, schemaDomains = Nothing
, schemaTypes = Nothing
, schemaExecPostInstall = Nothing
, schemaExecPostInstallAndUpgrade = Nothing
}
qry =
[sql|
SELECT
nspname,
COALESCE(pg_catalog.obj_description(oid, 'pg_namespace'), '')
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]
deployedTables schema = do
tbls <- psqlQry qry (Only $ toSqlCode schema)
sequence $ map toTable tbls
where
toTable (table, pname) = do
toTable (table, description) = do
columns <- deployedColumns (schema, table)
pk <- deployedPrimaryKey (schema, table)
return $
Table
{ tableName = table
, tableDescription = "x"
, tableDescription = description
, tableColumns = columns
, tablePrimaryKey = [pname]
, tablePrimaryKey = pk
, tableUnique = Nothing
, tableForeignKeys = Nothing
, tableChecks = Nothing
......@@ -39,21 +82,24 @@ deployedTables schema = do
}
qry =
[sql|
SELECT table_name, table_name
SELECT
table_name,
COALESCE(pg_catalog.obj_description(
(table_schema || '.' || table_name)::regclass, 'pg_class'), '')
FROM information_schema.tables
WHERE table_schema::regnamespace = ?::regnamespace
WHERE table_schema::regnamespace = ?::regnamespace
|]
deployedColumns :: (SqlName, SqlName) -> SqlT [Column]
deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
where
toColumn (sname, dataType, columnDefault') =
toColumn (sname, dataType, columnDefault', isNullable, description) =
Column
{ columnName = sname
, columnType = dataType
, columnDescription = "x"
, columnDescription = description
, columnDefault = columnDefault'
, columnNull = Nothing
, columnNull = isNullable
, columnReferences = Nothing
, columnOnRefDelete = Nothing
, columnOnRefUpdate = Nothing
......@@ -65,11 +111,48 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
SELECT
column_name,
COALESCE(domain_schema || '.' || domain_name, data_type),
column_default
column_default,
is_nullable::bool,
COALESCE(pg_catalog.col_description(a.attrelid, a.attnum), '')
FROM information_schema.columns
WHERE (table_schema || '.' || table_name)::regclass = ?::regclass
JOIN pg_catalog.pg_attribute AS a
ON a.attrelid = (table_schema || '.' || table_name)::regclass
AND a.attname = column_name
WHERE (table_schema || '.' || table_name)::regclass = ?::regclass
|]
deployedPrimaryKey :: (SqlName, SqlName) -> SqlT [SqlName]
deployedPrimaryKey tbl = do
res <- psqlQry keyQuery (Only $ toSqlCode tbl)
return $
case res of
[] -> []
(x:_) -> toPrimaryKey x
where
toPrimaryKey :: (SqlName, PGArray SqlName) -> [SqlName]
-- TODO: do not ignore name
toPrimaryKey (_, keys) = fromPGArray keys
-- (tbl)
keyQuery :: Query
keyQuery =
[sql|
SELECT
irel.relname AS index_name,
array_agg (a.attname ORDER BY c.ordinality) AS columns
FROM pg_index AS i
JOIN pg_class AS trel ON trel.oid = i.indrelid
JOIN pg_namespace AS tnsp ON trel.relnamespace = tnsp.oid
JOIN pg_class AS irel ON irel.oid = i.indexrelid
CROSS JOIN LATERAL unnest (i.indkey) WITH ORDINALITY AS c (colnum, ordinality)
JOIN pg_attribute AS a
ON trel.oid = a.attrelid AND a.attnum = c.colnum
WHERE
(tnsp.nspname || '.' || trel.relname)::regclass = ?::regclass
AND i.indisprimary
GROUP BY tnsp.nspname, trel.relname, irel.relname;
|]
sqlManageSchemaJoin :: Text -> Text
sqlManageSchemaJoin schemaid =
" JOIN pg_namespace AS n " <\> " ON" <-> schemaid <-> "= n.oid AND " <\>
......
......@@ -95,9 +95,8 @@ import Database.YamSql
sqlErrInvalidFunctionDefinition :: B.ByteString
sqlErrInvalidFunctionDefinition = "42P13"
pgsqlGetFullStatements :: OptCommon -> Setup -> IO [SqlStmt]
pgsqlGetFullStatements optCom setup =
return $ catMaybes $ getSetupStatements optCom setup
pgsqlGetFullStatements :: Setup -> IO [SqlStmt]
pgsqlGetFullStatements setup = return $ catMaybes $ getSetupStatements setup
pgsqlDeleteAllStmt :: Connection -> IO [SqlStmt]
pgsqlDeleteAllStmt conn = do
......
......@@ -56,16 +56,15 @@ sqlAddTransact xs =
xs ++ catMaybes [newSqlStmt SqlUnclassified emptyName "COMMIT"]
-- | Setup
getSetupStatements :: OptCommon -> Setup -> [Maybe SqlStmt]
getSetupStatements opts s =
debug opts "stmtInstallSetup" $
getSetupStatements :: Setup -> [Maybe SqlStmt]
getSetupStatements s =
[getStmt $ setupPreCode s] ++ schemaStatements ++ [getStmt $ setupPostCode s]
where
schemaStatements =
concat $ maybeMap (getSchemaStatements opts s) (setupSchemaData s)
concat $ maybeMap (getSchemaStatements s) (setupSchemaData s)
getStmt (Just code) = newSqlStmt SqlPre emptyName code
getStmt Nothing = Nothing
getSchemaStatements :: OptCommon -> Setup -> Schema -> [Maybe SqlStmt]
getSchemaStatements _ setup s =
getSchemaStatements :: Setup -> Schema -> [Maybe SqlStmt]
getSchemaStatements setup s =
elementsToStmts (SetupContext setup) $ allSchemaElements s
......@@ -2,7 +2,9 @@ module Main where
import Control.Exception.Safe
import Control.Monad.Trans.Reader (runReaderT)
import Database.PostgreSQL.Simple
import qualified Data.ByteString as B
import Data.Yaml.Pretty
import Database.PostgreSQL.Simple (Connection)
import System.Exit
--import System.Directory
......@@ -12,15 +14,65 @@ import Test.Tasty.HUnit
import Database.HamSql.Cli
import Database.HamSql.Internal.DbUtils
import Database.HamSql.Internal.InquireDeployed
import Database.HamSql.Internal.Load (loadSetup)
import Database.HamSql.Internal.PostgresCon
import Database.HamSql.Setup
import Database.YamSql
import Database.YamSql.Internal.SqlId (SqlName(..))
main :: IO ()
main = defaultMain tests
conn :: IO Connection
conn =
pgsqlConnectUrl $
getConUrlApp "hamsql-test" "postgresql://postgres@/carnivora"
pgsqlConnectUrl $ getConUrlApp "hamsql-test" "postgresql://postgres@/test1"
deploySetup s =
exec'
[ "install"
, "--permit-data-deletion"
, "-ds"
, "test/setups/" ++ s
, "-c"
, "postgresql://postgres@/test1"
]
xx :: TestTree
xx =
testCase "tables" $ do
deploySetup "self-test.yml"
schemas <- conn >>= runReaderT deployedSchemas
--B.putStrLn $ encodePretty defConfig (newSetup schemas)
stmtsYamSql <-
pgsqlGetFullStatements =<< (loadSetup "test/setups/self-test.yml")
stmtsDb <- pgsqlGetFullStatements (newSetup schemas)
print (show stmtsYamSql)
print (show stmtsDb)
firstListDiff stmtsDb stmtsYamSql @?= Nothing
firstListDiff
:: Eq a
=> [a] -> [a] -> Maybe (Maybe a, Maybe a)
firstListDiff [] [] = Nothing
firstListDiff [] (y:_) = Just (Nothing, Just y)
firstListDiff (x:_) [] = Just (Just x, Nothing)
firstListDiff (x:xs) (y:ys)
| x == y = firstListDiff xs ys
| otherwise = Just (Just x, Just y)
newSetup :: [Schema] -> Setup
newSetup s =
Setup
{ setupSchemas = []
, setupSchemaDirs = Nothing
, setupRolePrefix = Just "hamsql-test_"
, setupPreCode = Nothing
, setupPostCode = Nothing
, setupSchemaData = Just s
}
---------------------
---------------------
---------------------
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Integration Tests" [integrationTests, integrationTests2, abc]
......@@ -32,6 +84,7 @@ abc =
[ testCase "setups/domain.yml" $
exec'
[ "install"
, "--delete-residual-roles"
, "--permit-data-deletion"
, "-ds"
, "test/setups/domain.yml"
......@@ -41,12 +94,6 @@ abc =
, xx
]
xx :: TestTree
xx =
testCase "tables" $ do
tables <- conn >>= runReaderT (deployedTables $ SqlName "web")
print $ show tables
integrationTests2 :: TestTree
integrationTests2 = testCase "x" $ exec' ["--help"]
......
schemas:
- self-test
role_prefix: hamsql-test_
name: self-test
description: Table Install
tables:
- name: t1
description: Table with no primary_key
primary_key: []
columns:
- name: a
type: integer
description: A
# unique: true
- name: t2
description: Table 2
primary_key: [a]
columns:
- name: a
type: integer
description: A
# references: table-install.t1.a
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment