Commit 028b5bee authored by Sophie Herold's avatar Sophie Herold 🌼

Adds long and short form for unique constraints

parent 95fcb062
......@@ -44,7 +44,7 @@ run (Install optCommon optDb optInstall)
"must be supplied or non of them."
| otherwise = do
setup <- loadSetup (optSetup optCommon)
stmts <- pgsqlGetFullStatements setup
let stmts = pgsqlGetFullStatements setup
let dbname = SqlName $ T.pack $ tail $ uriPath $ getConUrl optDb
if not (optEmulate optDb || optPrint optDb)
then close =<<
......@@ -68,7 +68,7 @@ run (Upgrade optCommon optDb) = do
setup <- loadSetup (optSetup optCommon)
conn <- pgsqlConnectUrl (getConUrl optDb)
deleteStmts <- pgsqlDeleteAllStmt conn
createStmts <- pgsqlGetFullStatements setup
let createStmts = pgsqlGetFullStatements setup
fragile <- pgsqlUpdateFragile setup conn createStmts
let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile)
useSqlStmts optCommon optDb stmts
......
......@@ -25,9 +25,9 @@ presetEmpty :: [a] -> Maybe [a]
presetEmpty [] = Nothing
presetEmpty xs = Just xs
recoverIndexName :: Text -> [Text] -> Text -> Maybe IndexName
recoverIndexName tbl keys n =
case stripPrefix (tbl <> "_") n >>= stripSuffix "_key" of
recoverIndexName :: Text -> [Text] -> Text -> Text -> Maybe IndexName
recoverIndexName tbl keys n s =
case stripPrefix (tbl <> "_") n >>= stripSuffix ("_" <> s) of
Nothing -> Just $ IndexNamePrefixed {indexnamePrefixed = SqlName n}
Just unprefixed
| unprefixed == intercalate "_" keys -> Nothing
......@@ -83,6 +83,7 @@ deployedTables schema = do
toTable (table, description) = do
columns <- deployedColumns (schema, table)
pk <- deployedPrimaryKey (schema, table)
fks <- deployedForeignKeys (schema, table)
uniques <- deployedUniqueConstraints (schema, table)
return $
Table
......@@ -91,7 +92,7 @@ deployedTables schema = do
, tableColumns = columns
, tablePrimaryKey = pk
, tableUnique = presetEmpty uniques
, tableForeignKeys = Nothing
, tableForeignKeys = presetEmpty fks
, tableChecks = Nothing
, tableInherits = Nothing
, tablePrivSelect = Nothing
......@@ -154,18 +155,56 @@ deployedPrimaryKey tbl = do
-- TODO: do not ignore name
toPrimaryKey (_, keys) = fromPGArray keys
deployedUniqueConstraints :: (SqlName, SqlName) -> SqlT [UniqueConstraint]
deployedUniqueConstraints :: (SqlName, SqlName)
-> SqlT [Abbr [SqlName] UniqueConstraint]
deployedUniqueConstraints tbl@(_, table) = do
res <- psqlQry keyQuery (toSqlCode tbl, True, False)
return $ map toUniqueConstraint res
where
toUniqueConstraint (keyName, keys') =
let keys = fromPGArray keys'
in UniqueConstraint
{ uniqueconstraintName =
recoverIndexName (unsafeInternalName table) keys keyName
, uniqueconstraintColumns = map SqlName keys
idx = recoverIndexName (unsafeInternalName table) keys keyName "key"
in case idx of
Nothing -> ShortForm $ map SqlName keys
index ->
LongForm $
UniqueConstraint
{ uniqueconstraintName = index
, uniqueconstraintColumns = map SqlName keys
}
deployedForeignKeys :: (SqlName, SqlName) -> SqlT [ForeignKey]
deployedForeignKeys tbl@(_, table) = do
res <- psqlQry qry (Only $ toSqlCode tbl)
return $ map toForeignKey res
where
toForeignKey (keyName, cols', fTbl, fCols') =
let cols = fromPGArray cols'
fCols = fromPGArray fCols'
in ForeignKey
{ foreignkeyName =
recoverIndexName (unsafeInternalName table) cols keyName "fkey"
, foreignkeyColumns = map SqlName cols
, foreignkeyRefTable = SqlName fTbl
, foreignkeyRefColumns =
if (map SqlName cols) == fCols
then Nothing
else Just fCols
, foreignkeyOnDelete = Nothing
, foreignkeyOnUpdate = Nothing
}
qry =
[sql|
SELECT
conname,
(SELECT array_agg(attname) FROM unnest(conkey) AS id
JOIN pg_attribute ON attnum=id AND attrelid=conrelid),
confrelid::regclass::text,
(SELECT array_agg(attname) FROM unnest(confkey) AS id
JOIN pg_attribute ON attnum=id AND attrelid=confrelid)
FROM pg_catalog.pg_constraint
WHERE contype='f' AND conrelid::regclass = ?::regclass
|]
-- (tbl, unique, primary)
keyQuery :: Query
......
......@@ -95,8 +95,8 @@ import Database.YamSql
sqlErrInvalidFunctionDefinition :: B.ByteString
sqlErrInvalidFunctionDefinition = "42P13"
pgsqlGetFullStatements :: Setup -> IO [SqlStmt]
pgsqlGetFullStatements setup = return $ catMaybes $ getSetupStatements setup
pgsqlGetFullStatements :: Setup -> [SqlStmt]
pgsqlGetFullStatements setup = catMaybes $ getSetupStatements setup
pgsqlDeleteAllStmt :: Connection -> IO [SqlStmt]
pgsqlDeleteAllStmt conn = do
......
......@@ -203,9 +203,15 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
T.intercalate ", " (map toSqlCode ks) <>
")"
-- TODO: allow empty name with "mconcat (uniquekeyColumns ks)"
sqlUniqueConstr :: UniqueConstraint -> Maybe SqlStmt
sqlUniqueConstr ks =
let constr =
sqlUniqueConstr :: Abbr [SqlName] UniqueConstraint -> Maybe SqlStmt
sqlUniqueConstr ks' =
let ks =
case ks' of
LongForm ko -> ko
ShortForm xs ->
UniqueConstraint
{uniqueconstraintName = Nothing, uniqueconstraintColumns = xs}
constr =
indexName
(tableName t)
(uniqueconstraintColumns ks)
......@@ -219,7 +225,12 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
")"
sqlAddForeignKey' :: ForeignKey -> Maybe SqlStmt
sqlAddForeignKey' fk =
let constr = tableName t <> foreignkeyName fk
let constr =
indexName
(tableName t)
(foreignkeyColumns fk)
(SqlName "fkey")
(foreignkeyName fk)
refColumns =
fromMaybe (foreignkeyColumns fk) (foreignkeyRefColumns fk)
in newSqlStmt SqlCreateForeignKeyConstr (constrId s t constr) $
......
......@@ -7,6 +7,8 @@
module Database.YamSql.Internal.Commons where
import Data.Aeson.Types (Value(Object))
import Database.YamSql.Internal.Basic
data Variable = Variable
......@@ -33,3 +35,13 @@ instance FromJSON Parameter where
instance ToJSON Parameter where
toJSON = toYamSqlJson
data Abbr a b
= ShortForm a
| LongForm b
deriving (Data, Generic, Show)
instance (FromJSON a, FromJSON b) =>
FromJSON (Abbr a b) where
parseJSON x@(Object _) = LongForm <$> parseJSON x
parseJSON x = ShortForm <$> parseJSON x
module Database.YamSql.Internal.Obj.Table where
import Database.YamSql.Internal.Basic
import Database.YamSql.Internal.Commons
import Database.YamSql.Internal.Obj.Check
data Table = Table
......@@ -8,7 +9,7 @@ data Table = Table
, tableDescription :: Text
, tableColumns :: [Column]
, tablePrimaryKey :: [SqlName]
, tableUnique :: Maybe [UniqueConstraint]
, tableUnique :: Maybe [Abbr [SqlName] UniqueConstraint]
, tableForeignKeys :: Maybe [ForeignKey]
, tableChecks :: Maybe [Check]
, tableInherits :: Maybe [SqlName]
......@@ -32,6 +33,10 @@ data SQL_TABLE =
instance ToSqlCode SQL_TABLE where
toSqlCode = const "TABLE"
instance (ToJSON a, ToJSON b) =>
ToJSON (Abbr a b) where
toJSON = toYamSqlJson
data TableTpl = TableTpl
{ tabletplTemplate :: SqlName
, tabletplDescription :: Text
......@@ -113,7 +118,7 @@ instance ToJSON UniqueConstraint where
toJSON = toYamSqlJson
data ForeignKey = ForeignKey
{ foreignkeyName :: SqlName
{ foreignkeyName :: Maybe IndexName
, foreignkeyColumns :: [SqlName]
, foreignkeyRefTable :: SqlName
, foreignkeyRefColumns :: Maybe [SqlName]
......
......@@ -72,10 +72,10 @@ forceToJson s =
parseYamSql
:: (Generic r, GFromJSON Zero (Rep r), Data r)
=> Value -> Parser r
parseYamSql xs = do
parsed <- genericParseJSON myOpt xs
let known = keysOfData parsed
let used = keysOfValue xs
parseYamSql v = do
let used = keysOfValue v
parsed <- genericParseJSON myOpt v
let known = keysOfData $ parsed
let diff = used \\ known
return $
if null diff
......@@ -98,7 +98,8 @@ parseYamSql xs = do
ls = filter (/= "tag") (known \\ used)
closestString :: String -> [String] -> String
closestString x = minimumBy (\y y' -> compare (dist y) (dist y'))
closestString _ [] = "*no additional parameter at all*"
closestString x ys = minimumBy (\y y' -> compare (dist y) (dist y')) ys
where
dist =
levenshteinDistance
......
......@@ -3,11 +3,12 @@ module Main where
import Control.Exception.Safe
import Control.Monad.Trans.Reader (runReaderT)
--import qualified Data.ByteString as B
import qualified Data.ByteString as B
import Data.Monoid ((<>))
import qualified Data.Text.Lazy as T
--import Data.Yaml.Pretty
import Data.Maybe (catMaybes, fromMaybe)
import Data.Yaml.Pretty
import Database.PostgreSQL.Simple (Connection)
import System.Exit
import Text.Pretty.Simple
......@@ -24,7 +25,64 @@ import Database.HamSql.Internal.PostgresCon
import Database.HamSql.Setup
import Database.YamSql
--import Database.YamSql.Internal.SqlId (SqlName(..))
main :: IO ()
main =
defaultMain $
testGroup
"Tests"
[ testGroup
"CLI"
[integrationTests, testCase "show help" $ exec' ["--help"]]
, testGroup
"Integration Tests"
[ testCase "domain.yml" $ deploySetup "test/setups/domain.yml"
, testGroup "self-test.yml" [selfTestStmt, selfTestStruct]
]
]
integrationTests :: TestTree
integrationTests =
testCase "invalid schema" $ do
r <-
exec
(ExitFailure 1)
[ "install"
, "-s"
, "test/setups/invalid.yml"
, "-c"
, "postgresql://postgres@/test1"
]
r @? "Should fail"
--B.putStrLn $ encodePretty defConfig (setupLocal)
--pPrint schemasDb
--B.putStrLn $ encodePretty defConfig (newSetup schemas)
selfTestStmt :: TestTree
selfTestStmt =
testCaseSteps "stmt" $ \step -> do
(schemasDb, setupLocal) <- deploy step "test/setups/self-test.yml"
step "check statement diff"
assertNoDiff
(pgsqlGetFullStatements (newSetup schemasDb))
(pgsqlGetFullStatements setupLocal)
selfTestStruct :: TestTree
selfTestStruct =
testCaseSteps "struct" $ \step -> do
(schemasDb, setupLocal) <- deploy step "test/setups/self-test.yml"
step "check schema diff"
assertNoShowDiff schemasDb (fromMaybe [] $ setupSchemaData setupLocal)
deploy :: (String -> IO ()) -> String -> IO ([Schema], Setup)
deploy step file = do
step "deploy ..."
deploySetup file
step "retrive deployed from database ..."
schemasDb <- conn >>= runReaderT deployedSchemas
step "load setup ..."
setupLocal <- loadSetup file
return (schemasDb, setupLocal)
conn :: IO Connection
conn =
pgsqlConnectUrl $ getConUrlApp "hamsql-test" "postgresql://postgres@/test1"
......@@ -33,54 +91,14 @@ deploySetup :: String -> Assertion
deploySetup s =
exec'
[ "install"
, "--delete-residual-roles"
, "--permit-data-deletion"
, "-ds"
, "test/setups/" ++ s
, s
, "-c"
, "postgresql://postgres@/test1"
]
--B.putStrLn $ encodePretty defConfig (newSetup schemas)
xx :: TestTree
xx =
testCase "tables" $ do
deploySetup "self-test.yml"
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: " <> pForm x <> "\nversion 2: " <> pForm y)
where
pForm Nothing = "*Nothing*"
pForm (Just x) = pShowNoColor x
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
......@@ -92,49 +110,6 @@ newSetup s =
, setupSchemaData = Just s
}
---------------------
---------------------
---------------------
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Integration Tests" [integrationTests, integrationTests2, abc]
abc :: TestTree
abc =
testGroup
"grp3"
[ testCase "setups/domain.yml" $
exec'
[ "install"
, "--delete-residual-roles"
, "--permit-data-deletion"
, "-ds"
, "test/setups/domain.yml"
, "-c"
, "postgresql://postgres@/test1"
]
, xx
]
integrationTests2 :: TestTree
integrationTests2 = testCase "x" $ exec' ["--help"]
integrationTests :: TestTree
integrationTests =
testCase "y" $ do
r <-
exec
(ExitFailure 1)
[ "install"
, "-s"
, "test/setups/invalid.yml"
, "-c"
, "postgresql://postgres@/test1"
]
r @? "Should fail"
exec
:: (Eq e, Exception e)
=> e -> [String] -> IO Bool
......@@ -145,3 +120,48 @@ exec' :: [String] -> Assertion
exec' xs = do
r <- exec ExitSuccess xs
r @? "Exec should not fail"
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 firstDiff xs ys of
Nothing -> return ()
Just i ->
assertFailure $
T.unpack $
"version 1:\n" <> showContext xs i <> "\n\nversion 2:\n" <>
showContext ys i
where
getContext zs i =
let d =
case get zs i of
Nothing -> 2
Just n
| T.length (pShowNoColor n) > 150 -> 0
| otherwise -> 2
in catMaybes [get zs j | j <- [i - d .. i + d]]
showContext zs i = T.intercalate "\n" $ map pShowNoColor $ getContext zs i
firstDiff
:: Eq a
=> [a] -> [a] -> Maybe Int
firstDiff xs ys = findDiff 0
where
findDiff i
| i < max (length xs) (length ys) =
if get xs i /= get ys i
then Just i
else findDiff (i + 1)
| otherwise = Nothing
get :: [a] -> Int -> Maybe a
get xs i
| i < length xs && i >= 0 = Just (xs !! i)
| otherwise = Nothing
......@@ -2,34 +2,43 @@ name: self-test
description: Table Install
tables:
- name: t1
description: Table with no primary_key
- name: "x"
description: Table ``x`` without primary_key
primary_key: []
columns:
- name: a
- name: x1
type: integer
description: A
# unique: true
description: Column x1
- name: x2
type: integer
description: Column x2
- name: x3
type: integer
description: Column x3
unique:
- columns: [a]
- name: test1
columns: [a]
- name:
prefixed: x_test1
columns: [a]
- name: t2
description: Table 2
primary_key: [b]
# TODO: customPrefix_u2 fails
prefixed: customprefix_u2
columns: [x1]
- name: u1
columns: [x1]
- [x1]
- [x1, x3]
- name: "y"
description: Table ``y``
primary_key: [y1]
columns:
- name: b
- name: y1
type: integer
description: B
# references: self-test.t1.a
# foreign_keys:
# - name: manualfk
# columns: [b]
# ref_table: self-test.t1
# ref_columns: [a]
description: Column y1
- name: y2
type: integer
description: Column y2
foreign_keys:
- name: manualfk
columns: [y1, y2]
ref_table: '"self-test".x'
ref_columns: [x1, x3]
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