From 862b553870a57a611bc777f23de8ca0f709fc078 Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Mon, 10 Aug 2020 18:12:54 +0100 Subject: [PATCH 01/10] Add parsing and compilation of primary key table constraints --- IHP/IDE/SchemaDesigner/Parser.hs | 22 ++++++-- IHP/IDE/SchemaDesigner/Types.hs | 2 + IHP/SchemaCompiler.hs | 80 ++++++++++++++++++--------- Test/IDE/SchemaDesigner/ParserSpec.hs | 19 +++++++ 4 files changed, 92 insertions(+), 31 deletions(-) diff --git a/IHP/IDE/SchemaDesigner/Parser.hs b/IHP/IDE/SchemaDesigner/Parser.hs index 3fbdeb3fa..d8d6b8e5d 100644 --- a/IHP/IDE/SchemaDesigner/Parser.hs +++ b/IHP/IDE/SchemaDesigner/Parser.hs @@ -78,7 +78,7 @@ createTable = do char '.' name <- identifier (columns, constraints) <- between (char '(' >> space) (char ')' >> space) do - columnsAndConstraints <- ((Right <$> parseUniqueConstraint) <|> (Left <$> column)) `sepBy` (char ',' >> space) + columnsAndConstraints <- ((Right <$> parseTableConstraint) <|> (Left <$> column)) `sepBy` (char ',' >> space) pure (lefts columnsAndConstraints, rights columnsAndConstraints) char ';' pure CreateTable { name, columns, constraints } @@ -100,11 +100,25 @@ addConstraint = do lexeme "ADD" lexeme "CONSTRAINT" constraintName <- identifier - constraint <- parseConstraint + constraint <- parseTableConstraint char ';' pure AddConstraint { tableName, constraintName, constraint } -parseConstraint = do +parseTableConstraint = do + optional do + lexeme "CONSTRAINT" + identifier + parsePrimaryKeyConstraint + <|> parseForeignKeyConstraint + <|> parseUniqueConstraint + +parsePrimaryKeyConstraint = do + lexeme "PRIMARY" + lexeme "KEY" + columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space)) + pure PrimaryKeyConstraint { columnNames } + +parseForeignKeyConstraint = do lexeme "FOREIGN" lexeme "KEY" columnName <- between (char '(' >> space) (char ')' >> space) identifier @@ -120,7 +134,7 @@ parseConstraint = do parseUniqueConstraint = do lexeme "UNIQUE" columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space)) - pure UniqueConstraint { columnNames } + pure UniqueConstraint { columnNames } parseOnDelete = choice diff --git a/IHP/IDE/SchemaDesigner/Types.hs b/IHP/IDE/SchemaDesigner/Types.hs index f58700503..253819104 100644 --- a/IHP/IDE/SchemaDesigner/Types.hs +++ b/IHP/IDE/SchemaDesigner/Types.hs @@ -46,6 +46,8 @@ data Constraint , referenceColumn :: Maybe Text , onDelete :: Maybe OnDelete } + | PrimaryKeyConstraint + { columnNames :: [Text] } | UniqueConstraint { columnNames :: [Text] } deriving (Eq, Show) diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 908c74033..c9058c4c6 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -49,32 +49,35 @@ fullCompileOptions = CompilerOptions { compileGetAndSetFieldInstances = True } previewCompilerOptions :: CompilerOptions previewCompilerOptions = CompilerOptions { compileGetAndSetFieldInstances = False } +atomicType :: PostgresType -> Text +atomicType = \case + PInt -> "Int" + PBigInt -> "Integer" + PText -> "Text" + PBoolean -> "Bool" + PTimestampWithTimezone -> "UTCTime" + PUUID -> "UUID" + PSerial -> "Int" + PBigserial -> "Integer" + PReal -> "Float" + PDouble -> "Double" + PDate -> "Data.Time.Calendar.Day" + PBinary -> "Binary" + PTime -> "TimeOfDay" + PCustomType theType -> tableNameToModelName theType + PTimestamp -> "LocalTime" + (PNumeric _ _) -> "Float" + (PVaryingN _) -> "Text" + (PCharacterN _) -> "Text" + haskellType :: (?schema :: Schema) => Statement -> Column -> Text haskellType table Column { name, primaryKey } | primaryKey = "(" <> primaryKeyTypeName table <> ")" haskellType table column@(Column { columnType, notNull }) = let - atomicType = - case columnType of - PInt -> "Int" - PBigInt -> "Integer" - PText -> "Text" - PBoolean -> "Bool" - PTimestampWithTimezone -> "UTCTime" - PUUID -> "UUID" - PReal -> "Float" - PDouble -> "Double" - PDate -> "Data.Time.Calendar.Day" - PBinary -> "Binary" - PTime -> "TimeOfDay" - PCustomType theType -> tableNameToModelName theType - PTimestamp -> "LocalTime" - (PNumeric _ _) -> "Float" - (PVaryingN _) -> "Text" - (PCharacterN _) -> "Text" actualType = case findForeignKeyConstraint table column of Just (ForeignKeyConstraint { referenceTable }) -> "(" <> primaryKeyTypeName' referenceTable <> ")" - _ -> atomicType + _ -> atomicType columnType in if not notNull then "(Maybe " <> actualType <> ")" @@ -512,17 +515,40 @@ compileHasTableNameInstance table@(CreateTable { name }) = <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n" compilePrimaryKeyInstance :: (?schema :: Schema) => Statement -> Text -compilePrimaryKeyInstance table@(CreateTable { name, columns }) = "type instance PrimaryKey " <> tshow name <> " = " <> idType <> "\n" +compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = + "type instance PrimaryKey " <> tshow name <> " = " <> idType <> "\n" where - idColumn :: Column - (Just idColumn) = find (get #primaryKey) columns + idColumns :: [Column] + idColumns = case (idColumn, constraintColumns) of + (Just _, Just _) -> error ("Multiple primary keys for table " <> cs name <> " are not allowed") + (Just c, Nothing) -> [c] + (Nothing, Just cs) -> cs + (Nothing, Nothing) -> error ("No primary key defined for table " <> cs name) + + idColumn :: Maybe Column + idColumn = find (get #primaryKey) columns + + constraintColumns :: Maybe [Column] + constraintColumns = map getColumn . columnNames <$> find isPrimaryKeyConstraint constraints + where + getColumn columnName = case find ((==) columnName . get #name) columns of + Just c -> c + Nothing -> error ("Missing column " <> cs columnName <> " used in primary key for " <> cs name) + + isPrimaryKeyConstraint PrimaryKeyConstraint {} = True + isPrimaryKeyConstraint _ = False idType :: Text - idType = case get #columnType idColumn of - PUUID -> "UUID" - PSerial -> "Int" - PBigserial -> "Integer" - otherwise -> error ("Unexpected type for primary key column in table" <> cs name) + idType = case idColumns of + [] -> error "Impossible happened in compilePrimaryKeyInstance" + [c] -> colType c + cs -> "(" <> intercalate ", " (map colType cs) <> ")" + where colType = atomicType . get #columnType + -- colType column = case get #columnType column of + -- PUUID -> "UUID" + -- PSerial -> "Int" + -- PBigserial -> "Integer" + -- otherwise -> error ("Unexpected type for primary key column in table " <> cs name) compileGetModelName :: (?schema :: Schema) => Statement -> Text compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow (tableNameToModelName name) <> "\n" diff --git a/Test/IDE/SchemaDesigner/ParserSpec.hs b/Test/IDE/SchemaDesigner/ParserSpec.hs index 28fc8e808..d3115e83d 100644 --- a/Test/IDE/SchemaDesigner/ParserSpec.hs +++ b/Test/IDE/SchemaDesigner/ParserSpec.hs @@ -253,6 +253,25 @@ tests = do (evaluate (parseSql "CREATE TABLE user_followers (id UUID, UNIQUE());")) `shouldThrow` anyException pure () + it "should parse a CREATE TABLE statement with a multi-column PRIMARY KEY (a, b) constraint" do + parseSql "CREATE TABLE user_followers (user_id UUID NOT NULL, follower_id UUID NOT NULL, PRIMARY KEY (user_id, follower_id));" `shouldBe` CreateTable + { name = "user_followers" + , columns = + [ col { name = "user_id", columnType = PUUID, notNull = True } + , col { name = "follower_id", columnType = PUUID, notNull = True } + ] + , constraints = [ PrimaryKeyConstraint { columnNames = [ "user_id", "follower_id" ] } ] + } + + -- Should we also have the following failure or is it better to check it outside of the parser? + -- it "should fail to parse a CREATE TABLE statement with PRIMARY KEY column and table constraints" do + -- (evaluate (parseSql "CREATE TABLE user_followers (id UUID PRIMARY KEY, PRIMARY KEY(id));")) `shouldThrow` anyException + -- pure () + + it "should fail to parse a CREATE TABLE statement with an empty PRIMARY KEY () constraint" do + (evaluate (parseSql "CREATE TABLE user_followers (id UUID, PRIMARY KEY ());")) `shouldThrow` anyException + pure () + it "should parse a CREATE TABLE statement with a serial id" do parseSql "CREATE TABLE orders (\n id SERIAL PRIMARY KEY NOT NULL\n);\n" `shouldBe` CreateTable { name = "orders" From 29bac8824090daf1f4d285b456cea1910d2e6108 Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Fri, 14 Aug 2020 15:51:23 +0100 Subject: [PATCH 02/10] [#291] Add composite primary key code generation to SchemaCompiler --- IHP/SchemaCompiler.hs | 118 +++++++++++++++++++++++++----------------- 1 file changed, 71 insertions(+), 47 deletions(-) diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index c9058c4c6..1a501631c 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -5,6 +5,7 @@ module IHP.SchemaCompiler import ClassyPrelude import Data.String.Conversions (cs) +import Data.String.Interpolate (i) import IHP.NameSupport (tableNameToModelName, columnNameToFieldName) import Data.Maybe (fromJust) import qualified Data.Text as Text @@ -150,6 +151,9 @@ compileStatement CompilerOptions { compileGetAndSetFieldInstances } table@(Creat <> compileUpdate table <> section <> compileBuild table + <> if needsHasFieldId table + then compileHasFieldId table + else "" <> section <> if compileGetAndSetFieldInstances then compileSetFieldInstances table <> compileUpdateFieldInstances table @@ -185,7 +189,7 @@ compileData :: (?schema :: Schema) => Statement -> Text compileData table@(CreateTable { name, columns }) = "data " <> modelName <> "' " <> typeArguments <> " = " <> modelName <> " {" - <> + <> table |> dataFields |> map (\(fieldName, fieldType) -> fieldName <> " :: " <> fieldType) @@ -202,7 +206,7 @@ dataTypeArguments :: (?schema :: Schema) => Statement -> [Text] dataTypeArguments table = (map columnNameToFieldName belongsToVariables) <> hasManyVariables where belongsToVariables = variableAttributes table |> map (get #name) - hasManyVariables = + hasManyVariables = columnsReferencingTable (get #name table) |> compileQueryBuilderFields |> map snd @@ -252,11 +256,11 @@ compileQueryBuilderFields columns = map compileQueryBuilderField columns |> length |> (\count -> count > 1) - stripIdSuffix :: Text -> Text + stripIdSuffix :: Text -> Text stripIdSuffix name = fromMaybe name (Text.stripSuffix "_id" name) fieldName = if hasDuplicateQueryBuilder - then + then (refTableName <> "_" <> (refColumnName |> stripIdSuffix)) |> columnNameToFieldName |> Countable.pluralize @@ -279,7 +283,7 @@ compileQueryBuilderFields columns = map compileQueryBuilderField columns -- >>> columnsReferencingTable "companies" -- [ ("users", "company_id") ] columnsReferencingTable :: (?schema :: Schema) => Text -> [(Text, Text)] -columnsReferencingTable theTableName = +columnsReferencingTable theTableName = let (Schema statements) = ?schema in @@ -345,7 +349,7 @@ compileCreate table@(CreateTable { name, columns }) = if hasExplicitOrImplicitDefault column then "fieldWithDefault #" <> columnNameToFieldName name <> " model" else "get #" <> columnNameToFieldName name <> " model" - + bindings :: [Text] bindings = map toBinding columns @@ -386,11 +390,12 @@ compileUpdate table@(CreateTable { name, columns }) = modelName = tableNameToModelName name toUpdateBinding Column { name } = "fieldWithUpdate #" <> columnNameToFieldName name <> " model" + toPrimaryKeyBinding Column { name } = "get #" <> columnNameToFieldName name <> " model" bindings :: Text bindings = let - bindingValues = (map toUpdateBinding columns) <> ["get #id model"] + bindingValues = map toUpdateBinding columns <> map toPrimaryKeyBinding (primaryKeyColumns table) in compileToRowValues bindingValues @@ -405,26 +410,30 @@ compileUpdate table@(CreateTable { name, columns }) = ) compileFromRowInstance :: (?schema :: Schema) => Statement -> Text -compileFromRowInstance table@(CreateTable { name, columns }) = - "instance FromRow " <> modelName <> " where " - <> ("fromRow = do id <- field; " <> modelName <> " <$> " <> (intercalate " <*> " $ map compileField (dataFields table))) <> ";\n" +compileFromRowInstance table@(CreateTable { name, columns }) = cs [i| +instance FromRow #{modelName} where + fromRow = do +#{unsafeInit . indent . indent . unlines $ map columnBinding columnNames} + pure $ #{modelName} #{intercalate " " (map compileField (dataFields table))} + +|] where modelName = tableNameToModelName name columnNames = map (columnNameToFieldName . get #name) columns - - + columnBinding columnName = columnName <> " <- field" referencing = columnsReferencingTable (get #name table) - isManyToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst)) + compileField (fieldName, _) + | isColumn fieldName = fieldName + | isManyToManyField fieldName = let (Just ref) = find (\(n, _) -> columnNameToFieldName n == fieldName) referencing in compileSetQueryBuilder ref + | otherwise = "def" + isPrimaryKey name = name `elem` primaryKeyColumnNames table isColumn name = name `elem` columnNames - compileField ("id", _) = "pure id" - compileField (fieldName, _) | isColumn fieldName = "field" - compileField (fieldName, _) | isManyToManyField fieldName = let (Just ref) = find (\(n, _) -> columnNameToFieldName n == fieldName) referencing in compileSetQueryBuilder ref - compileField _ = "pure def" + isManyToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst)) - compileSetQueryBuilder (refTableName, refFieldName) = "pure (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow (columnNameToFieldName refFieldName) <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" + compileSetQueryBuilder (refTableName, refFieldName) = "pure (QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" where -- | When the referenced column is nullable, we have to wrap the @Id@ in @Just@ primaryKeyField :: Text @@ -444,7 +453,6 @@ compileFromRowInstance table@(CreateTable { name, columns }) = Just refColumn -> refColumn Nothing -> error (cs $ "Could not find " <> get #name refTable <> "." <> refFieldName <> " referenced by a foreign key constraint. Make sure that there is no typo in the foreign key constraint") - compileQuery column@(Column { name }) = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" -- compileQuery column@(Column { name }) | isReferenceColum column = columnNameToFieldName name <> " = (" <> toBinding modelName column <> ")" --compileQuery (HasMany hasManyName inverseOf) = columnNameToFieldName hasManyName <> " = (QueryBuilder.filterWhere (Data.Proxy.Proxy @" <> tshow relatedFieldName <> ", " <> (fromJust $ toBinding' (tableNameToModelName name) relatedIdField) <> ") (QueryBuilder.query @" <> tableNameToModelName hasManyName <>"))" @@ -518,37 +526,12 @@ compilePrimaryKeyInstance :: (?schema :: Schema) => Statement -> Text compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = "type instance PrimaryKey " <> tshow name <> " = " <> idType <> "\n" where - idColumns :: [Column] - idColumns = case (idColumn, constraintColumns) of - (Just _, Just _) -> error ("Multiple primary keys for table " <> cs name <> " are not allowed") - (Just c, Nothing) -> [c] - (Nothing, Just cs) -> cs - (Nothing, Nothing) -> error ("No primary key defined for table " <> cs name) - - idColumn :: Maybe Column - idColumn = find (get #primaryKey) columns - - constraintColumns :: Maybe [Column] - constraintColumns = map getColumn . columnNames <$> find isPrimaryKeyConstraint constraints - where - getColumn columnName = case find ((==) columnName . get #name) columns of - Just c -> c - Nothing -> error ("Missing column " <> cs columnName <> " used in primary key for " <> cs name) - - isPrimaryKeyConstraint PrimaryKeyConstraint {} = True - isPrimaryKeyConstraint _ = False - idType :: Text - idType = case idColumns of + idType = case primaryKeyColumns table of [] -> error "Impossible happened in compilePrimaryKeyInstance" [c] -> colType c cs -> "(" <> intercalate ", " (map colType cs) <> ")" where colType = atomicType . get #columnType - -- colType column = case get #columnType column of - -- PUUID -> "UUID" - -- PSerial -> "Int" - -- PBigserial -> "Integer" - -- otherwise -> error ("Unexpected type for primary key column in table " <> cs name) compileGetModelName :: (?schema :: Schema) => Statement -> Text compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow (tableNameToModelName name) <> "\n" @@ -563,7 +546,7 @@ compileInclude :: (?schema :: Schema) => Statement -> Text compileInclude table@(CreateTable { name, columns }) = (belongsToIncludes <> hasManyIncludes) |> unlines where belongsToIncludes = map compileBelongsTo (filter (isRefCol table) columns) - hasManyIncludes = columnsReferencingTable name |> map compileHasMany + hasManyIncludes = columnsReferencingTable name |> map compileHasMany typeArgs = dataTypeArguments table modelName = tableNameToModelName name modelConstructor = modelName <> "'" @@ -620,6 +603,47 @@ compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map compileTypePattern' :: Text -> Text compileTypePattern' name = tableNameToModelName (get #name table) <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) (dataTypeArguments table)) +compileHasFieldId :: (?schema :: Schema) => Statement -> Text +compileHasFieldId table = cs [i| +instance HasField "id" Picture (Id' "pictures") where + getField (#{compileDataTypePattern table}) = Id #{compilePrimaryKeyValue} +|] + where + compilePrimaryKeyValue = case primaryKeyColumnNames table of + [id] -> columnNameToFieldName id + ids -> "(" <> commaSep (map columnNameToFieldName ids) <> ")" + +needsHasFieldId :: Statement -> Bool +needsHasFieldId table = case primaryKeyColumnNames table of + [] -> False + ["id"] -> False + _ -> True + +primaryKeyColumnNames :: Statement -> [Text] +primaryKeyColumnNames table@(CreateTable { name, columns, constraints }) = + case (idColumn, constraintColumns) of + (Just _, Just _) -> error ("Multiple primary keys for table " <> cs name <> " are not allowed") + (Just c, Nothing) -> [c] + (Nothing, Just cs) -> cs + (Nothing, Nothing) -> error ("No primary key defined for table " <> cs name) + where + idColumn :: Maybe Text + idColumn = get #name <$> find (get #primaryKey) columns + + constraintColumns :: Maybe [Text] + constraintColumns = columnNames <$> find isPrimaryKeyConstraint constraints + + isPrimaryKeyConstraint PrimaryKeyConstraint {} = True + isPrimaryKeyConstraint _ = False + +primaryKeyColumns :: Statement -> [Column] +primaryKeyColumns table@(CreateTable { name, columns }) = + map getColumn (primaryKeyColumnNames table) + where + getColumn columnName = case find ((==) columnName . get #name) columns of + Just c -> c + Nothing -> error ("Missing column " <> cs columnName <> " used in primary key for " <> cs name) + -- | Indents a block of code with 4 spaces. -- -- Empty lines are not indented. @@ -638,4 +662,4 @@ hasExplicitOrImplicitDefault column = case column of Column { defaultValue = Just _ } -> True Column { columnType = PSerial } -> True Column { columnType = PBigserial } -> True - _ -> False \ No newline at end of file + _ -> False From 918d146bce2c3f0181cfe7fdf8797cfa0f49a5eb Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Fri, 14 Aug 2020 19:45:30 +0100 Subject: [PATCH 03/10] [#291] Allow composite primary keys in schema designer UI --- IHP/IDE/CodeGen/ControllerGenerator.hs | 14 +-- IHP/IDE/CodeGen/ViewGenerator.hs | 22 ++-- IHP/IDE/SchemaDesigner/Compiler.hs | 11 +- IHP/IDE/SchemaDesigner/Controller/Columns.hs | 80 ++++++------ IHP/IDE/SchemaDesigner/Controller/Tables.hs | 26 ++-- IHP/IDE/SchemaDesigner/Parser.hs | 50 +++++--- IHP/IDE/SchemaDesigner/Types.hs | 20 ++- IHP/IDE/SchemaDesigner/View/Columns/Edit.hs | 27 ++-- .../View/Columns/EditForeignKey.hs | 2 +- IHP/IDE/SchemaDesigner/View/Columns/New.hs | 2 +- .../View/Columns/NewForeignKey.hs | 2 +- IHP/IDE/SchemaDesigner/View/Layout.hs | 21 +++- IHP/IDE/SchemaDesigner/View/Tables/Show.hs | 2 +- IHP/SchemaCompiler.hs | 117 ++++++++---------- 14 files changed, 221 insertions(+), 175 deletions(-) diff --git a/IHP/IDE/CodeGen/ControllerGenerator.hs b/IHP/IDE/CodeGen/ControllerGenerator.hs index f4b4cce13..d398f3865 100644 --- a/IHP/IDE/CodeGen/ControllerGenerator.hs +++ b/IHP/IDE/CodeGen/ControllerGenerator.hs @@ -24,7 +24,7 @@ buildPlan rawControllerName applicationName = do Right statements -> pure statements let controllerName = tableNameToControllerName rawControllerName let modelName = tableNameToModelName rawControllerName - pure $ Right $ buildPlan' schema applicationName controllerName modelName + pure $ Right $ buildPlan' schema applicationName controllerName modelName buildPlan' schema applicationName controllerName modelName = let @@ -40,7 +40,7 @@ buildPlan' schema applicationName controllerName modelName = <> viewPlans data ControllerConfig = ControllerConfig - { controllerName :: Text + { controllerName :: Text , applicationName :: Text , modelName :: Text } deriving (Eq, Show) @@ -52,7 +52,6 @@ controllerInstance ControllerConfig { controllerName, modelName, applicationName data HaskellModule = HaskellModule { moduleName :: Text, body :: Text } - generateControllerData :: ControllerConfig -> Text generateControllerData config = let @@ -61,7 +60,7 @@ generateControllerData config = singularName = get #modelName config idFieldName = lcfirst singularName <> "Id" idType = "Id " <> singularName - in + in "\n" <> "data " <> name <> "Controller\n" <> " = " <> pluralName <> "Action\n" @@ -127,7 +126,7 @@ generateController schema config = "" <> " action Update" <> singularName <> "Action { " <> idFieldName <> " } = do\n" <> " " <> modelVariableSingular <> " <- fetch " <> idFieldName <> "\n" - <> " " <> modelVariableSingular <> "\n" + <> " " <> modelVariableSingular <> "\n" <> " |> build" <> singularName <> "\n" <> " |> ifValid \\case\n" <> " Left " <> modelVariableSingular <> " -> render EditView { .. }\n" @@ -140,7 +139,7 @@ generateController schema config = "" <> " action Create" <> singularName <> "Action = do\n" <> " let " <> modelVariableSingular <> " = newRecord @" <> model <> "\n" - <> " " <> modelVariableSingular <> "\n" + <> " " <> modelVariableSingular <> "\n" <> " |> build" <> singularName <> "\n" <> " |> ifValid \\case\n" <> " Left " <> modelVariableSingular <> " -> render NewView { .. } \n" @@ -195,7 +194,7 @@ pathToModuleName :: Text -> Text pathToModuleName moduleName = Text.replace "." "/" moduleName generateViews :: [Statement] -> Text -> Text -> [GeneratorAction] -generateViews schema applicationName controllerName' = +generateViews schema applicationName controllerName' = if null controllerName' then [] else do @@ -213,4 +212,3 @@ generateViews schema applicationName controllerName' = isAlphaOnly :: Text -> Bool isAlphaOnly text = Text.all (\c -> Char.isAlpha c || c == '_') text - diff --git a/IHP/IDE/CodeGen/ViewGenerator.hs b/IHP/IDE/CodeGen/ViewGenerator.hs index 94352881a..1959718d5 100644 --- a/IHP/IDE/CodeGen/ViewGenerator.hs +++ b/IHP/IDE/CodeGen/ViewGenerator.hs @@ -12,7 +12,7 @@ import IHP.IDE.SchemaDesigner.Types import qualified Text.Countable as Countable data ViewConfig = ViewConfig - { controllerName :: Text + { controllerName :: Text , applicationName :: Text , modelName :: Text , viewName :: Text @@ -22,7 +22,7 @@ buildPlan :: Text -> Text -> Text -> IO (Either Text [GeneratorAction]) buildPlan viewName applicationName controllerName' = if (null viewName || null controllerName') then pure $ Left "View name and controller name cannot be empty" - else do + else do schema <- SchemaDesigner.parseSchemaSql >>= \case Left parserError -> pure [] Right statements -> pure statements @@ -37,8 +37,8 @@ qualifiedViewModuleName config viewName = get #applicationName config <> ".View." <> get #controllerName config <> "." <> viewName buildPlan' :: [Statement] -> ViewConfig -> [GeneratorAction] -buildPlan' schema config = - let +buildPlan' schema config = + let controllerName = get #controllerName config name = get #viewName config singularName = config |> get #modelName @@ -48,7 +48,7 @@ buildPlan' schema config = then name else name <> "View" --e.g. "Test" -> "TestView" nameWithoutSuffix = if "View" `isSuffixOf` name - then Text.replace "View" "" name + then Text.replace "View" "" name else name --e.g. "TestView" -> "Test" indexAction = Countable.pluralize singularName <> "Action" @@ -68,8 +68,8 @@ buildPlan' schema config = <> "module " <> qualifiedViewModuleName config nameWithoutSuffix <> " where\n" <> "import " <> get #applicationName config <> ".View.Prelude\n" <> "\n" - - genericView = + + genericView = viewHeader <> "data " <> nameWithSuffix <> " = " <> nameWithSuffix <> "\n" <> "\n" @@ -84,7 +84,7 @@ buildPlan' schema config = <> "

" <> nameWithSuffix <> "

\n" <> " |]\n" - showView = + showView = viewHeader <> "data ShowView = ShowView { " <> singularVariableName <> " :: " <> singularName <> " }\n" <> "\n" @@ -99,7 +99,7 @@ buildPlan' schema config = <> "

