Commit 95fcb062 authored by Sophie Herold's avatar Sophie Herold 🌼

Adds support for auto and custom index names

parent 2c550b4e
Pipeline #794 passed with stage
in 4 minutes and 1 second
......@@ -4,7 +4,7 @@
-- Some rights reserved. See COPYING, AUTHORS.
module Database.HamSql.Internal.InquireDeployed where
import Data.Text (stripPrefix)
import Data.Text (stripPrefix, stripSuffix, intercalate)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.Types (PGArray(..), fromPGArray)
......@@ -21,6 +21,18 @@ preset d x
| d == x = Nothing
| otherwise = Just x
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
Nothing -> Just $ IndexNamePrefixed {indexnamePrefixed = SqlName n}
Just unprefixed
| unprefixed == intercalate "_" keys -> Nothing
| otherwise -> Just $ IndexNameUnprefixed (SqlName unprefixed)
deployedSchemas :: SqlT [Schema]
deployedSchemas = do
schemas <- psqlQry_ qry
......@@ -71,13 +83,14 @@ deployedTables schema = do
toTable (table, description) = do
columns <- deployedColumns (schema, table)
pk <- deployedPrimaryKey (schema, table)
uniques <- deployedUniqueConstraints (schema, table)
return $
Table
{ tableName = table
, tableDescription = description
, tableColumns = columns
, tablePrimaryKey = pk
, tableUnique = Nothing
, tableUnique = presetEmpty uniques
, tableForeignKeys = Nothing
, tableChecks = Nothing
, tableInherits = Nothing
......@@ -141,6 +154,19 @@ deployedPrimaryKey tbl = do
-- TODO: do not ignore name
toPrimaryKey (_, keys) = fromPGArray keys
deployedUniqueConstraints :: (SqlName, SqlName) -> SqlT [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
}
-- (tbl, unique, primary)
keyQuery :: Query
keyQuery =
......
......@@ -6,7 +6,6 @@ module Database.HamSql.Internal.Stmt.Create where
import Data.Maybe
import Database.HamSql.Internal.Option
import Database.HamSql.Internal.Stmt
import Database.HamSql.Internal.Stmt.Basic
import Database.HamSql.Internal.Stmt.Commons ()
......
......@@ -160,6 +160,13 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
, sequenceOwnedByColumn = Just $ SqlName $ sqlIdCode obj
})
indexName :: SqlName -> [SqlName] -> SqlName -> Maybe IndexName -> SqlName
indexName t keys s Nothing = mconcat ([t] ++ keys ++ [s])
indexName t _ s (Just k) =
case k of
(IndexNameUnprefixed n) -> t <> n <> s
(IndexNamePrefixed {indexnamePrefixed = n}) -> n
instance ToSqlStmts (SqlContext (Schema, Table)) where
toSqlStmts SetupContext {setupContextSetup = setup} obj@(SqlContext (s, t)) =
[ stmtCreateTable
......@@ -196,14 +203,19 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
T.intercalate ", " (map toSqlCode ks) <>
")"
-- TODO: allow empty name with "mconcat (uniquekeyColumns ks)"
sqlUniqueConstr :: UniqueKey -> Maybe SqlStmt
sqlUniqueConstr :: UniqueConstraint -> Maybe SqlStmt
sqlUniqueConstr ks =
let constr = tableName t <> uniquekeyName ks
let constr =
indexName
(tableName t)
(uniqueconstraintColumns ks)
(SqlName "key")
(uniqueconstraintName ks)
in newSqlStmt SqlCreateUniqueConstr (constrId s t constr) $
"ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <>
toSqlCode constr <>
" UNIQUE (" <>
T.intercalate ", " (map toSqlCode (uniquekeyColumns ks)) <>
T.intercalate ", " (map toSqlCode (uniqueconstraintColumns ks)) <>
")"
sqlAddForeignKey' :: ForeignKey -> Maybe SqlStmt
sqlAddForeignKey' fk =
......
......@@ -8,7 +8,7 @@ data Table = Table
, tableDescription :: Text
, tableColumns :: [Column]
, tablePrimaryKey :: [SqlName]
, tableUnique :: Maybe [UniqueKey]
, tableUnique :: Maybe [UniqueConstraint]
, tableForeignKeys :: Maybe [ForeignKey]
, tableChecks :: Maybe [Check]
, tableInherits :: Maybe [SqlName]
......@@ -90,15 +90,26 @@ applyTableTpl tpl t =
, tablePrivDelete = maybeJoin (tabletplPrivDelete tpl) (tablePrivDelete t)
}
data UniqueKey = UniqueKey
{ uniquekeyName :: SqlName
, uniquekeyColumns :: [SqlName]
data IndexName
= IndexNameUnprefixed SqlName
| IndexNamePrefixed { indexnamePrefixed :: SqlName }
deriving (Generic, Show, Data)
instance FromJSON IndexName where
parseJSON = parseYamSql
instance ToJSON IndexName where
toJSON = toYamSqlJson
data UniqueConstraint = UniqueConstraint
{ uniqueconstraintName :: Maybe IndexName
, uniqueconstraintColumns :: [SqlName]
} deriving (Generic, Show, Data)
instance FromJSON UniqueKey where
instance FromJSON UniqueConstraint where
parseJSON = parseYamSql
instance ToJSON UniqueKey where
instance ToJSON UniqueConstraint where
toJSON = toYamSqlJson
data ForeignKey = ForeignKey
......
......@@ -18,7 +18,7 @@ module Database.YamSql.Parser
import Control.Exception
import Data.Aeson.Types
(GFromJSON, GToJSON, Options(..), defaultOptions, genericParseJSON,
genericToJSON, Zero)
genericToJSON, Zero, SumEncoding(UntaggedValue))
import Data.Char
import Data.Data
......@@ -55,6 +55,7 @@ myOpt =
defaultOptions
{ fieldLabelModifier = snakeify . removeFirstPart
, constructorTagModifier = drop 1 . snakeify
, sumEncoding = UntaggedValue
}
outJson
......@@ -88,7 +89,7 @@ parseYamSql xs = do
"tag" : map (snakeify . removeFirstPart) (constrFields (toConstr u))
keysOfValue :: Value -> [String]
keysOfValue (Object ys) = map T.unpack $ keys ys
keysOfValue _ = err "HAMSQL-UNEXPECTED 3"
keysOfValue _ = []
explainMissing :: [String] -> [String] -> String -> Text
explainMissing known used x =
"\n - " <> tshow x <> " (did you mean " <> tshow (closestString x ls) <>
......
......@@ -2,10 +2,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.Yaml.Pretty
import Database.PostgreSQL.Simple (Connection)
import System.Exit
import Text.Pretty.Simple
......@@ -21,12 +23,13 @@ import Database.HamSql.Internal.Load (loadSetup)
import Database.HamSql.Internal.PostgresCon
import Database.HamSql.Setup
import Database.YamSql
import Database.YamSql.Internal.SqlId (SqlName(..))
--import Database.YamSql.Internal.SqlId (SqlName(..))
conn :: IO Connection
conn =
pgsqlConnectUrl $ getConUrlApp "hamsql-test" "postgresql://postgres@/test1"
deploySetup :: String -> Assertion
deploySetup s =
exec'
[ "install"
......@@ -63,8 +66,10 @@ assertNoDiff xs ys =
Nothing -> return ()
Just (x, y) ->
assertFailure $
T.unpack
("version 1: " <> pShowNoColor x <> "\nversion 2: " <> pShowNoColor y)
T.unpack ("version 1: " <> pForm x <> "\nversion 2: " <> pForm y)
where
pForm Nothing = "*Nothing*"
pForm (Just x) = pShowNoColor x
firstListDiff
:: Eq a
......
......@@ -10,6 +10,13 @@ tables:
type: integer
description: A
# unique: true
unique:
- columns: [a]
- name: test1
columns: [a]
- name:
prefixed: x_test1
columns: [a]
- name: t2
description: Table 2
primary_key: [b]
......@@ -24,3 +31,5 @@ tables:
# 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