Commit 2c550b4e authored by Sophie Herold's avatar Sophie Herold 🌼

Adds first data structure self test

parent a9a0beb7
Pipeline #793 passed with stage
in 5 minutes and 17 seconds
......@@ -136,6 +136,8 @@ test-suite hamsql-tests
transformers,
yaml,
bytestring,
pretty-simple,
text,
-- test
tasty,
tasty-hunit,
......
......@@ -14,6 +14,13 @@ import Database.HamSql.Internal.Utils
import Database.HamSql.Setup
import Database.YamSql
preset
:: Eq a
=> a -> a -> Maybe a
preset d x
| d == x = Nothing
| otherwise = Just x
deployedSchemas :: SqlT [Schema]
deployedSchemas = do
schemas <- psqlQry_ qry
......@@ -26,12 +33,12 @@ deployedSchemas = do
{ schemaName = schema
, schemaDescription = description
, schemaDependencies = Nothing
, schemaFunctions = Nothing
, schemaFunctions = Just []
, schemaFunctionTemplates = Nothing
, schemaTables = Just tables
, schemaTableTemplates = Nothing
, schemaRoles = Nothing
, schemaSequences = Nothing
, schemaSequences = Just []
, schemaPrivUsage = Nothing
, schemaPrivSelectAll = Nothing
, schemaPrivInsertAll = Nothing
......@@ -40,8 +47,8 @@ deployedSchemas = do
, schemaPrivSequenceAll = Nothing
, schemaPrivExecuteAll = Nothing
, schemaPrivAllAll = Nothing
, schemaDomains = Nothing
, schemaTypes = Nothing
, schemaDomains = Just []
, schemaTypes = Just []
, schemaExecPostInstall = Nothing
, schemaExecPostInstallAndUpgrade = Nothing
}
......@@ -99,7 +106,7 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
, columnType = dataType
, columnDescription = description
, columnDefault = columnDefault'
, columnNull = isNullable
, columnNull = preset False isNullable
, columnReferences = Nothing
, columnOnRefDelete = Nothing
, columnOnRefUpdate = Nothing
......@@ -121,9 +128,10 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
WHERE (table_schema || '.' || table_name)::regclass = ?::regclass
|]
--deployedKeys ::
deployedPrimaryKey :: (SqlName, SqlName) -> SqlT [SqlName]
deployedPrimaryKey tbl = do
res <- psqlQry keyQuery (Only $ toSqlCode tbl)
res <- psqlQry keyQuery (toSqlCode tbl, True, True)
return $
case res of
[] -> []
......@@ -133,7 +141,7 @@ deployedPrimaryKey tbl = do
-- TODO: do not ignore name
toPrimaryKey (_, keys) = fromPGArray keys
-- (tbl)
-- (tbl, unique, primary)
keyQuery :: Query
keyQuery =
[sql|
......@@ -149,7 +157,8 @@ keyQuery =
ON trel.oid = a.attrelid AND a.attnum = c.colnum
WHERE
(tnsp.nspname || '.' || trel.relname)::regclass = ?::regclass
AND i.indisprimary
AND i.indisunique = ?
AND i.indisprimary = ?
GROUP BY tnsp.nspname, trel.relname, irel.relname;
|]
......
......@@ -3,9 +3,12 @@ module Main where
import Control.Exception.Safe
import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.ByteString as B
import Data.Monoid ((<>))
import qualified Data.Text.Lazy as T
import Data.Yaml.Pretty
import Database.PostgreSQL.Simple (Connection)
import System.Exit
import Text.Pretty.Simple
--import System.Directory
import Test.Tasty
......@@ -34,18 +37,34 @@ deploySetup s =
, "postgresql://postgres@/test1"
]
--B.putStrLn $ encodePretty defConfig (newSetup schemas)
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
setupLocal <- (loadSetup "test/setups/self-test.yml")
stmtsLocal <- pgsqlGetFullStatements setupLocal
schemasDb <- conn >>= runReaderT deployedSchemas
stmtsDb <- pgsqlGetFullStatements (newSetup schemasDb)
assertNoShowDiff (Just schemasDb) (setupSchemaData setupLocal)
assertNoDiff stmtsDb stmtsLocal
assertNoShowDiff
:: (Show a0, Show a1)
=> a0 -> a1 -> Assertion
assertNoShowDiff x y =
assertNoDiff (T.lines $ pShowNoColor x) (T.lines $ pShowNoColor y)
assertNoDiff
:: (Show a, Eq a)
=> [a] -> [a] -> Assertion
assertNoDiff xs ys =
case firstListDiff xs ys of
Nothing -> return ()
Just (x, y) ->
assertFailure $
T.unpack
("version 1: " <> pShowNoColor x <> "\nversion 2: " <> pShowNoColor y)
firstListDiff
:: Eq a
......
......@@ -12,10 +12,15 @@ tables:
# unique: true
- name: t2
description: Table 2
primary_key: [a]
primary_key: [b]
columns:
- name: a
- name: b
type: integer
description: A
# references: table-install.t1.a
description: B
# references: self-test.t1.a
# foreign_keys:
# - name: manualfk
# columns: [b]
# ref_table: self-test.t1
# ref_columns: [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