Show " <> singularName <> "

\n" <> " |]\n" - newView = + newView = viewHeader <> "data NewView = NewView { " <> singularVariableName <> " :: " <> singularName <> " }\n" <> "\n" @@ -121,7 +121,7 @@ buildPlan' schema config = <> " {submitButton}\n" <> "|]\n" - editView = + editView = viewHeader <> "data EditView = EditView { " <> singularVariableName <> " :: " <> singularName <> " }\n" <> "\n" @@ -143,7 +143,7 @@ buildPlan' schema config = <> " {submitButton}\n" <> "|]\n" - indexView = + indexView = viewHeader <> "data IndexView = IndexView { " <> pluralVariableName <> " :: [" <> singularName <> "] }\n" <> "\n" diff --git a/IHP/IDE/SchemaDesigner/Compiler.hs b/IHP/IDE/SchemaDesigner/Compiler.hs index 494bad13c..4c09e86f1 100644 --- a/IHP/IDE/SchemaDesigner/Compiler.hs +++ b/IHP/IDE/SchemaDesigner/Compiler.hs @@ -22,13 +22,17 @@ compileSql statements = statements |> unlines compileStatement :: Statement -> Text -compileStatement CreateTable { name, columns, constraints } = "CREATE TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map compileColumn columns <> map (indent . compileConstraint) constraints) <> "\n);" +compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints }) = "CREATE TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map compileColumn columns <> [indent (compilePrimaryKeyConstraint primaryKeyConstraint)] <> map (indent . compileConstraint) constraints) <> "\n);" compileStatement CreateEnumType { name, values } = "CREATE TYPE " <> compileIdentifier name <> " AS ENUM (" <> intercalate ", " (values |> map TextExpression |> map compileExpression) <> ");" compileStatement CreateExtension { name, ifNotExists } = "CREATE EXTENSION " <> (if ifNotExists then "IF NOT EXISTS " else "") <> "\"" <> compileIdentifier name <> "\";" compileStatement AddConstraint { tableName, constraintName, constraint } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD CONSTRAINT " <> compileIdentifier constraintName <> " " <> compileConstraint constraint <> ";" compileStatement Comment { content } = "-- " <> content compileStatement UnknownStatement { raw } = raw +compilePrimaryKeyConstraint :: PrimaryKeyConstraint -> Text +compilePrimaryKeyConstraint PrimaryKeyConstraint { primaryKeyColumnNames } = + "PRIMARY KEY(" <> intercalate ", " primaryKeyColumnNames <> ")" + compileConstraint :: Constraint -> Text compileConstraint ForeignKeyConstraint { columnName, referenceTable, referenceColumn, onDelete } = "FOREIGN KEY (" <> compileIdentifier columnName <> ") REFERENCES " <> compileIdentifier referenceTable <> (if isJust referenceColumn then " (" <> fromJust referenceColumn <> ")" else "") <> " " <> compileOnDelete onDelete compileConstraint UniqueConstraint { columnNames } = "UNIQUE(" <> intercalate ", " columnNames <> ")" @@ -41,12 +45,11 @@ compileOnDelete (Just SetNull) = "ON DELETE SET NULL" compileOnDelete (Just Cascade) = "ON DELETE CASCADE" compileColumn :: Column -> Text -compileColumn Column { name, columnType, primaryKey, defaultValue, notNull, isUnique } = +compileColumn Column { name, columnType, defaultValue, notNull, isUnique } = " " <> unwords (catMaybes [ Just (compileIdentifier name) , Just (compilePostgresType columnType) , fmap compileDefaultValue defaultValue - , if primaryKey then Just "PRIMARY KEY" else Nothing , if notNull then Just "NOT NULL" else Nothing , if isUnique then Just "UNIQUE" else Nothing ]) @@ -59,7 +62,7 @@ compileExpression (TextExpression value) = "'" <> value <> "'" compileExpression (VarExpression name) = name compileExpression (CallExpression func args) = func <> "(" <> intercalate ", " (map compileExpression args) <> ")" -compareStatement (CreateTable {}) _ = LT +compareStatement (StatementCreateTable CreateTable {}) _ = LT compareStatement (AddConstraint {}) _ = GT compareStatement _ _ = EQ diff --git a/IHP/IDE/SchemaDesigner/Controller/Columns.hs b/IHP/IDE/SchemaDesigner/Controller/Columns.hs index 1434f8378..a36ffec20 100644 --- a/IHP/IDE/SchemaDesigner/Controller/Columns.hs +++ b/IHP/IDE/SchemaDesigner/Controller/Columns.hs @@ -21,11 +21,11 @@ import IHP.IDE.SchemaDesigner.Controller.Schema import IHP.IDE.SchemaDesigner.Controller.Helper instance Controller ColumnsController where - + action NewColumnAction { tableName } = do statements <- readSchema let (Just table) = findStatementByName tableName statements - primaryKeyExists <- hasPrimaryKey table + let primaryKeyExists = hasPrimaryKey table let tableNames = nameList (getCreateTable statements) let enumNames = nameList (getCreateEnum statements) render NewColumnView { .. } @@ -43,12 +43,11 @@ instance Controller ColumnsController where let column = Column { name = columnName , columnType = param "columnType" - , primaryKey = (param "primaryKey") , defaultValue = defaultValue , notNull = (not (param "allowNull")) , isUnique = param "isUnique" } - updateSchema (map (addColumnToTable tableName column)) + updateSchema (map (addColumnToTable tableName column (param "primaryKey"))) when (param "isReference") do let columnName = param "name" let constraintName = tableName <> "_ref_" <> columnName @@ -62,9 +61,9 @@ instance Controller ColumnsController where let name = tableName statements <- readSchema let (Just table) = findStatementByName name statements - primaryKeyExists <- hasPrimaryKey table + let primaryKeyExists = hasPrimaryKey table let table = findStatementByName tableName statements - let columns = maybe [] (get #columns) table + let columns = maybe [] (get #columns . unsafeGetCreateTable) table let column = columns !! columnId let enumNames = nameList (getCreateEnum statements) render EditColumnView { .. } @@ -81,12 +80,11 @@ instance Controller ColumnsController where redirectTo ShowTableAction { .. } let defaultValue = getDefaultValue (param "columnType") (param "defaultValue") let table = findStatementByName tableName statements - let columns = maybe [] (get #columns) table + let columns = maybe [] (get #columns . unsafeGetCreateTable) table let columnId = param "columnId" let column = Column { name = columnName , columnType = param "columnType" - , primaryKey = (param "primaryKey") , defaultValue = defaultValue , notNull = (not (param "allowNull")) , isUnique = param "isUnique" @@ -94,7 +92,7 @@ instance Controller ColumnsController where when ((get #name column) == "") do setErrorMessage ("Column Name can not be empty") redirectTo ShowTableAction { tableName } - updateSchema (map (updateColumnInTable tableName column columnId)) + updateSchema (map (updateColumnInTable tableName column (param "primaryKey") columnId)) redirectTo ShowTableAction { .. } action DeleteColumnAction { .. } = do @@ -172,24 +170,44 @@ instance Controller ColumnsController where updateSchema (deleteForeignKeyConstraint constraintName) redirectTo ShowTableAction { .. } -addColumnToTable :: Text -> Column -> Statement -> Statement -addColumnToTable tableName column (table@CreateTable { name, columns }) | name == tableName = - table { columns = columns <> [column] } -addColumnToTable tableName column statement = statement - -updateColumnInTable :: Text -> Column -> Int -> Statement -> Statement -updateColumnInTable tableName column columnId (table@CreateTable { name, columns }) | name == tableName = - table { columns = (replace columnId column columns) } -updateColumnInTable tableName column columnId statement = statement +addColumnToTable :: Text -> Column -> Bool -> Statement -> Statement +addColumnToTable tableName (column@Column { name = columnName }) isPrimaryKey (StatementCreateTable table@CreateTable { name, columns, primaryKeyConstraint = PrimaryKeyConstraint pks}) + | name == tableName = + let primaryKeyConstraint = + if isPrimaryKey + then PrimaryKeyConstraint (pks <> [columnName]) + else PrimaryKeyConstraint pks + in StatementCreateTable (table { columns = columns <> [column] , primaryKeyConstraint }) +addColumnToTable tableName column isPrimaryKey statement = statement + +updateColumnInTable :: Text -> Column -> Bool -> Int -> Statement -> Statement +updateColumnInTable tableName column isPrimaryKey columnId (StatementCreateTable table@CreateTable { name, columns, primaryKeyConstraint }) + | name == tableName = StatementCreateTable $ + table + { columns = (replace columnId column columns) + , primaryKeyConstraint = updatePrimaryKeyConstraint column isPrimaryKey primaryKeyConstraint + } +updateColumnInTable tableName column isPrimaryKey columnId statement = statement + +-- | Add or remove a column from the primary key constraint +updatePrimaryKeyConstraint :: Column -> Bool -> PrimaryKeyConstraint -> PrimaryKeyConstraint +updatePrimaryKeyConstraint Column { name } isPrimaryKey primaryKeyConstraint@PrimaryKeyConstraint { primaryKeyColumnNames } = + case (isPrimaryKey, name `elem` primaryKeyColumnNames) of + (False, False) -> primaryKeyConstraint + (False, True) -> PrimaryKeyConstraint (filter (/= name) primaryKeyColumnNames) + (True, False) -> PrimaryKeyConstraint (primaryKeyColumnNames <> [name]) + (True, True) -> primaryKeyConstraint toggleUniqueInColumn :: Text -> Int -> Statement -> Statement -toggleUniqueInColumn tableName columnId (table@CreateTable { name, columns }) | name == tableName = - table { columns = (replace columnId ((columns !! columnId) { isUnique = (not (get #isUnique (columns !! columnId))) }) columns) } +toggleUniqueInColumn tableName columnId (StatementCreateTable table@CreateTable { name, columns }) + | name == tableName = StatementCreateTable $ + table { columns = (replace columnId ((columns !! columnId) { isUnique = (not (get #isUnique (columns !! columnId))) }) columns) } toggleUniqueInColumn tableName columnId statement = statement deleteColumnInTable :: Text -> Int -> Statement -> Statement -deleteColumnInTable tableName columnId (table@CreateTable { name, columns }) | name == tableName = - table { columns = delete (columns !! columnId) columns} +deleteColumnInTable tableName columnId (StatementCreateTable table@CreateTable { name, columns }) + | name == tableName = StatementCreateTable $ + table { columns = delete (columns !! columnId) columns} deleteColumnInTable tableName columnId statement = statement addForeignKeyConstraint :: Text -> Text -> Text -> Text -> OnDelete -> [Statement] -> [Statement] @@ -202,7 +220,7 @@ deleteForeignKeyConstraint :: Text -> [Statement] -> [Statement] deleteForeignKeyConstraint constraintName list = filter (\con -> not (con == AddConstraint { tableName = get #tableName con, constraintName = constraintName, constraint = get #constraint con })) list getCreateTable statements = filter isCreateTable statements -isCreateTable CreateTable {} = True +isCreateTable (StatementCreateTable CreateTable {}) = True isCreateTable _ = False getCreateEnum statements = filter isCreateEnumType statements @@ -211,15 +229,7 @@ isCreateEnumType _ = False nameList statements = map (get #name) statements -hasPrimaryKey CreateTable { columns } = do - let primaryKey = find (\col -> col == Column { name = get #name col - , columnType = get #columnType col - , primaryKey = True - , defaultValue = get #defaultValue col - , notNull = get #notNull col - , isUnique = get #isUnique col - }) columns - case primaryKey of - Nothing -> pure False - _ -> pure True -hasPrimaryKey _ = pure False \ No newline at end of file +hasPrimaryKey (StatementCreateTable CreateTable { primaryKeyConstraint }) = + case primaryKeyConstraint of + PrimaryKeyConstraint [] -> False + _ -> True diff --git a/IHP/IDE/SchemaDesigner/Controller/Tables.hs b/IHP/IDE/SchemaDesigner/Controller/Tables.hs index ff34afec4..be08b4f68 100644 --- a/IHP/IDE/SchemaDesigner/Controller/Tables.hs +++ b/IHP/IDE/SchemaDesigner/Controller/Tables.hs @@ -72,20 +72,26 @@ instance Controller TablesController where addTable :: Text -> [Statement] -> [Statement] -addTable tableName list = list <> [CreateTable { name = tableName, columns = [Column - { name = "id" - , columnType = PUUID - , primaryKey = True - , defaultValue = Just (CallExpression "uuid_generate_v4" []) - , notNull = True - , isUnique = False - }], constraints = [] }] +addTable tableName list = list <> [StatementCreateTable CreateTable + { name = tableName + , columns = + [Column + { name = "id" + , columnType = PUUID + , defaultValue = Just (CallExpression "uuid_generate_v4" []) + , notNull = True + , isUnique = False + }] + , primaryKeyConstraint = PrimaryKeyConstraint ["id"] + , constraints = [] + }] updateTable :: Int -> Text -> [Statement] -> [Statement] -updateTable tableId tableName list = replace tableId CreateTable { name = tableName, columns = (get #columns (list !! tableId)), constraints = (get #constraints (list !! tableId)) } list +updateTable tableId tableName list = replace tableId (StatementCreateTable CreateTable { name = tableName, columns = get #columns table, primaryKeyConstraint = get #primaryKeyConstraint table, constraints = get #constraints table }) list + where table = unsafeGetCreateTable (list !! tableId) deleteTable :: Int -> [Statement] -> [Statement] deleteTable tableId list = delete (list !! tableId) list deleteForeignKeyConstraints :: Text -> [Statement] -> [Statement] -deleteForeignKeyConstraints tableName list = filter (\con -> not (con == AddConstraint { tableName = tableName, constraintName = get #constraintName con, constraint = get #constraint con })) list \ No newline at end of file +deleteForeignKeyConstraints tableName list = filter (\con -> not (con == AddConstraint { tableName = tableName, constraintName = get #constraintName con, constraint = get #constraint con })) list diff --git a/IHP/IDE/SchemaDesigner/Parser.hs b/IHP/IDE/SchemaDesigner/Parser.hs index d8d6b8e5d..0abe8e691 100644 --- a/IHP/IDE/SchemaDesigner/Parser.hs +++ b/IHP/IDE/SchemaDesigner/Parser.hs @@ -55,9 +55,9 @@ stringLiteral = char '\'' *> manyTill Lexer.charLiteral (char '\'') parseDDL :: Parser [Statement] parseDDL = manyTill statement eof - + statement = do - s <- try createExtension <|> try createTable <|> createEnumType <|> addConstraint <|> comment + s <- try createExtension <|> try (StatementCreateTable <$> createTable) <|> createEnumType <|> addConstraint <|> comment space pure s @@ -77,11 +77,32 @@ createTable = do lexeme "public" char '.' name <- identifier - (columns, constraints) <- between (char '(' >> space) (char ')' >> space) do + + -- Process columns (tagged if they're primary key) and table constraints + -- together, as they can be in any order + (taggedColumns, allConstraints) <- between (char '(' >> space) (char ')' >> space) do columnsAndConstraints <- ((Right <$> parseTableConstraint) <|> (Left <$> column)) `sepBy` (char ',' >> space) pure (lefts columnsAndConstraints, rights columnsAndConstraints) + char ';' - pure CreateTable { name, columns, constraints } + + -- Check that either there is a single column with a PRIMARY KEY constraint, + -- or there is a single PRIMARY KEY table constraint + let + columns = map snd taggedColumns + constraints = rights allConstraints + + primaryKeyConstraint <- case filter fst taggedColumns of + [] -> case lefts allConstraints of + [] -> Prelude.fail ("No primary key defined for table " <> cs name) + [primaryKeyConstraint] -> pure primaryKeyConstraint + _ -> Prelude.fail ("Multiple PRIMARY KEY constraints on table " <> cs name) + [(_, Column { name })] -> case lefts allConstraints of + [] -> pure $ PrimaryKeyConstraint [name] + _ -> Prelude.fail ("Primary key defined in both column and table constraints on table " <> cs name) + _ -> Prelude.fail "Multiple columns with PRIMARY KEY constraint" + + pure CreateTable { name, columns, primaryKeyConstraint, constraints } createEnumType = do lexeme "CREATE" @@ -100,23 +121,24 @@ addConstraint = do lexeme "ADD" lexeme "CONSTRAINT" constraintName <- identifier - constraint <- parseTableConstraint + constraint <- parseTableConstraint >>= \case + Left _ -> Prelude.fail "Cannot add new PRIMARY KEY constraint to table" + Right constraint -> pure constraint char ';' pure AddConstraint { tableName, constraintName, constraint } parseTableConstraint = do - optional do - lexeme "CONSTRAINT" - identifier - parsePrimaryKeyConstraint - <|> parseForeignKeyConstraint - <|> parseUniqueConstraint + optional do + lexeme "CONSTRAINT" + identifier + (Left <$> parsePrimaryKeyConstraint) <|> + (Right <$> (parseForeignKeyConstraint <|> parseUniqueConstraint)) parsePrimaryKeyConstraint = do lexeme "PRIMARY" lexeme "KEY" - columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space)) - pure PrimaryKeyConstraint { columnNames } + primaryKeyColumnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space)) + pure PrimaryKeyConstraint { primaryKeyColumnNames } parseForeignKeyConstraint = do lexeme "FOREIGN" @@ -154,7 +176,7 @@ column = do primaryKey <- isJust <$> optional (lexeme "PRIMARY" >> lexeme "KEY") notNull <- isJust <$> optional (lexeme "NOT" >> lexeme "NULL") isUnique <- isJust <$> optional (lexeme "UNIQUE") - pure Column { name, columnType, primaryKey, defaultValue, notNull, isUnique } + pure (primaryKey, Column { name, columnType, defaultValue, notNull, isUnique }) sqlType :: Parser PostgresType sqlType = choice diff --git a/IHP/IDE/SchemaDesigner/Types.hs b/IHP/IDE/SchemaDesigner/Types.hs index 253819104..57ac1bc2c 100644 --- a/IHP/IDE/SchemaDesigner/Types.hs +++ b/IHP/IDE/SchemaDesigner/Types.hs @@ -8,9 +8,9 @@ module IHP.IDE.SchemaDesigner.Types where import IHP.Prelude data Statement - = + = -- | CREATE TABLE name ( columns ); - CreateTable { name :: Text, columns :: [Column], constraints :: [Constraint] } + StatementCreateTable { unsafeGetCreateTable :: CreateTable } -- | CREATE TYPE name AS ENUM ( values ); | CreateEnumType { name :: Text, values :: [Text] } -- | CREATE EXTENSION IF NOT EXISTS "name"; @@ -21,10 +21,18 @@ data Statement | Comment { content :: Text } deriving (Eq, Show) +data CreateTable + = CreateTable + { name :: Text + , columns :: [Column] + , primaryKeyConstraint :: PrimaryKeyConstraint + , constraints :: [Constraint] + } + deriving (Eq, Show) + data Column = Column { name :: Text , columnType :: PostgresType - , primaryKey :: Bool , defaultValue :: Maybe Expression , notNull :: Bool , isUnique :: Bool @@ -38,6 +46,10 @@ data OnDelete | Cascade deriving (Show, Eq) +newtype PrimaryKeyConstraint + = PrimaryKeyConstraint { primaryKeyColumnNames :: [Text] } + deriving (Eq, Show) + data Constraint -- | FOREIGN KEY (columnName) REFERENCES referenceTable (referenceColumn) ON DELETE onDelete; = ForeignKeyConstraint @@ -46,8 +58,6 @@ data Constraint , referenceColumn :: Maybe Text , onDelete :: Maybe OnDelete } - | PrimaryKeyConstraint - { columnNames :: [Text] } | UniqueConstraint { columnNames :: [Text] } deriving (Eq, Show) diff --git a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs index 200f7654e..fa4521f93 100644 --- a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs +++ b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs @@ -20,7 +20,7 @@ data EditColumnView = EditColumnView instance View EditColumnView ViewContext where beforeRender (context, view) = (context { layout = schemaDesignerLayout }, view) - html EditColumnView { .. } = [hsx| + html EditColumnView { column = column@Column { name }, .. } = [hsx|
{renderObjectSelector (zip [0..] statements) (Just tableName)} {renderColumnSelector tableName (zip [0..] columns) statements} @@ -29,20 +29,23 @@ instance View EditColumnView ViewContext where |] where table = findStatementByName tableName statements - columns = maybe [] (get #columns) table + columns = maybe [] (get #columns . unsafeGetCreateTable) table + primaryKeyColumns = maybe [] (primaryKeyColumnNames . get #primaryKeyConstraint . unsafeGetCreateTable) table - - - primaryKeyCheckbox = if get #primaryKey column - then preEscapedToHtml [plain|
|] - modalFooter = mempty + modalFooter = mempty modalCloseUrl = pathTo ShowTableRowsAction { tableName } modalTitle = "Add Row" modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle } @@ -60,13 +60,13 @@ instance View NewRowView ViewContext where {get #columnType col} - + |] - onClick tableName fieldName id = "window.location.assign(" <> tshow (pathTo (ToggleBooleanFieldAction tableName (cs fieldName) id)) <> ")" \ No newline at end of file + onClick tableName fieldName id = "window.location.assign(" <> tshow (pathTo (ToggleBooleanFieldAction tableName (cs fieldName) id)) <> ")" diff --git a/IHP/IDE/Data/View/ShowTableRows.hs b/IHP/IDE/Data/View/ShowTableRows.hs index 036fccbc7..ffd0d6eed 100644 --- a/IHP/IDE/Data/View/ShowTableRows.hs +++ b/IHP/IDE/Data/View/ShowTableRows.hs @@ -16,6 +16,7 @@ data ShowTableRowsView = ShowTableRowsView , tableName :: Text , rows :: [[DynamicField]] , tableCols :: [ColumnDefinition] + , primaryKeyFields :: [Text] } instance View ShowTableRowsView ViewContext where @@ -36,20 +37,21 @@ instance View ShowTableRowsView ViewContext where where tableBody = [hsx|{forEach rows renderRow}|] - renderRow fields = [hsx| contextMenuId <> "'); event.stopPropagation();"}>{forEach fields (renderField id)} + renderRow fields = [hsx| contextMenuId <> "'); event.stopPropagation();"}>{forEach fields (renderField primaryKey)} |] where - contextMenuId = "context-menu-column-" <> tshow id - id = (cs (fromMaybe "" (get #fieldValue (fromJust (headMay fields))))) - renderField id DynamicField { .. } | fieldName == "id" = [hsx|{renderId (sqlValueToText fieldValue)}|] - renderField id DynamicField { .. } | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx||] - renderField id DynamicField { .. } = [hsx|{sqlValueToText fieldValue}|] + contextMenuId = "context-menu-column-" <> tshow primaryKey + primaryKey = intercalate "---" . map (cs . fromMaybe "" . get #fieldValue) $ filter ((`elem` primaryKeyFields) . cs . get #fieldName) fields + renderField primaryKey DynamicField { .. } + | fieldName == "id" = [hsx|{renderId (sqlValueToText fieldValue)}|] + | isBoolField fieldName tableCols && not (isNothing fieldValue) = [hsx||] + | otherwise = [hsx|{sqlValueToText fieldValue}|] columnNames = map (get #fieldName) (fromMaybe [] (head rows)) - onClick tableName fieldName id = "window.location.assign(" <> tshow (pathTo (ToggleBooleanFieldAction tableName (cs fieldName) id)) <> ")" + onClick tableName fieldName primaryKey = "window.location.assign(" <> tshow (pathTo (ToggleBooleanFieldAction tableName (cs fieldName) primaryKey)) <> ")" diff --git a/IHP/IDE/ToolServer/Types.hs b/IHP/IDE/ToolServer/Types.hs index 354897e0e..f33c46b84 100644 --- a/IHP/IDE/ToolServer/Types.hs +++ b/IHP/IDE/ToolServer/Types.hs @@ -76,13 +76,13 @@ data DataController = ShowDatabaseAction | ShowTableRowsAction { tableName :: Text } | ShowQueryAction - | DeleteEntryAction { fieldValue :: Text, tableName :: Text } + | DeleteEntryAction { primaryKey :: Text, tableName :: Text } | CreateRowAction | NewRowAction { tableName :: Text } - | EditRowAction { tableName :: Text, id :: Text } + | EditRowAction { tableName :: Text, targetPrimaryKey :: Text } | UpdateRowAction - | EditRowValueAction { tableName :: Text, targetName :: Text, id :: Text } - | ToggleBooleanFieldAction { tableName :: Text, targetName :: Text, id :: Text } + | EditRowValueAction { tableName :: Text, targetName :: Text, targetPrimaryKey :: Text } + | ToggleBooleanFieldAction { tableName :: Text, targetName :: Text, targetPrimaryKey :: Text } deriving (Eq, Show, Data) data LogsController @@ -118,6 +118,6 @@ data ColumnDefinition = ColumnDefinition , columnDefault :: Maybe Text } deriving (Show) -instance FrameworkConfig where +instance FrameworkConfig where environment = Development - appHostname = "localhost" \ No newline at end of file + appHostname = "localhost" diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 5c9aa99fe..6a85665d8 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -603,8 +603,8 @@ compileUpdateFieldInstances table@(CreateTable { name, columns }) = unlines (map compileTypePattern' name = tableNameToModelName (get #name table) <> "' " <> unwords (map (\f -> if f == name then name <> "'" else f) (dataTypeArguments table)) compileHasFieldId :: (?schema :: Schema) => CreateTable -> Text -compileHasFieldId table@CreateTable { primaryKeyConstraint } = cs [i| -instance HasField "id" Picture (Id' "pictures") where +compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i| +instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where getField (#{compileDataTypePattern table}) = #{compilePrimaryKeyValue} |] where From c85ce39c7e59695e47a9d314f5aeb8a07a6bcbde Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Tue, 25 Aug 2020 20:07:52 +0100 Subject: [PATCH 06/10] [#291] Get code compiling after rebase onto master --- IHP/IDE/CodeGen/Types.hs | 14 +++++++------- IHP/SchemaCompiler.hs | 6 +++--- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/IHP/IDE/CodeGen/Types.hs b/IHP/IDE/CodeGen/Types.hs index c0bb3575e..a586da4b5 100644 --- a/IHP/IDE/CodeGen/Types.hs +++ b/IHP/IDE/CodeGen/Types.hs @@ -20,8 +20,8 @@ data GeneratorAction fieldsForTable :: [Statement] -> Text -> [Text] fieldsForTable database name = case getTable database name of - Just (CreateTable { columns }) -> columns - |> filter columnRelevantForCreateOrEdit + Just (StatementCreateTable CreateTable { columns, primaryKeyConstraint }) -> columns + |> filter (columnRelevantForCreateOrEdit primaryKeyConstraint) |> map (get #name) |> map columnNameToFieldName _ -> [] @@ -29,17 +29,17 @@ fieldsForTable database name = -- | Returns True when a column should be part of the generated controller or forms -- -- Returrns @False@ for primary keys, or fields such as @created_at@ -columnRelevantForCreateOrEdit :: Column -> Bool -columnRelevantForCreateOrEdit column +columnRelevantForCreateOrEdit :: PrimaryKeyConstraint -> Column -> Bool +columnRelevantForCreateOrEdit _ column | (get #columnType column == PTimestamp || get #columnType column == PTimestampWithTimezone) && (isJust (get #defaultValue column)) = False -columnRelevantForCreateOrEdit column = not (get #primaryKey column) +columnRelevantForCreateOrEdit (PrimaryKeyConstraint primaryKeyColumns) column = + get #name column `notElem` primaryKeyColumns getTable :: [Statement] -> Text -> Maybe Statement getTable schema name = find isTable schema where isTable :: Statement -> Bool - isTable table@(CreateTable { name = name' }) | name == name' = True + isTable table@(StatementCreateTable CreateTable { name = name' }) | name == name' = True isTable _ = False - diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 6a85665d8..14d90a5a3 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -432,7 +432,7 @@ instance FromRow #{modelName} where isColumn name = name `elem` columnNames isManyToManyField fieldName = fieldName `elem` (referencing |> map (columnNameToFieldName . fst)) - compileSetQueryBuilder (refTableName, refFieldName) = "pure (QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" + compileSetQueryBuilder (refTableName, refFieldName) = "(QueryBuilder.filterWhere (#" <> columnNameToFieldName refFieldName <> ", " <> primaryKeyField <> ") (QueryBuilder.query @" <> tableNameToModelName refTableName <> "))" where -- | When the referenced column is nullable, we have to wrap the @Id@ in @Just@ primaryKeyField :: Text @@ -441,12 +441,12 @@ instance FromRow #{modelName} where (Just refTable) = let (Schema statements) = ?schema in statements |> find \case - CreateTable { name } -> name == refTableName + StatementCreateTable CreateTable { name } -> name == refTableName otherwise -> False refColumn :: Column refColumn = refTable - |> \case CreateTable { columns } -> columns + |> \case StatementCreateTable CreateTable { columns } -> columns |> find (\col -> get #name col == refFieldName) |> \case Just refColumn -> refColumn From e0466f956b9381a98e51b6d69f94442a2e55e959 Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Sun, 30 Aug 2020 18:23:48 +0100 Subject: [PATCH 07/10] [#291] Get Fetchable working with composite primary keys --- IHP/LoginSupport/Middleware.hs | 5 +-- IHP/QueryBuilder.hs | 56 +++++++++++++++++++++++++++------- IHP/SchemaCompiler.hs | 21 +++++++++++-- 3 files changed, 67 insertions(+), 15 deletions(-) diff --git a/IHP/LoginSupport/Middleware.hs b/IHP/LoginSupport/Middleware.hs index cb7230d1c..cf5bbcfca 100644 --- a/IHP/LoginSupport/Middleware.hs +++ b/IHP/LoginSupport/Middleware.hs @@ -20,15 +20,16 @@ import IHP.ModelSupport initAuthentication :: forall user. ( ?requestContext :: RequestContext , ?modelContext :: ModelContext - , HasField "id" (NormalizeModel user) (Id user) , Typeable (NormalizeModel user) , KnownSymbol (GetTableName (NormalizeModel user)) , KnownSymbol (GetModelName user) + , GetTableName (NormalizeModel user) ~ GetTableName user , FromRow (NormalizeModel user) , PrimaryKey (GetTableName user) ~ UUID + , FilterPrimaryKey (NormalizeModel user) ) => TypeMap.TMap -> IO TypeMap.TMap initAuthentication context = do user <- getSessionUUID (sessionKey @user) >>= pure . fmap (Newtype.pack @(Id user)) >>= fetchOneOrNothing - pure (TypeMap.insert @(Maybe (NormalizeModel user)) user context) \ No newline at end of file + pure (TypeMap.insert @(Maybe (NormalizeModel user)) user context) diff --git a/IHP/QueryBuilder.hs b/IHP/QueryBuilder.hs index 32102253f..ffdf3e2ce 100644 --- a/IHP/QueryBuilder.hs +++ b/IHP/QueryBuilder.hs @@ -9,7 +9,37 @@ creation of sql queries in a type safe way. For more complex sql queries, use 'IHP.ModelSupport.sqlQuery'. -} -module IHP.QueryBuilder (query, findManyBy, findMaybeBy, filterWhere, QueryBuilder, findBy, In (In), orderBy, orderByAsc, orderByDesc, queryUnion, queryOr, DefaultScope (..), filterWhereIn, filterWhereNotIn, genericFetchId, genericfetchIdOneOrNothing, genericFetchIdOne, Fetchable (..), include, genericFetchIds, genericfetchIdsOneOrNothing, genericFetchIdsOne, EqOrIsOperator, fetchCount, filterWhereSql, fetchExists) where +module IHP.QueryBuilder + ( query + , findManyBy + , findMaybeBy + , filterWhere + , QueryBuilder + , findBy + , In (In) + , orderBy + , orderByAsc + , orderByDesc + , queryUnion + , queryOr + , DefaultScope (..) + , filterWhereIn + , filterWhereNotIn + , genericFetchId + , genericfetchIdOneOrNothing + , genericFetchIdOne + , Fetchable (..) + , include + , genericFetchIds + , genericfetchIdsOneOrNothing + , genericFetchIdsOne + , EqOrIsOperator + , fetchCount + , filterWhereSql + , fetchExists + , FilterPrimaryKey (..) + ) +where import IHP.Prelude import Database.PostgreSQL.Simple (Connection) @@ -199,14 +229,14 @@ fetchExists !queryBuilder = do {-# INLINE fetchExists #-} {-# INLINE genericFetchId #-} -genericFetchId :: forall model value. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value) => value -> IO [model] -genericFetchId !id = query @model |> filterWhere (#id, id) |> fetch +genericFetchId :: forall model. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, FilterPrimaryKey model) => Id model -> IO [model] +genericFetchId !id = query @model |> filterWhereId id |> fetch {-# INLINE genericfetchIdOneOrNothing #-} -genericfetchIdOneOrNothing :: forall model value. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value) => value -> IO (Maybe model) -genericfetchIdOneOrNothing !id = query @model |> filterWhere (#id, id) |> fetchOneOrNothing +genericfetchIdOneOrNothing :: forall model. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, FilterPrimaryKey model) => Id model -> IO (Maybe model) +genericfetchIdOneOrNothing !id = query @model |> filterWhereId id |> fetchOneOrNothing {-# INLINE genericFetchIdOne #-} -genericFetchIdOne :: forall model value. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value) => value -> IO model -genericFetchIdOne !id = query @model |> filterWhere (#id, id) |> fetchOne +genericFetchIdOne :: forall model. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, FilterPrimaryKey model) => Id model -> IO model +genericFetchIdOne !id = query @model |> filterWhereId id |> fetchOne {-# INLINE genericFetchIds #-} genericFetchIds :: forall model value. (KnownSymbol (GetTableName model), PG.FromRow model, ?modelContext :: ModelContext, ToField value, EqOrIsOperator value, HasField "id" model value) => [value] -> IO [model] @@ -266,17 +296,21 @@ class EqOrIsOperator value where toEqOrIsOperator :: value -> FilterOperator instance {-# OVERLAPS #-} EqOrIsOperator (Maybe something) where toEqOrIsOperator Nothing = IsOp; toEqOrIsOperator (Just _) = EqOp instance {-# OVERLAPPABLE #-} EqOrIsOperator otherwise where toEqOrIsOperator _ = EqOp + +class FilterPrimaryKey model where + filterWhereId :: Id model -> QueryBuilder model -> QueryBuilder model + -- | Adds a simple @WHERE x = y@ condition to the query. -- -- __Example:__ Only show projects where @active@ is @True@. --- +-- -- > activeProjects <- query @Project -- > |> filterWhere (#active, True) -- > |> fetch -- > -- SELECT * FROM projects WHERE active = True -- -- __Example:__ Find book with title @Learn you a Haskell@. --- +-- -- > book <- query @Book -- > |> filterWhere (#title, "Learn you a Haskell") -- > |> fetchOne @@ -408,7 +442,7 @@ queryOr :: (qb ~ QueryBuilder model) => (qb -> qb) -> (qb -> qb) -> qb -> qb queryOr a b queryBuilder = a queryBuilder `UnionQueryBuilder` b queryBuilder {-# INLINE queryOr #-} -instance (model ~ GetModelById (Id' model'), HasField "id" model id, id ~ Id' model', ToField (PrimaryKey model')) => Fetchable (Id' model') model where +instance (model ~ GetModelById (Id' model'), GetTableName model ~ model', FilterPrimaryKey model) => Fetchable (Id' model') model where type FetchResult (Id' model') model = model {-# INLINE fetch #-} fetch = genericFetchIdOne @@ -417,7 +451,7 @@ instance (model ~ GetModelById (Id' model'), HasField "id" model id, id ~ Id' mo {-# INLINE fetchOne #-} fetchOne = genericFetchIdOne -instance (model ~ GetModelById (Id' model'), HasField "id" model id, id ~ Id' model', ToField (PrimaryKey model')) => Fetchable (Maybe (Id' model')) model where +instance (model ~ GetModelById (Id' model'), GetTableName model ~ model', FilterPrimaryKey model) => Fetchable (Maybe (Id' model')) model where type FetchResult (Maybe (Id' model')) model = [model] {-# INLINE fetch #-} fetch (Just a) = genericFetchId a diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 14d90a5a3..8d7a5bea6 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -147,6 +147,7 @@ compileStatement CompilerOptions { compileGetAndSetFieldInstances } (StatementCr <> compileHasTableNameInstance table <> compileGetModelName table <> compilePrimaryKeyInstance table + <> section <> compileInclude table <> compileCreate table <> section @@ -522,8 +523,13 @@ compileHasTableNameInstance table@(CreateTable { name }) = <> "type instance GetModelByTableName " <> tshow name <> " = " <> tableNameToModelName name <> "\n" compilePrimaryKeyInstance :: (?schema :: Schema) => CreateTable -> Text -compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = - "type instance PrimaryKey " <> tshow name <> " = " <> idType <> "\n" +compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = cs [i| +type instance PrimaryKey #{tshow name} = #{idType} + +instance QueryBuilder.FilterPrimaryKey #{tableNameToModelName name} where + filterWhereId #{primaryKeyPattern} builder = + builder |> #{intercalate " |> " primaryKeyFilters} +|] where idType :: Text idType = case primaryKeyColumns table of @@ -532,6 +538,17 @@ compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = cs -> "(" <> intercalate ", " (map colType cs) <> ")" where colType = atomicType . get #columnType + primaryKeyPattern = case primaryKeyColumns table of + [] -> error "Impossible happened in compilePrimaryKeyInstance" + [c] -> get #name c + cs -> "(Id (" <> intercalate ", " (map (columnNameToFieldName . get #name) cs) <> "))" + + primaryKeyFilters :: [Text] + primaryKeyFilters = map primaryKeyFilter $ primaryKeyColumns table + + primaryKeyFilter :: Column -> Text + primaryKeyFilter Column {name} = "QueryBuilder.filterWhere (#" <> columnNameToFieldName name <> ", " <> columnNameToFieldName name <> ")" + compileGetModelName :: (?schema :: Schema) => CreateTable -> Text compileGetModelName table@(CreateTable { name }) = "type instance GetModelName (" <> tableNameToModelName name <> "' " <> unwords (map (const "_") (dataTypeArguments table)) <> ") = " <> tshow (tableNameToModelName name) <> "\n" From c5706c8e3798d1060ef9612dad2d36cfc70bccd8 Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Sun, 30 Aug 2020 18:31:02 +0100 Subject: [PATCH 08/10] [#291] Skip code generation for tables with no primary key --- IHP/SchemaCompiler.hs | 49 +++++++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 23 deletions(-) diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs index 8d7a5bea6..96135cc3d 100644 --- a/IHP/SchemaCompiler.hs +++ b/IHP/SchemaCompiler.hs @@ -141,27 +141,30 @@ compileStatementPreview statements statement = let ?schema = Schema statements i compileStatement :: (?schema :: Schema) => CompilerOptions -> Statement -> Text compileStatement CompilerOptions { compileGetAndSetFieldInstances } (StatementCreateTable table) = - compileData table - <> compileTypeAlias table - <> compileFromRowInstance table - <> compileHasTableNameInstance table - <> compileGetModelName table - <> compilePrimaryKeyInstance table - <> section - <> compileInclude table - <> compileCreate table - <> section - <> compileUpdate table - <> section - <> compileBuild table - <> if needsHasFieldId table - then compileHasFieldId table - else "" - <> section - <> if compileGetAndSetFieldInstances - then compileSetFieldInstances table <> compileUpdateFieldInstances table - else "" - <> section + case primaryKeyConstraint table of + -- Skip generation of tables with no primary keys + PrimaryKeyConstraint [] -> "" + _ -> compileData table + <> compileTypeAlias table + <> compileFromRowInstance table + <> compileHasTableNameInstance table + <> compileGetModelName table + <> compilePrimaryKeyInstance table + <> section + <> compileInclude table + <> compileCreate table + <> section + <> compileUpdate table + <> section + <> compileBuild table + <> if needsHasFieldId table + then compileHasFieldId table + else "" + <> section + <> if compileGetAndSetFieldInstances + then compileSetFieldInstances table <> compileUpdateFieldInstances table + else "" + <> section compileStatement _ enum@(CreateEnumType {}) = compileEnumDataDefinitions enum compileStatement _ _ = "" @@ -533,13 +536,13 @@ instance QueryBuilder.FilterPrimaryKey #{tableNameToModelName name} where where idType :: Text idType = case primaryKeyColumns table of - [] -> error "Impossible happened in compilePrimaryKeyInstance" + [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required." [c] -> colType c cs -> "(" <> intercalate ", " (map colType cs) <> ")" where colType = atomicType . get #columnType primaryKeyPattern = case primaryKeyColumns table of - [] -> error "Impossible happened in compilePrimaryKeyInstance" + [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required." [c] -> get #name c cs -> "(Id (" <> intercalate ", " (map (columnNameToFieldName . get #name) cs) <> "))" From d16ec33ea6e2b24acf340ac03cdb2dd00a2a33f4 Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Sun, 30 Aug 2020 19:19:12 +0100 Subject: [PATCH 09/10] [#291] Get compiling after rebase onto master --- IHP/IDE/Data/Controller.hs | 4 ++-- IHP/IDE/Data/View/ShowTableRows.hs | 2 +- IHP/IDE/SchemaDesigner/Controller/Columns.hs | 15 +++++---------- IHP/IDE/SchemaDesigner/View/Columns/Edit.hs | 1 - IHP/IDE/SchemaDesigner/View/Columns/New.hs | 15 +++++---------- IHP/IDE/SchemaDesigner/View/Layout.hs | 2 +- 6 files changed, 14 insertions(+), 25 deletions(-) diff --git a/IHP/IDE/Data/Controller.hs b/IHP/IDE/Data/Controller.hs index f4b082099..07b21dffb 100644 --- a/IHP/IDE/Data/Controller.hs +++ b/IHP/IDE/Data/Controller.hs @@ -126,8 +126,8 @@ instance Controller DataController where tableNames <- fetchTableNames connection tableCols <- fetchTableCols connection tableName primaryKeyFields <- tablePrimaryKeyFields connection tableName - let targetPrimaryKeyValues = T.splitOn "---" targetPrimaryKey - let query = PG.Query ("UPDATE ? SET ? = NOT ? WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields)) + let targetPrimaryKeyValues = PG.Escape . cs <$> T.splitOn "---" targetPrimaryKey + let query = PG.Query . cs $! "UPDATE ? SET ? = NOT ? WHERE " <> intercalate " AND " ((<> " = ?") <$> primaryKeyFields) let params = [PG.toField $ PG.Identifier tableName, PG.toField $ PG.Identifier targetName, PG.toField $ PG.Identifier targetName] <> targetPrimaryKeyValues PG.execute connection query params PG.close connection diff --git a/IHP/IDE/Data/View/ShowTableRows.hs b/IHP/IDE/Data/View/ShowTableRows.hs index ffd0d6eed..aa1c9449e 100644 --- a/IHP/IDE/Data/View/ShowTableRows.hs +++ b/IHP/IDE/Data/View/ShowTableRows.hs @@ -40,7 +40,7 @@ instance View ShowTableRowsView ViewContext where renderRow fields = [hsx| contextMenuId <> "'); event.stopPropagation();"}>{forEach fields (renderField primaryKey)} |] diff --git a/IHP/IDE/SchemaDesigner/Controller/Columns.hs b/IHP/IDE/SchemaDesigner/Controller/Columns.hs index a36ffec20..959401a4f 100644 --- a/IHP/IDE/SchemaDesigner/Controller/Columns.hs +++ b/IHP/IDE/SchemaDesigner/Controller/Columns.hs @@ -25,7 +25,6 @@ instance Controller ColumnsController where action NewColumnAction { tableName } = do statements <- readSchema let (Just table) = findStatementByName tableName statements - let primaryKeyExists = hasPrimaryKey table let tableNames = nameList (getCreateTable statements) let enumNames = nameList (getCreateEnum statements) render NewColumnView { .. } @@ -61,7 +60,6 @@ instance Controller ColumnsController where let name = tableName statements <- readSchema let (Just table) = findStatementByName name statements - let primaryKeyExists = hasPrimaryKey table let table = findStatementByName tableName statements let columns = maybe [] (get #columns . unsafeGetCreateTable) table let column = columns !! columnId @@ -219,17 +217,14 @@ updateForeignKeyConstraint tableName columnName constraintName referenceTable on deleteForeignKeyConstraint :: Text -> [Statement] -> [Statement] deleteForeignKeyConstraint constraintName list = filter (\con -> not (con == AddConstraint { tableName = get #tableName con, constraintName = constraintName, constraint = get #constraint con })) list -getCreateTable statements = filter isCreateTable statements -isCreateTable (StatementCreateTable CreateTable {}) = True -isCreateTable _ = False +getCreateTable :: [Statement] -> [CreateTable] +getCreateTable statements = foldr step [] statements + where + step (StatementCreateTable createTable) createTables = createTable : createTables + step _ createTables = createTables getCreateEnum statements = filter isCreateEnumType statements isCreateEnumType CreateEnumType {} = True isCreateEnumType _ = False nameList statements = map (get #name) statements - -hasPrimaryKey (StatementCreateTable CreateTable { primaryKeyConstraint }) = - case primaryKeyConstraint of - PrimaryKeyConstraint [] -> False - _ -> True diff --git a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs index fa4521f93..7f5cdb559 100644 --- a/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs +++ b/IHP/IDE/SchemaDesigner/View/Columns/Edit.hs @@ -13,7 +13,6 @@ data EditColumnView = EditColumnView , tableName :: Text , columnId :: Int , column :: Column - , primaryKeyExists :: Bool , enumNames :: [Text] } diff --git a/IHP/IDE/SchemaDesigner/View/Columns/New.hs b/IHP/IDE/SchemaDesigner/View/Columns/New.hs index 33ac85290..1ab096e9a 100644 --- a/IHP/IDE/SchemaDesigner/View/Columns/New.hs +++ b/IHP/IDE/SchemaDesigner/View/Columns/New.hs @@ -12,7 +12,6 @@ import IHP.IDE.SchemaDesigner.View.Columns.Edit (typeSelector) data NewColumnView = NewColumnView { statements :: [Statement] , tableName :: Text - , primaryKeyExists :: Bool , tableNames :: [Text] , enumNames :: [Text] } @@ -57,13 +56,14 @@ instance View NewColumnView ViewContext where - {primaryKeyCheckbox} - +
- {defaultSelector} + {defaultSelector}
@@ -84,18 +84,13 @@ instance View NewColumnView ViewContext where References {tableName} |] - primaryKeyCheckbox = if primaryKeyExists - then mempty - else [hsx||] defaultSelector = [hsx| |] - modalFooter = mempty + modalFooter = mempty modalCloseUrl = pathTo ShowTableAction { tableName } modalTitle = "New Column" modal = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle } diff --git a/IHP/IDE/SchemaDesigner/View/Layout.hs b/IHP/IDE/SchemaDesigner/View/Layout.hs index 2d36a7f62..20c5e636c 100644 --- a/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -257,7 +257,7 @@ renderObjectSelector statements activeObjectName = [hsx| renderObject CreateExtension {} id = mempty renderObject statement id = [hsx|
{statement}
|] - shouldRenderObject CreateTable {} = True + shouldRenderObject (StatementCreateTable CreateTable {}) = True shouldRenderObject CreateEnumType {} = True shouldRenderObject _ = False From fe5fcf1bf497ce680c78153017366d0273bfa14b Mon Sep 17 00:00:00 2001 From: Ru Horlick Date: Fri, 4 Sep 2020 09:10:25 +0100 Subject: [PATCH 10/10] [#291] Add a special case for single column primary keys in compiler --- IHP/IDE/SchemaDesigner/Compiler.hs | 16 +++++++++++++--- Test/IDE/SchemaDesigner/CompilerSpec.hs | 11 +++++------ 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/IHP/IDE/SchemaDesigner/Compiler.hs b/IHP/IDE/SchemaDesigner/Compiler.hs index b24f1ee3a..9d52058dd 100644 --- a/IHP/IDE/SchemaDesigner/Compiler.hs +++ b/IHP/IDE/SchemaDesigner/Compiler.hs @@ -22,17 +22,19 @@ compileSql statements = statements |> unlines compileStatement :: Statement -> Text -compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints }) = "CREATE TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map compileColumn columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n);" +compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints }) = "CREATE TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map (compileColumn primaryKeyConstraint) columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n);" compileStatement CreateEnumType { name, values } = "CREATE TYPE " <> compileIdentifier name <> " AS ENUM (" <> intercalate ", " (values |> map TextExpression |> map compileExpression) <> ");" compileStatement CreateExtension { name, ifNotExists } = "CREATE EXTENSION " <> (if ifNotExists then "IF NOT EXISTS " else "") <> "\"" <> compileIdentifier name <> "\";" compileStatement AddConstraint { tableName, constraintName, constraint } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD CONSTRAINT " <> compileIdentifier constraintName <> " " <> compileConstraint constraint <> ";" compileStatement Comment { content } = "-- " <> content compileStatement UnknownStatement { raw } = raw +-- | Emit a PRIMARY KEY constraint when there are multiple primary key columns compilePrimaryKeyConstraint :: PrimaryKeyConstraint -> Maybe Text compilePrimaryKeyConstraint PrimaryKeyConstraint { primaryKeyColumnNames } = case primaryKeyColumnNames of [] -> Nothing + [_] -> Nothing names -> Just $ "PRIMARY KEY(" <> intercalate ", " names <> ")" compileConstraint :: Constraint -> Text @@ -46,15 +48,23 @@ compileOnDelete (Just Restrict) = "ON DELETE RESTRICT" compileOnDelete (Just SetNull) = "ON DELETE SET NULL" compileOnDelete (Just Cascade) = "ON DELETE CASCADE" -compileColumn :: Column -> Text -compileColumn Column { name, columnType, defaultValue, notNull, isUnique } = +compileColumn :: PrimaryKeyConstraint -> Column -> Text +compileColumn primaryKeyConstraint Column { name, columnType, defaultValue, notNull, isUnique } = " " <> unwords (catMaybes [ Just (compileIdentifier name) , Just (compilePostgresType columnType) , fmap compileDefaultValue defaultValue + , primaryKeyColumnConstraint , if notNull then Just "NOT NULL" else Nothing , if isUnique then Just "UNIQUE" else Nothing ]) + where + -- Emit a PRIMARY KEY column constraint if this is the only primary key column + primaryKeyColumnConstraint = case primaryKeyConstraint of + PrimaryKeyConstraint [primaryKeyColumn] + | name == primaryKeyColumn -> Just "PRIMARY KEY" + | otherwise -> Nothing + PrimaryKeyConstraint _ -> Nothing compileDefaultValue :: Expression -> Text compileDefaultValue value = "DEFAULT " <> compileExpression value diff --git a/Test/IDE/SchemaDesigner/CompilerSpec.hs b/Test/IDE/SchemaDesigner/CompilerSpec.hs index 614a53c30..ec4010ea4 100644 --- a/Test/IDE/SchemaDesigner/CompilerSpec.hs +++ b/Test/IDE/SchemaDesigner/CompilerSpec.hs @@ -25,15 +25,14 @@ tests = do it "should compile a CREATE TABLE with columns" do let sql = cs [plain|CREATE TABLE users ( - id UUID DEFAULT uuid_generate_v4() NOT NULL, + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, firstname TEXT NOT NULL, lastname TEXT NOT NULL, password_hash TEXT NOT NULL, email TEXT NOT NULL, company_id UUID NOT NULL, picture_url TEXT, - created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL, - PRIMARY KEY(id) + created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL ); |] let statement = StatementCreateTable CreateTable @@ -236,7 +235,7 @@ tests = do compileSql [statement] `shouldBe` sql it "should compile a CREATE TABLE statement with a multi-column UNIQUE (a, b) constraint" do - let sql = cs [plain|CREATE TABLE user_followers (\n id UUID DEFAULT uuid_generate_v4() NOT NULL,\n user_id UUID NOT NULL,\n follower_id UUID NOT NULL,\n PRIMARY KEY(id),\n UNIQUE(user_id, follower_id)\n);\n|] + let sql = cs [plain|CREATE TABLE user_followers (\n id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n user_id UUID NOT NULL,\n follower_id UUID NOT NULL,\n UNIQUE(user_id, follower_id)\n);\n|] let statement = StatementCreateTable CreateTable { name = "user_followers" , columns = @@ -250,7 +249,7 @@ tests = do compileSql [statement] `shouldBe` sql it "should compile a CREATE TABLE statement with a serial id" do - let sql = cs [plain|CREATE TABLE orders (\n id SERIAL NOT NULL,\n PRIMARY KEY(id)\n);\n|] + let sql = cs [plain|CREATE TABLE orders (\n id SERIAL PRIMARY KEY NOT NULL\n);\n|] let statement = StatementCreateTable CreateTable { name = "orders" , columns = [ col { name = "id", columnType = PSerial, notNull = True} ] @@ -260,7 +259,7 @@ tests = do compileSql [statement] `shouldBe` sql it "should compile a CREATE TABLE statement with a bigserial id" do - let sql = cs [plain|CREATE TABLE orders (\n id BIGSERIAL NOT NULL,\n PRIMARY KEY(id)\n);\n|] + let sql = cs [plain|CREATE TABLE orders (\n id BIGSERIAL PRIMARY KEY NOT NULL\n);\n|] let statement = StatementCreateTable CreateTable { name = "orders" , columns = [ col { name = "id", columnType = PBigserial, notNull = True} ]