ihp-postgres-parser (empty) → 1.0.0
raw patch · 7 files changed
+2368/−0 lines, 7 filesdep +basedep +bytestringdep +filepath
Dependencies added: base, bytestring, filepath, hspec, ihp-postgres-parser, megaparsec, parser-combinators, string-conversions, text
Files
- IHP/Postgres/Compiler.hs +520/−0
- IHP/Postgres/Parser.hs +1043/−0
- IHP/Postgres/Types.hs +338/−0
- Test/Postgres/CompilerSpec.hs +189/−0
- Test/Postgres/ParserSpec.hs +192/−0
- Test/Spec.hs +1/−0
- ihp-postgres-parser.cabal +85/−0
+ IHP/Postgres/Compiler.hs view
@@ -0,0 +1,520 @@+{-|+Module: IHP.Postgres.Compiler+Description: Compiles AST of SQL to DDL+Copyright: (c) digitally induced GmbH, 2020+-}+module IHP.Postgres.Compiler (compileSql, compileIdentifier, compileExpression, compilePostgresType, compileIndexColumn, compareStatement) where++import Prelude hiding (unlines, unwords)+import IHP.Postgres.Types+import Data.Maybe (fromJust, isJust, catMaybes, fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Function ((&))++-- | Text versions of list functions+intercalate :: Text -> [Text] -> Text+intercalate = Text.intercalate++unlines :: [Text] -> Text+unlines = Text.unlines++unwords :: [Text] -> Text+unwords = Text.unwords++-- | Convert a Show-able value to Text+tshow :: Show a => a -> Text+tshow = Text.pack . show++compileSql :: [Statement] -> Text+compileSql statements = statements+ & map compileStatement+ & unlines++compileStatement :: Statement -> Text+compileStatement (StatementCreateTable CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged, inherits }) = "CREATE" <> (if unlogged then " UNLOGGED" else "") <> " TABLE " <> compileIdentifier name <> " (\n" <> intercalate ",\n" (map (\col -> " " <> compileColumn primaryKeyConstraint col) columns <> maybe [] ((:[]) . indent) (compilePrimaryKeyConstraint primaryKeyConstraint) <> map (indent . compileConstraint) constraints) <> "\n)" <> maybe "" (\parent -> " INHERITS (" <> compileIdentifier parent <> ")") inherits <> ";"+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, constraint = UniqueConstraint { name = Nothing, columnNames } } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD UNIQUE (" <> intercalate ", " columnNames <> ")" <> ";"+compileStatement AddConstraint { tableName, constraint, deferrable, deferrableType } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD CONSTRAINT " <> compileIdentifier (fromMaybe (error "compileStatement: Expected constraint name") (constraint.name)) <> " " <> compileConstraint constraint <> compileDeferrable deferrable deferrableType <> ";"+compileStatement AddColumn { tableName, column } = "ALTER TABLE " <> compileIdentifier tableName <> " ADD COLUMN " <> (compileColumn (PrimaryKeyConstraint []) column) <> ";"+compileStatement DropColumn { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " DROP COLUMN " <> compileIdentifier columnName <> ";"+compileStatement RenameColumn { tableName, from, to } = "ALTER TABLE " <> compileIdentifier tableName <> " RENAME COLUMN " <> compileIdentifier from <> " TO " <> compileIdentifier to <> ";"+compileStatement DropTable { tableName } = "DROP TABLE " <> compileIdentifier tableName <> ";"+compileStatement Comment { content } = "--" <> content+compileStatement CreateIndex { indexName, unique, tableName, columns, whereClause, indexType } = "CREATE" <> (if unique then " UNIQUE " else " ") <> "INDEX " <> compileIdentifier indexName <> " ON " <> compileIdentifier tableName <> (maybe "" (\indexType -> " USING " <> compileIndexType indexType) indexType) <> " (" <> (intercalate ", " (map compileIndexColumn columns)) <> ")" <> (case whereClause of Just expression -> " WHERE " <> compileExpression expression; Nothing -> "") <> ";"+compileStatement CreateFunction { functionName, functionArguments, functionBody, orReplace, returns, language, securityDefiner } = "CREATE " <> (if orReplace then "OR REPLACE " else "") <> "FUNCTION " <> functionName <> "(" <> (functionArguments & map (\(argName, argType) -> argName <> " " <> compilePostgresType argType) & intercalate ", ") <> ")" <> " RETURNS " <> compilePostgresType returns <> (if securityDefiner then " SECURITY DEFINER" else "") <> " AS $$" <> functionBody <> "$$ language " <> language <> ";"+compileStatement EnableRowLevelSecurity { tableName } = "ALTER TABLE " <> compileIdentifier tableName <> " ENABLE ROW LEVEL SECURITY;"+compileStatement CreatePolicy { name, action, tableName, using, check } = "CREATE POLICY " <> compileIdentifier name <> " ON " <> compileIdentifier tableName <> maybe "" (\action -> " FOR " <> compilePolicyAction action) action <> maybe "" (\expr -> " USING (" <> compileExpression expr <> ")") using <> maybe "" (\expr -> " WITH CHECK (" <> compileExpression expr <> ")") check <> ";"+compileStatement CreateSequence { name } = "CREATE SEQUENCE " <> compileIdentifier name <> ";"+compileStatement DropConstraint { tableName, constraintName } = "ALTER TABLE " <> compileIdentifier tableName <> " DROP CONSTRAINT " <> compileIdentifier constraintName <> ";"+compileStatement DropEnumType { name } = "DROP TYPE " <> compileIdentifier name <> ";"+compileStatement DropIndex { indexName } = "DROP INDEX " <> compileIdentifier indexName <> ";"+compileStatement DropNotNull { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " DROP NOT NULL;"+compileStatement SetNotNull { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " SET NOT NULL;"+compileStatement RenameTable { from, to } = "ALTER TABLE " <> compileIdentifier from <> " RENAME TO " <> compileIdentifier to <> ";"+compileStatement DropPolicy { tableName, policyName } = "DROP POLICY " <> compileIdentifier policyName <> " ON " <> compileIdentifier tableName <> ";"+compileStatement SetDefaultValue { tableName, columnName, value } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " SET DEFAULT " <> compileExpression value <> ";"+compileStatement DropDefaultValue { tableName, columnName } = "ALTER TABLE " <> compileIdentifier tableName <> " ALTER COLUMN " <> compileIdentifier columnName <> " DROP DEFAULT;"+compileStatement AddValueToEnumType { enumName, newValue } = "ALTER TYPE " <> compileIdentifier enumName <> " ADD VALUE " <> compileExpression (TextExpression newValue) <> ";"+compileStatement CreateTrigger { name, eventWhen, event, tableName, for, whenCondition, functionName, arguments } = "CREATE TRIGGER " <> compileIdentifier name <> " " <> compileTriggerEventWhen eventWhen <> " " <> intercalate " OR " (map compileTriggerEvent event) <> " ON " <> compileIdentifier tableName <> " " <> compileTriggerFor for <> " EXECUTE FUNCTION " <> compileExpression (CallExpression functionName arguments) <> ";"+compileStatement Begin = "BEGIN;"+compileStatement Commit = "COMMIT;"+compileStatement DropFunction { functionName } = "DROP FUNCTION " <> compileIdentifier functionName <> ";"+compileStatement UnknownStatement { raw } = raw <> ";"+compileStatement Set { name, value } = "SET " <> compileIdentifier name <> " = " <> compileExpression value <> ";"+compileStatement SelectStatement { query } = "SELECT " <> query <> ";"+compileStatement DropTrigger { name, tableName } = "DROP TRIGGER " <> compileIdentifier name <> " ON " <> compileIdentifier tableName <> ";"+compileStatement CreateEventTrigger { name, eventOn, whenCondition, functionName, arguments } = "CREATE EVENT TRIGGER " <> compileIdentifier name <> " ON " <> compileIdentifier eventOn <> " " <> (maybe "" (\expression -> "WHEN " <> compileExpression expression) whenCondition) <> " EXECUTE FUNCTION " <> compileExpression (CallExpression functionName arguments) <> ";"+compileStatement DropEventTrigger { name } = "DROP EVENT TRIGGER " <> compileIdentifier name <> ";"++-- | 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+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 <> ")"+compileConstraint CheckConstraint { checkExpression } = "CHECK (" <> compileExpression checkExpression <> ")"+compileConstraint AlterTableAddPrimaryKey { primaryKeyConstraint } = fromMaybe "" (compilePrimaryKeyConstraint primaryKeyConstraint)+compileConstraint ExcludeConstraint { excludeElements, predicate, indexType } = "EXCLUDE" <> compiledIndexType <> " (" <> compiledExcludeElements <> ")" <> case predicate of+ Just expression -> " WHERE (" <> compileExpression expression <> ")"+ Nothing -> ""+ where+ compiledExcludeElements = intercalate ", " $ map compileExcludeElement excludeElements++ compileExcludeElement ExcludeConstraintElement { element, operator } = element <> " WITH " <> operator++ compiledIndexType = case indexType of+ Nothing -> ""+ Just indexType -> " USING " <> compileIndexType indexType++compileDeferrable :: Maybe Bool -> Maybe DeferrableType -> Text+compileDeferrable deferrable deferrableType = Text.concat $ map ((<>) " ") $ catMaybes [compileIsDeferrable <$> deferrable, compileDeferrableType <$> deferrableType]+ where+ compileIsDeferrable True = "DEFERRABLE"+ compileIsDeferrable False = "NOT DEFERRABLE"+ compileDeferrableType InitiallyImmediate = "INITIALLY IMMEDIATE"+ compileDeferrableType InitiallyDeferred = "INITIALLY DEFERRED"++compileOnDelete :: Maybe OnDelete -> Text+compileOnDelete Nothing = ""+compileOnDelete (Just NoAction) = "ON DELETE NO ACTION"+compileOnDelete (Just Restrict) = "ON DELETE RESTRICT"+compileOnDelete (Just SetNull) = "ON DELETE SET NULL"+compileOnDelete (Just SetDefault) = "ON DELETE SET DEFAULT"+compileOnDelete (Just Cascade) = "ON DELETE CASCADE"++compileColumn :: PrimaryKeyConstraint -> Column -> Text+compileColumn primaryKeyConstraint Column { name, columnType, defaultValue, notNull, isUnique, generator } =+ unwords (catMaybes+ [ Just (compileIdentifier name)+ , Just (compilePostgresType columnType)+ , fmap compileDefaultValue defaultValue+ , fmap compileGenerator generator+ , 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++compileExpression :: Expression -> Text+compileExpression (TextExpression value) = "'" <> value <> "'"+compileExpression (VarExpression name) =+ if nameContainsSpaces+ then compileIdentifier name+ else name+ where+ nameContainsSpaces = Text.any (== ' ') name+compileExpression (CallExpression func args) = func <> "(" <> intercalate ", " (map compileExpressionWithOptionalParenthese args) <> ")"+compileExpression (NotEqExpression a b) = compileExpression a <> " <> " <> compileExpression b+compileExpression (EqExpression a b) = compileExpressionWithOptionalParenthese a <> " = " <> compileExpressionWithOptionalParenthese b+compileExpression (IsExpression a (NotExpression b)) = compileExpressionWithOptionalParenthese a <> " IS NOT " <> compileExpressionWithOptionalParenthese b -- 'IS (NOT NULL)' => 'IS NOT NULL'+compileExpression (IsExpression a b) = compileExpressionWithOptionalParenthese a <> " IS " <> compileExpressionWithOptionalParenthese b+compileExpression (InExpression a b) = compileExpressionWithOptionalParenthese a <> " IN " <> compileExpressionWithOptionalParenthese b+compileExpression (InArrayExpression values) = "(" <> intercalate ", " (map compileExpression values) <> ")"+compileExpression (NotExpression a) = "NOT " <> compileExpressionWithOptionalParenthese a+compileExpression (AndExpression a b) = compileExpressionWithOptionalParenthese a <> " AND " <> compileExpressionWithOptionalParenthese b+compileExpression (OrExpression a b) = compileExpressionWithOptionalParenthese a <> " OR " <> compileExpressionWithOptionalParenthese b+compileExpression (LessThanExpression a b) = compileExpressionWithOptionalParenthese a <> " < " <> compileExpressionWithOptionalParenthese b+compileExpression (LessThanOrEqualToExpression a b) = compileExpressionWithOptionalParenthese a <> " <= " <> compileExpressionWithOptionalParenthese b+compileExpression (GreaterThanExpression a b) = compileExpressionWithOptionalParenthese a <> " > " <> compileExpressionWithOptionalParenthese b+compileExpression (GreaterThanOrEqualToExpression a b) = compileExpressionWithOptionalParenthese a <> " >= " <> compileExpressionWithOptionalParenthese b+compileExpression (DoubleExpression double) = tshow double+compileExpression (IntExpression integer) = tshow integer+compileExpression (TypeCastExpression value type_) = compileExpression value <> "::" <> compilePostgresType type_+compileExpression (SelectExpression Select { columns, from, whereClause }) = "SELECT " <> intercalate ", " (map compileExpression columns) <> " FROM " <> compileExpression from <> " WHERE " <> compileExpression whereClause+compileExpression (ExistsExpression a) = "EXISTS " <> compileExpressionWithOptionalParenthese a+compileExpression (DotExpression a b) = compileExpressionWithOptionalParenthese a <> "." <> compileIdentifier b+compileExpression (ConcatenationExpression a b) = compileExpressionWithOptionalParenthese a <> " || " <> compileExpressionWithOptionalParenthese b++compileExpressionWithOptionalParenthese :: Expression -> Text+compileExpressionWithOptionalParenthese expr@(VarExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(IsExpression a (NotExpression b)) = compileExpression a <> " IS " <> compileExpression (NotExpression b) -- 'IS (NOT NULL)' => 'IS NOT NULL'+compileExpressionWithOptionalParenthese expr@(IsExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(EqExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(AndExpression a@(AndExpression {}) b ) = "(" <> compileExpression a <> " AND " <> compileExpressionWithOptionalParenthese b <> ")" -- '(a AND b) AND c' => 'a AND b AND C'+compileExpressionWithOptionalParenthese expr@(AndExpression a b@(AndExpression {}) ) = "(" <> compileExpressionWithOptionalParenthese a <> " AND " <> compileExpression b <> ")" -- 'a AND (b AND c)' => 'a AND b AND C'+--compileExpressionWithOptionalParenthese expr@(OrExpression a@(IsExpression {}) b ) = compileExpressionWithOptionalParenthese a <> " OR " <> compileExpressionWithOptionalParenthese b -- '(a IS NULL) OR b' => 'A IS NULL OR b'+compileExpressionWithOptionalParenthese expr@(CallExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(TextExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(IntExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(DoubleExpression {}) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(DotExpression (VarExpression {}) b) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(ConcatenationExpression a b ) = compileExpression expr+compileExpressionWithOptionalParenthese expr@(InArrayExpression values) = compileExpression expr+compileExpressionWithOptionalParenthese expression = "(" <> compileExpression expression <> ")"++-- | Compare statements for sorting in schema output+compareStatement :: Statement -> Statement -> Ordering+compareStatement (CreateEnumType {}) _ = LT+compareStatement (StatementCreateTable CreateTable {}) (AddConstraint {}) = LT+compareStatement (AddConstraint { constraint = a }) (AddConstraint { constraint = b }) = compare (a.name) (b.name)+compareStatement (AddConstraint {}) _ = GT+compareStatement _ _ = EQ++compilePostgresType :: PostgresType -> Text+compilePostgresType PUUID = "UUID"+compilePostgresType PText = "TEXT"+compilePostgresType PInt = "INT"+compilePostgresType PSmallInt = "SMALLINT"+compilePostgresType PBigInt = "BIGINT"+compilePostgresType PBoolean = "BOOLEAN"+compilePostgresType PTimestamp = "TIMESTAMP WITHOUT TIME ZONE"+compilePostgresType PTimestampWithTimezone = "TIMESTAMP WITH TIME ZONE"+compilePostgresType PReal = "REAL"+compilePostgresType PDouble = "DOUBLE PRECISION"+compilePostgresType PPoint = "POINT"+compilePostgresType PPolygon = "POLYGON"+compilePostgresType PDate = "DATE"+compilePostgresType PBinary = "BYTEA"+compilePostgresType PTime = "TIME"+compilePostgresType (PInterval Nothing) = "INTERVAL"+compilePostgresType (PInterval (Just fields)) = "INTERVAL" <> " " <> fields+compilePostgresType (PNumeric (Just precision) (Just scale)) = "NUMERIC(" <> tshow precision <> "," <> tshow scale <> ")"+compilePostgresType (PNumeric (Just precision) Nothing) = "NUMERIC(" <> tshow precision <> ")"+compilePostgresType (PNumeric Nothing _) = "NUMERIC"+compilePostgresType (PVaryingN (Just limit)) = "CHARACTER VARYING(" <> tshow limit <> ")"+compilePostgresType (PVaryingN Nothing) = "CHARACTER VARYING"+compilePostgresType (PCharacterN length) = "CHARACTER(" <> tshow length <> ")"+compilePostgresType PSingleChar = "\"char\""+compilePostgresType PSerial = "SERIAL"+compilePostgresType PBigserial = "BIGSERIAL"+compilePostgresType PJSONB = "JSONB"+compilePostgresType PInet = "INET"+compilePostgresType PTSVector = "TSVECTOR"+compilePostgresType (PArray type_) = compilePostgresType type_ <> "[]"+compilePostgresType PTrigger = "TRIGGER"+compilePostgresType PEventTrigger = "EVENT_TRIGGER"+compilePostgresType (PCustomType theType) = theType++compileIdentifier :: Text -> Text+compileIdentifier identifier = if identifierNeedsQuoting then tshow identifier else identifier+ where+ identifierNeedsQuoting = isKeyword || containsChar ' ' || containsChar '-' || isUsingUppercase+ isKeyword = Text.toUpper identifier `elem` keywords+ containsChar char = Text.any (char ==) identifier+ isUsingUppercase = Text.toLower identifier /= identifier++ keywords = [ "ABORT"+ , "ABSOLUTE"+ , "ACCESS"+ , "ACTION"+ , "ADD"+ , "ADMIN"+ , "AFTER"+ , "AGGREGATE"+ , "ALSO"+ , "ALTER"+ , "ASSERTION"+ , "ASSIGNMENT"+ , "AT"+ , "ALL"+ , "BACKWARD"+ , "BEFORE"+ , "BEGIN"+ , "BY"+ , "CACHE"+ , "CALLED"+ , "CASCADE"+ , "CHAIN"+ , "CHARACTERISTICS"+ , "CHECKPOINT"+ , "CLASS"+ , "CLOSE"+ , "CLUSTER"+ , "COMMENT"+ , "COMMIT"+ , "COMMITTED"+ , "CONNECTION"+ , "CONSTRAINTS"+ , "CONVERSION"+ , "COPY"+ , "CREATEDB"+ , "CREATEROLE"+ , "CREATEUSER"+ , "CSV"+ , "CURSOR"+ , "CYCLE"+ , "DATABASE"+ , "DAY"+ , "DEALLOCATE"+ , "DECLARE"+ , "DEFAULTS"+ , "DEFERRED"+ , "DEFINER"+ , "DELETE"+ , "DELIMITER"+ , "DELIMITERS"+ , "DISABLE"+ , "DOMAIN"+ , "DOUBLE"+ , "DROP"+ , "EACH"+ , "ENABLE"+ , "ENCODING"+ , "ENCRYPTED"+ , "ESCAPE"+ , "EXCLUDING"+ , "EXCLUSIVE"+ , "EXECUTE"+ , "EXPLAIN"+ , "EXTERNAL"+ , "FETCH"+ , "FIRST"+ , "FORCE"+ , "FORWARD"+ , "FUNCTION"+ , "GLOBAL"+ , "GRANTED"+ , "HANDLER"+ , "HEADER"+ , "HOLD"+ , "HOUR"+ , "IMMEDIATE"+ , "IMMUTABLE"+ , "IMPLICIT"+ , "INCLUDING"+ , "INCREMENT"+ , "INDEX"+ , "INHERIT"+ , "INHERITS"+ , "INPUT"+ , "INSENSITIVE"+ , "INSERT"+ , "INSTEAD"+ , "INVOKER"+ , "ISOLATION"+ , "KEY"+ , "LANCOMPILER"+ , "LANGUAGE"+ , "LARGE"+ , "LAST"+ , "LEVEL"+ , "LISTEN"+ , "LOAD"+ , "LOCAL"+ , "LOCATION"+ , "LOCK"+ , "LOGIN"+ , "MATCH"+ , "MAXVALUE"+ , "MINUTE"+ , "MINVALUE"+ , "MODE"+ , "MONTH"+ , "MOVE"+ , "NAMES"+ , "NEXT"+ , "NO"+ , "NOCREATEDB"+ , "NOCREATEROLE"+ , "NOCREATEUSER"+ , "NOINHERIT"+ , "NOLOGIN"+ , "NOSUPERUSER"+ , "NOTHING"+ , "NOTIFY"+ , "NOWAIT"+ , "OBJECT"+ , "OF"+ , "OIDS"+ , "OPERATOR"+ , "OPTION"+ , "OWNER"+ , "PARTIAL"+ , "PASSWORD"+ , "PREPARE"+ , "PREPARED"+ , "PRESERVE"+ , "PRIOR"+ , "PRIVILEGES"+ , "PROCEDURAL"+ , "PROCEDURE"+ , "QUOTE"+ , "READ"+ , "RECHECK"+ , "REINDEX"+ , "RELATIVE"+ , "RELEASE"+ , "RENAME"+ , "REPEATABLE"+ , "REPLACE"+ , "RESET"+ , "RESTART"+ , "RESTRICT"+ , "RETURNS"+ , "REVOKE"+ , "ROLE"+ , "ROLLBACK"+ , "ROWS"+ , "RULE"+ , "SAVEPOINT"+ , "SCHEMA"+ , "SCROLL"+ , "SECOND"+ , "SECURITY"+ , "SEQUENCE"+ , "SERIALIZABLE"+ , "SESSION"+ , "SET"+ , "SHARE"+ , "SHOW"+ , "SIMPLE"+ , "STABLE"+ , "START"+ , "STATEMENT"+ , "STATISTICS"+ , "STDIN"+ , "STDOUT"+ , "STORAGE"+ , "STRICT"+ , "SUPERUSER"+ , "SYSID"+ , "SYSTEM"+ , "TABLESPACE"+ , "TEMP"+ , "TEMPLATE"+ , "TEMPORARY"+ , "TOAST"+ , "TRANSACTION"+ , "TRIGGER"+ , "TRUNCATE"+ , "TRUSTED"+ , "TYPE"+ , "UNCOMMITTED"+ , "UNENCRYPTED"+ , "UNKNOWN"+ , "UNLISTEN"+ , "UNTIL"+ , "UPDATE"+ , "VACUUM"+ , "VALID"+ , "VALIDATOR"+ , "VALUES"+ , "VARYING"+ , "VIEW"+ , "VOLATILE"+ , "WITH"+ , "WITHOUT"+ , "WORK"+ , "WRITE"+ , "YEAR"+ , "ZONE"+ , "BIGINT"+ , "BIT"+ , "BOOLEAN"+ , "CHAR"+ , "CHARACTER"+ , "COALESCE"+ , "CONVERT"+ , "DEC"+ , "DECIMAL"+ , "EXISTS"+ , "EXTRACT"+ , "FLOAT"+ , "GREATEST"+ , "INOUT"+ , "INT"+ , "INTEGER"+ , "INTERVAL"+ , "LEAST"+ , "NATIONAL"+ , "NCHAR"+ , "NONE"+ , "NULLIF"+ , "NUMERIC"+ , "OUT"+ , "OVERLAY"+ , "POSITION"+ , "PRECISION"+ , "REAL"+ , "ROW"+ , "SETOF"+ , "SMALLINT"+ , "SUBSTRING"+ , "TIME"+ , "TIMESTAMP"+ , "TREAT"+ , "TRIM"+ , "VARCHAR"+ ]++indent text = " " <> text++compileTriggerEventWhen :: TriggerEventWhen -> Text+compileTriggerEventWhen Before = "BEFORE"+compileTriggerEventWhen After = "AFTER"+compileTriggerEventWhen InsteadOf = "INSTEAD OF"++compileTriggerEvent :: TriggerEvent -> Text+compileTriggerEvent TriggerOnInsert = "INSERT"+compileTriggerEvent TriggerOnUpdate = "UPDATE"+compileTriggerEvent TriggerOnDelete = "DELETE"+compileTriggerEvent TriggerOnTruncate = "TRUNCATE"++compileTriggerFor :: TriggerFor -> Text+compileTriggerFor ForEachRow = "FOR EACH ROW"+compileTriggerFor ForEachStatement = "FOR EACH STATEMENT"++compilePolicyAction :: PolicyAction -> Text+compilePolicyAction PolicyForAll = "ALL"+compilePolicyAction PolicyForSelect = "SELECT"+compilePolicyAction PolicyForInsert = "INSERT"+compilePolicyAction PolicyForUpdate = "UPDATE"+compilePolicyAction PolicyForDelete = "DELETE"++compileGenerator :: ColumnGenerator -> Text+compileGenerator ColumnGenerator { generate, stored } =+ "GENERATED ALWAYS AS ("+ <> compileExpressionWithOptionalParenthese generate+ <> ")"+ <> (if stored then " STORED" else "")++compileIndexType :: IndexType -> Text+compileIndexType Gin = "GIN"+compileIndexType Btree = "BTREE"+compileIndexType Gist = "GIST"++compileIndexColumn :: IndexColumn -> Text+compileIndexColumn IndexColumn { column, columnOrder = [] } = compileExpression column+compileIndexColumn IndexColumn { column, columnOrder } = compileExpression column <> " " <> unwords (columnOrder & map compileIndexColumnOrder)++compileIndexColumnOrder :: IndexColumnOrder -> Text+compileIndexColumnOrder Asc = "ASC"+compileIndexColumnOrder Desc = "DESC"+compileIndexColumnOrder NullsFirst = "NULLS FIRST"+compileIndexColumnOrder NullsLast = "NULLS LAST"
+ IHP/Postgres/Parser.hs view
@@ -0,0 +1,1043 @@+{-|+Module: IHP.Postgres.Parser+Description: Parser for PostgreSQL DDL statements+Copyright: (c) digitally induced GmbH, 2020+-}+module IHP.Postgres.Parser+( parseSqlFile+, parseDDL+, expression+, sqlType+, removeTypeCasts+, parseIndexColumns+) where++import Prelude+import IHP.Postgres.Types hiding (table)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.ByteString (ByteString)+import Data.String.Conversions (cs)+import Data.Maybe (isJust, catMaybes, isNothing)+import Data.Either (lefts, rights)+import Data.Functor (($>))+import Data.Char (isAlphaNum)+import Control.Monad (when)+import Text.Megaparsec+import Data.Void+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as Lexer+import System.OsPath (OsPath, decodeUtf)+import Control.Monad.Combinators.Expr++-- | Helper to convert Int parsing results+textToInt :: Text -> Maybe Int+textToInt text = case reads (Text.unpack text) of+ [(n, "")] -> Just n+ _ -> Nothing++parseSqlFile :: OsPath -> IO (Either ByteString [Statement])+parseSqlFile schemaFilePath = do+ fp <- decodeUtf schemaFilePath+ schemaSql <- Text.readFile fp+ let result = runParser parseDDL fp schemaSql+ case result of+ Left error -> pure (Left (cs $ errorBundlePretty error))+ Right r -> pure (Right r)++type Parser = Parsec Void Text++spaceConsumer :: Parser ()+spaceConsumer = Lexer.space+ space1+ (Lexer.skipLineComment "//")+ (Lexer.skipBlockComment "/*" "*/")++lexeme :: Parser a -> Parser a+lexeme = Lexer.lexeme spaceConsumer++symbol :: Text -> Parser Text+symbol = Lexer.symbol spaceConsumer++symbol' :: Text -> Parser Text+symbol' = Lexer.symbol' spaceConsumer++stringLiteral :: Parser String+stringLiteral = char '\'' *> manyTill Lexer.charLiteral (char '\'')++parseDDL :: Parser [Statement]+parseDDL = optional space >> (manyTill statement eof)++statement = do+ space+ let create = try createExtension <|> try (StatementCreateTable <$> createTable) <|> try createIndex <|> try createFunction <|> try createTrigger <|> try createEnumType <|> try createPolicy <|> try createSequence+ let alter = do+ lexeme "ALTER"+ alterTable <|> alterType <|> alterSequence+ s <- setStatement <|> create <|> alter <|> selectStatement <|> try dropTable <|> try dropIndex <|> try dropPolicy <|> try dropFunction <|> try dropType <|> dropTrigger <|> commentStatement <|> comment <|> begin <|> commit <|> restrict <|> unrestrict+ space+ pure s+++createExtension = do+ lexeme "CREATE"+ lexeme "EXTENSION"+ ifNotExists <- isJust <$> optional (lexeme "IF" >> lexeme "NOT" >> lexeme "EXISTS")+ name <- qualifiedIdentifier+ optional do+ space+ lexeme "WITH"+ lexeme "SCHEMA"+ lexeme "public"+ char ';'+ pure CreateExtension { name, ifNotExists = True }++createTable = do+ lexeme "CREATE"+ unlogged <- isJust <$> optional (lexeme "UNLOGGED")+ lexeme "TABLE"+ name <- qualifiedIdentifier++ -- 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 <$> parseColumn)) `sepBy` (char ',' >> space)+ pure (lefts columnsAndConstraints, rights columnsAndConstraints)++ inherits <- optional do+ lexeme "INHERITS"+ between (char '(' >> space) (char ')' >> space) qualifiedIdentifier++ char ';'++ -- 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+ [] -> pure $ PrimaryKeyConstraint []+ [primaryKeyConstraint] -> pure primaryKeyConstraint+ _ -> fail ("Multiple PRIMARY KEY constraints on table " <> cs name)+ [(_, Column { name })] -> case lefts allConstraints of+ [] -> pure $ PrimaryKeyConstraint [name]+ _ -> fail ("Primary key defined in both column and table constraints on table " <> cs name)+ _ -> fail "Multiple columns with PRIMARY KEY constraint"++ pure CreateTable { name, columns, primaryKeyConstraint, constraints, unlogged, inherits }++createEnumType = do+ lexeme "CREATE"+ lexeme "TYPE"+ optional do+ lexeme "public"+ char '.'+ name <- identifier+ lexeme "AS"+ lexeme "ENUM"+ values <- between (char '(' >> space) (space >> char ')' >> space) (textExpr' `sepBy` (char ',' >> space))+ space+ char ';'+ pure CreateEnumType { name, values }++addConstraint tableName = do+ constraint <- parseTableConstraint >>= \case+ Left primaryKeyConstraint -> pure AlterTableAddPrimaryKey { name = Nothing, primaryKeyConstraint }+ Right constraint -> pure constraint+ deferrable <- optional parseDeferrable+ deferrableType <- optional parseDeferrableType+ char ';'+ pure AddConstraint { tableName, constraint, deferrable, deferrableType }++parseDeferrable :: Parser Bool+parseDeferrable = (lexeme "NOT DEFERRABLE" $> False) <|> (lexeme "DEFERRABLE" $> True)++parseDeferrableType :: Parser DeferrableType+parseDeferrableType = do+ lexeme "INITIALLY"+ (lexeme "IMMEDIATE" $> InitiallyImmediate) <|> (lexeme "DEFERRED" $> InitiallyDeferred)++parseTableConstraint = do+ name <- optional do+ lexeme "CONSTRAINT"+ identifier+ (Left <$> parsePrimaryKeyConstraint) <|>+ (Right <$> (parseForeignKeyConstraint name <|> parseUniqueConstraint name <|> parseCheckConstraint name <|> parseExcludeConstraint name))++parsePrimaryKeyConstraint = do+ lexeme "PRIMARY"+ lexeme "KEY"+ primaryKeyColumnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space))+ pure PrimaryKeyConstraint { primaryKeyColumnNames }++parseForeignKeyConstraint name = do+ lexeme "FOREIGN"+ lexeme "KEY"+ columnName <- between (char '(' >> space) (char ')' >> space) identifier+ lexeme "REFERENCES"+ referenceTable <- qualifiedIdentifier+ referenceColumn <- optional $ between (char '(' >> space) (char ')' >> space) identifier+ onDelete <- optional do+ lexeme "ON"+ lexeme "DELETE"+ parseOnDelete+ pure ForeignKeyConstraint { name, columnName, referenceTable, referenceColumn, onDelete }++parseUniqueConstraint name = do+ lexeme "UNIQUE"+ columnNames <- between (char '(' >> space) (char ')' >> space) (identifier `sepBy1` (char ',' >> space))+ pure UniqueConstraint { name, columnNames }++parseCheckConstraint name = do+ lexeme "CHECK"+ checkExpression <- between (char '(' >> space) (char ')' >> space) expression+ pure CheckConstraint { name, checkExpression }++parseExcludeConstraint name = do+ lexeme "EXCLUDE"+ indexType <- optional parseIndexType+ excludeElements <- between (char '(' >> space) (char ')' >> space) $ excludeElement `sepBy` (char ',' >> space)+ predicate <- optional do+ lexeme "WHERE"+ between (char '(' >> space) (char ')' >> space) expression+ pure ExcludeConstraint { name, excludeElements, predicate, indexType }+ where+ excludeElement = do+ element <- identifier+ space+ lexeme "WITH"+ space+ operator <- parseCommutativeInfixOperator+ pure ExcludeConstraintElement { element, operator }++ parseCommutativeInfixOperator = choice $ map lexeme+ [ "="+ , "<>"+ , "!="+ , "AND"+ , "OR"+ ]++parseOnDelete = choice+ [ (lexeme "NO" >> lexeme "ACTION") >> pure NoAction+ , (lexeme "RESTRICT" >> pure Restrict)+ , (lexeme "SET" >> ((lexeme "NULL" >> pure SetNull) <|> (lexeme "DEFAULT" >> pure SetDefault)))+ , (lexeme "CASCADE" >> pure Cascade)+ ]++parseColumn :: Parser (Bool, Column)+parseColumn = do+ name <- identifier+ columnType <- sqlType+ space+ let+ column = Column+ { name+ , columnType+ , defaultValue = Nothing+ , notNull = False+ , isUnique = False+ , generator = Nothing+ }+ parseColumnAttributes column False+ where+ parseColumnAttributes column primaryKey = choice+ [ do+ lexeme "DEFAULT"+ value <- expression+ parseColumnAttributes column { defaultValue = Just value } primaryKey+ , do+ lexeme "GENERATED"+ lexeme "ALWAYS"+ lexeme "AS"+ generate <- expression+ stored <- isJust <$> optional (lexeme "STORED")+ parseColumnAttributes column { generator = Just ColumnGenerator { generate, stored } } primaryKey+ , do+ lexeme "PRIMARY"+ lexeme "KEY"+ parseColumnAttributes column True+ , do+ lexeme "NOT"+ lexeme "NULL"+ parseColumnAttributes column { notNull = True } primaryKey+ , do+ lexeme "UNIQUE"+ parseColumnAttributes column { isUnique = True } primaryKey+ , pure (primaryKey, column)+ ]++sqlType :: Parser PostgresType+sqlType = choice $ map optionalArray+ [ uuid+ , text+ , interval --Needs higher precedence otherwise parsed as int+ , bigint+ , smallint+ , int -- order int after smallint/bigint because symbol INT is prefix of INT2, INT8+ , bool+ , timestamp+ , timestampZ+ , timestampZ'+ , timestamp'+ , real+ , double+ , point+ , polygon+ , date+ , binary+ , time+ , numericPS+ , numeric+ , character+ , varchar+ , serial+ , bigserial+ , jsonb+ , inet+ , tsvector+ , trigger+ , eventTrigger+ , singleChar+ , customType+ ]+ where+ timestamp = do+ try (symbol' "TIMESTAMP" >> symbol' "WITHOUT" >> symbol' "TIME" >> symbol' "ZONE")+ pure PTimestamp++ timestampZ = do+ try (symbol' "TIMESTAMP" >> symbol' "WITH" >> symbol' "TIME" >> symbol' "ZONE")+ pure PTimestampWithTimezone++ timestampZ' = do+ try (symbol' "TIMESTAMPZ")+ pure PTimestampWithTimezone++ timestamp' = do+ try (symbol' "TIMESTAMP")+ pure PTimestamp++ uuid = do+ try (symbol' "UUID")+ pure PUUID++ text = do+ try (symbol' "TEXT")+ pure PText++ bigint = do+ try (symbol' "BIGINT") <|> try (symbol' "INT8")+ pure PBigInt++ smallint = do+ try (symbol' "SMALLINT") <|> try (symbol' "INT2")+ pure PSmallInt++ int = do+ try (symbol' "INTEGER") <|> try (symbol' "INT4") <|> try (symbol' "INT")+ pure PInt++ bool = do+ try (symbol' "BOOLEAN") <|> try (symbol' "BOOL")+ pure PBoolean++ real = do+ try (symbol' "REAL") <|> try (symbol' "FLOAT4")+ pure PReal++ double = do+ try (symbol' "DOUBLE PRECISION") <|> try (symbol' "FLOAT8")+ pure PDouble++ point = do+ try (symbol' "POINT")+ pure PPoint++ polygon = do+ try (symbol' "POLYGON")+ pure PPolygon++ date = do+ try (symbol' "DATE")+ pure PDate++ binary = do+ try (symbol' "BYTEA")+ pure PBinary++ time = do+ try (symbol' "TIME")+ optional do+ symbol' "WITHOUT"+ symbol' "TIME"+ symbol' "ZONE"+ pure PTime++ interval = do+ try (symbol' "INTERVAL")+ fields <- optional do+ choice $ map symbol' intervalFields+ pure (PInterval fields)++ numericPS = do+ try (symbol' "NUMERIC(")+ values <- between (space) (char ')' >> space) (varExpr `sepBy` (char ',' >> space))+ case values of+ [VarExpression precision, VarExpression scale] -> do+ let p = textToInt precision+ let s = textToInt scale+ when (or [isNothing p, isNothing s]) do+ fail "Failed to parse NUMERIC(..) expression"+ pure (PNumeric p s)+ [VarExpression precision] -> do+ let p = textToInt precision+ when (isNothing p) do+ fail "Failed to parse NUMERIC(..) expression"+ pure (PNumeric p Nothing)+ _ -> fail "Failed to parse NUMERIC(..) expression"++ numeric = do+ try (symbol' "NUMERIC")+ pure (PNumeric Nothing Nothing)++ varchar = do+ try (symbol' "CHARACTER VARYING") <|> try (symbol' "VARCHAR")+ value <- optional $ between (char '(' >> space) (char ')' >> space) (varExpr)+ case value of+ Just (VarExpression limit) -> do+ let l = textToInt limit+ case l of+ Nothing -> fail "Failed to parse CHARACTER VARYING(..) expression"+ Just l -> pure (PVaryingN (Just l))+ Nothing -> pure (PVaryingN Nothing)+ _ -> fail "Failed to parse CHARACTER VARYING(..) expression"++ character = do+ try (symbol' "CHAR(") <|> try (symbol' "CHARACTER(")+ value <- between (space) (char ')' >> space) (varExpr)+ case value of+ VarExpression length -> do+ let l = textToInt length+ case l of+ Nothing -> fail "Failed to parse CHARACTER VARYING(..) expression"+ Just l -> pure (PCharacterN l)+ _ -> fail "Failed to parse CHARACTER VARYING(..) expression"++ singleChar = do+ try (symbol "\"char\"")+ pure PSingleChar++ serial = do+ try (symbol' "SERIAL")+ pure PSerial++ bigserial = do+ try (symbol' "BIGSERIAL")+ pure PBigserial++ jsonb = do+ try (symbol' "JSONB")+ pure PJSONB++ inet = do+ try (symbol' "INET")+ pure PInet++ tsvector = do+ try (symbol' "TSVECTOR")+ pure PTSVector++ optionalArray typeParser= do+ arrayType <- typeParser;+ (try do symbol' "[]"; pure $ PArray arrayType) <|> pure arrayType++ trigger = do+ try (symbol' "TRIGGER")+ pure PTrigger++ eventTrigger = do+ try (symbol' "EVENT_TRIGGER")+ pure PEventTrigger++ customType = do+ optional do+ lexeme "public"+ char '.'+ theType <- try (takeWhile1P (Just "Custom type") (\c -> isAlphaNum c || c == '_'))+ pure (PCustomType theType)+++intervalFields :: [Text]+intervalFields = [ "YEAR TO MONTH", "DAY TO HOUR", "DAY TO MINUTE", "DAY TO SECOND"+ , "HOUR TO MINUTE", "HOUR TO SECOND", "MINUTE TO SECOND"+ , "YEAR", "MONTH", "DAY", "HOUR", "MINUTE", "SECOND"]+++term = parens expression <|> try callExpr <|> try doubleExpr <|> try intExpr <|> selectExpr <|> varExpr <|> (textExpr <* optional space)+ where+ parens f = between (char '(' >> space) (char ')' >> space) f++table = [+ [ binary "<>" NotEqExpression+ , binary "=" EqExpression++ , binary "<=" LessThanOrEqualToExpression+ , binary "<" LessThanExpression+ , binary ">=" GreaterThanOrEqualToExpression+ , binary ">" GreaterThanExpression+ , binary "||" ConcatenationExpression++ , binary "IS" IsExpression+ , inExpr+ , prefix "NOT" NotExpression+ , prefix "EXISTS" ExistsExpression+ , typeCast+ , dot+ ],+ [ binary "AND" AndExpression, binary "OR" OrExpression ]+ ]+ where+ binary name f = InfixL (f <$ try (symbol name))+ prefix name f = Prefix (f <$ symbol name)+ postfix name f = Postfix (f <$ symbol name)++ -- Cannot be implemented as a infix operator as that requires two expression operands,+ -- but the second is the type-cast type which is not an expression+ typeCast = Postfix do+ symbol "::"+ castType <- sqlType+ pure $ \expr -> TypeCastExpression expr castType++ dot = Postfix do+ char '.'+ name <- identifier+ pure $ \expr -> DotExpression expr name++ inExpr = Postfix do+ lexeme "IN"+ right <- try inArrayExpression <|> expression+ pure $ \expr -> InExpression expr right++-- | Parses a SQL expression+--+-- This parser makes use of makeExprParser as described in https://hackage.haskell.org/package/parser-combinators-1.2.0/docs/Control-Monad-Combinators-Expr.html+expression :: Parser Expression+expression = do+ e <- makeExprParser term table <?> "expression"+ space+ pure e++varExpr :: Parser Expression+varExpr = VarExpression <$> identifier++doubleExpr :: Parser Expression+doubleExpr = DoubleExpression <$> (Lexer.signed spaceConsumer Lexer.float)++intExpr :: Parser Expression+intExpr = IntExpression <$> (Lexer.signed spaceConsumer Lexer.decimal)++callExpr :: Parser Expression+callExpr = do+ func <- qualifiedIdentifier+ args <- between (char '(') (char ')') (expression `sepBy` (char ',' >> space))+ space+ pure (CallExpression func args)++textExpr :: Parser Expression+textExpr = TextExpression <$> textExpr'++textExpr' :: Parser Text+textExpr' = cs <$> do+ let emptyByteString = do+ string "'\\x'"+ pure ""+ (try (char '\'' *> manyTill Lexer.charLiteral (char '\''))) <|> emptyByteString++selectExpr :: Parser Expression+selectExpr = do+ symbol' "SELECT"+ columns <- expression `sepBy` (char ',' >> space)+ symbol' "FROM"+ from <- expression+++ let whereClause alias = do+ symbol' "WHERE"+ whereClause <- expression+ pure (SelectExpression Select { .. })++ let explicitAs = do+ symbol' "AS"+ alias <- identifier+ whereClause (Just alias)++ let implicitAs = do+ alias <- identifier+ whereClause (Just alias)++ whereClause Nothing <|> explicitAs <|> implicitAs++inArrayExpression :: Parser Expression+inArrayExpression = do+ values <- between (char '(') (char ')') (expression `sepBy` (char ',' >> space))+ pure (InArrayExpression values)++++identifier :: Parser Text+identifier = do+ i <- (between (char '"') (char '"') (takeWhile1P Nothing (\c -> c /= '"'))) <|> takeWhile1P (Just "identifier") (\c -> isAlphaNum c || c == '_')+ space+ pure i++comment = do+ (char '-' >> char '-') <?> "Line comment"+ content <- takeWhileP Nothing (/= '\n')+ pure Comment { content }++createIndex = do+ lexeme "CREATE"+ unique <- isJust <$> optional (lexeme "UNIQUE")+ lexeme "INDEX"+ indexName <- identifier+ lexeme "ON"+ tableName <- qualifiedIdentifier+ indexType <- optional parseIndexType+ columns <- between (char '(' >> space) (char ')' >> space) parseIndexColumns+ whereClause <- optional do+ lexeme "WHERE"+ expression+ char ';'+ pure CreateIndex { indexName, unique, tableName, columns, whereClause, indexType }++parseIndexColumns = parseIndexColumn `sepBy` (char ',' >> space)++parseIndexColumn = do+ column <- expression+ orderOption1 <- optional $ space *> lexeme "ASC" $> Asc <|> space *> lexeme "DESC" $> Desc+ orderOption2 <- optional $ space *> lexeme "NULLS FIRST" $> NullsFirst <|> space *> lexeme "NULLS LAST" $> NullsLast+ pure IndexColumn { column, columnOrder = catMaybes [orderOption1, orderOption2] }++parseIndexType = do+ lexeme "USING"++ choice $ map (\(s, v) -> do symbol' s; pure v)+ [ ("btree", Btree)+ , ("gin", Gin)+ , ("gist", Gist)+ ]++createFunction = do+ lexeme "CREATE"+ orReplace <- isJust <$> optional (lexeme "OR" >> lexeme "REPLACE")+ lexeme "FUNCTION"+ functionName <- qualifiedIdentifier+ functionArguments <- between (char '(') (char ')') (functionArgument `sepBy` (char ',' >> space))+ space+ lexeme "RETURNS"+ returns <- sqlType+ space++ language <- optional do+ lexeme "language" <|> lexeme "LANGUAGE"+ symbol' "plpgsql" <|> symbol' "SQL"++ securityDefiner <- isJust <$> optional do+ lexeme "SECURITY"+ lexeme "DEFINER"++ lexeme "AS"+ space+ functionBody <- cs <$> between (char '$' >> char '$') (char '$' >> char '$') (many (anySingleBut '$'))+ space++ language <- case language of+ Just language -> pure language+ Nothing -> do+ lexeme "language" <|> lexeme "LANGUAGE"+ symbol' "plpgsql" <|> symbol' "SQL"+ char ';'+ pure CreateFunction { functionName, functionArguments, functionBody, orReplace, returns, language, securityDefiner }+ where+ functionArgument = do+ argumentName <- qualifiedIdentifier+ space+ argumentType <- sqlType+ pure (argumentName, argumentType)++createTrigger = do+ lexeme "CREATE"+ createEventTrigger <|> createTrigger'++createEventTrigger = do+ lexeme "EVENT"+ lexeme "TRIGGER"++ name <- qualifiedIdentifier+ lexeme "ON"+ eventOn <- identifier++ whenCondition <- optional do+ lexeme "WHEN"+ expression++ lexeme "EXECUTE"+ (lexeme "FUNCTION") <|> (lexeme "PROCEDURE")++ (CallExpression functionName arguments) <- callExpr++ char ';'++ pure CreateEventTrigger+ { name+ , eventOn+ , whenCondition+ , functionName+ , arguments+ }++++createTrigger' = do+ lexeme "TRIGGER"++ name <- qualifiedIdentifier+ eventWhen <- (lexeme "AFTER" >> pure After) <|> (lexeme "BEFORE" >> pure Before) <|> (lexeme "INSTEAD OF" >> pure InsteadOf)+ event <- triggerEvent `sepBy1` lexeme "OR"++ lexeme "ON"+ tableName <- qualifiedIdentifier++ lexeme "FOR"+ optional (lexeme "EACH")++ for <- (lexeme "ROW" >> pure ForEachRow) <|> (lexeme "STATEMENT" >> pure ForEachStatement)++ whenCondition <- optional do+ lexeme "WHEN"+ expression++ lexeme "EXECUTE"+ optional (lexeme "FUNCTION" <|> lexeme "PROCEDURE")++ (CallExpression functionName arguments) <- callExpr++ char ';'++ pure CreateTrigger+ { name+ , eventWhen+ , event+ , tableName+ , for+ , whenCondition+ , functionName+ , arguments+ }++triggerEvent :: Parser TriggerEvent+triggerEvent = (lexeme "INSERT" >> pure TriggerOnInsert) <|> (lexeme "UPDATE" >> pure TriggerOnUpdate) <|> (lexeme "DELETE" >> pure TriggerOnDelete) <|> (lexeme "TRUNCATE" >> pure TriggerOnTruncate)++alterTable = do+ lexeme "TABLE"+ optional (lexeme "ONLY")+ tableName <- qualifiedIdentifier+ let add = do+ lexeme "ADD"+ let addUnique = do+ unique <- parseUniqueConstraint Nothing+ deferrable <- optional parseDeferrable+ deferrableType <- optional parseDeferrableType+ char ';'+ pure (AddConstraint tableName unique deferrable deferrableType)+ addConstraint tableName <|> addColumn tableName <|> addUnique+ let drop = do+ lexeme "DROP"+ dropColumn tableName <|> dropConstraint tableName+ let rename = do+ lexeme "RENAME"+ renameColumn tableName <|> renameTable tableName+ let alter = do+ lexeme "ALTER"+ alterColumn tableName+ enableRowLevelSecurity tableName <|> add <|> drop <|> rename <|> alter++alterType = do+ lexeme "TYPE"+ typeName <- qualifiedIdentifier+ addValue typeName++alterSequence = do+ lexeme "SEQUENCE"+ raw <- cs <$> someTill (anySingle) (char ';')+ pure UnknownStatement { raw = "ALTER SEQUENCE " <> raw };++-- | ALTER TABLE users ALTER COLUMN email DROP NOT NULL;+-- ALTER TABLE users ALTER COLUMN email SET NOT NULL;+-- ALTER TABLE users ALTER COLUMN email SET DEFAULT 'value';+-- ALTER TABLE users ALTER COLUMN email DROP DEFAULT;+alterColumn tableName = do+ lexeme "COLUMN"+ columnName <- identifier++ let drop = do+ lexeme "DROP"+ let notNull = do+ lexeme "NOT"+ lexeme "NULL"+ char ';'+ pure DropNotNull { tableName, columnName }+ let defaultValue = do+ lexeme "DEFAULT"+ char ';'+ pure DropDefaultValue { tableName, columnName }+ notNull <|> defaultValue++ let set = do+ lexeme "SET"+ let notNull = do+ lexeme "NOT"+ lexeme "NULL"+ char ';'+ pure SetNotNull { tableName, columnName }+ let defaultValue = do+ lexeme "DEFAULT"+ value <- expression+ char ';'+ pure SetDefaultValue { tableName, columnName, value }+ notNull <|> defaultValue++ drop <|> set+++++enableRowLevelSecurity tableName = do+ lexeme "ENABLE"+ lexeme "ROW"+ lexeme "LEVEL"+ lexeme "SECURITY"+ char ';'+ pure EnableRowLevelSecurity { tableName }++createPolicy = do+ lexeme "CREATE"+ lexeme "POLICY"+ name <- identifier+ lexeme "ON"+ tableName <- qualifiedIdentifier++ action <- optional (lexeme "FOR" >> policyAction)++ using <- optional do+ lexeme "USING"+ expression++ check <- optional do+ lexeme "WITH"+ lexeme "CHECK"+ expression++ char ';'++ pure CreatePolicy { name, action, tableName, using, check }++policyAction =+ (lexeme "ALL" >> pure PolicyForAll)+ <|> (lexeme "SELECT" >> pure PolicyForSelect)+ <|> (lexeme "INSERT" >> pure PolicyForInsert)+ <|> (lexeme "UPDATE" >> pure PolicyForUpdate)+ <|> (lexeme "DELETE" >> pure PolicyForDelete)++setStatement = do+ lexeme "SET"+ name <- identifier+ lexeme "="+ value <- expression+ char ';'+ pure Set { name, value }++selectStatement = do+ lexeme "SELECT"+ query <- takeWhile1P (Just "SQL Query") (\c -> c /= ';')+ char ';'+ pure SelectStatement { query }+++commentStatement = do+ lexeme "COMMENT"+ content <- takeWhile1P (Just "SQL Query") (\c -> c /= ';')+ char ';'+ pure Comment { content }++qualifiedIdentifier = do+ optional $ try do+ lexeme "public"+ char '.'+ identifier++addColumn tableName = do+ lexeme "COLUMN"+ (_, column) <- parseColumn+ char ';'+ pure AddColumn { tableName, column }++dropColumn tableName = do+ lexeme "COLUMN"+ columnName <- identifier+ char ';'+ pure DropColumn { tableName, columnName }++dropConstraint tableName = do+ lexeme "CONSTRAINT"+ constraintName <- identifier+ char ';'+ pure DropConstraint { tableName, constraintName }++renameColumn tableName = do+ lexeme "COLUMN"+ from <- identifier+ lexeme "TO"+ to <- identifier+ char ';'+ pure RenameColumn { tableName, from, to }++renameTable tableName = do+ lexeme "TO"+ to <- identifier+ char ';'+ pure RenameTable { from = tableName, to }++dropTable = do+ lexeme "DROP"+ lexeme "TABLE"+ tableName <- identifier+ char ';'+ pure DropTable { tableName }++dropType = do+ lexeme "DROP"+ lexeme "TYPE"+ name <- qualifiedIdentifier+ char ';'+ pure DropEnumType { name }++dropFunction = do+ lexeme "DROP"+ lexeme "FUNCTION"+ functionName <- qualifiedIdentifier+ char ';'+ pure DropFunction { functionName }++dropIndex = do+ lexeme "DROP"+ lexeme "INDEX"+ indexName <- qualifiedIdentifier+ char ';'+ pure DropIndex { indexName }++dropPolicy = do+ lexeme "DROP"+ lexeme "POLICY"+ policyName <- qualifiedIdentifier+ lexeme "ON"+ tableName <- qualifiedIdentifier+ char ';'+ pure DropPolicy { tableName, policyName }++dropTrigger = do+ lexeme "DROP"++ dropEventTrigger <|> dropTrigger'++dropTrigger' = do+ lexeme "TRIGGER"+ name <- qualifiedIdentifier+ lexeme "ON"+ tableName <- qualifiedIdentifier+ char ';'+ pure DropTrigger { name, tableName }+++dropEventTrigger = do+ lexeme "EVENT"+ lexeme "TRIGGER"+ name <- qualifiedIdentifier+ char ';'+ pure DropEventTrigger { name }++createSequence = do+ lexeme "CREATE"+ lexeme "SEQUENCE"+ name <- qualifiedIdentifier++ -- We accept all the following SEQUENCE attributes, but don't save them+ -- This is mostly to void issues in migrations when parsing the pg_dump output+ optional do+ lexeme "AS"+ sqlType++ optional do+ lexeme "START"+ lexeme "WITH"+ expression++ optional do+ lexeme "INCREMENT"+ lexeme "BY"+ expression++ optional do+ lexeme "NO"+ lexeme "MINVALUE"++ optional do+ lexeme "NO"+ lexeme "MAXVALUE"++ optional do+ lexeme "CACHE"+ expression++ char ';'+ pure CreateSequence { name }++addValue typeName = do+ lexeme "ADD"+ lexeme "VALUE"+ ifNotExists <- isJust <$> optional do+ lexeme "IF"+ lexeme "NOT"+ lexeme "EXISTS"+ newValue <- textExpr'+ char ';'+ pure AddValueToEnumType { enumName = typeName, newValue, ifNotExists }++begin = do+ lexeme "BEGIN"+ char ';'+ pure Begin++commit = do+ lexeme "COMMIT"+ char ';'+ pure Commit++-- | Turns sql like '1::double precision' into just '1'+removeTypeCasts :: Expression -> Expression+removeTypeCasts (TypeCastExpression value _) = value+removeTypeCasts otherwise = otherwise++restrict = do+ lexeme "\\restrict"+ key <- identifier+ pure Comment { content = "" }++unrestrict = do+ lexeme "\\unrestrict"+ key <- identifier+ pure Comment { content = "" }
+ IHP/Postgres/Types.hs view
@@ -0,0 +1,338 @@+{-|+Module: IHP.Postgres.Types+Description: Types for representing an AST of SQL DDL+Copyright: (c) digitally induced GmbH, 2020+-}+module IHP.Postgres.Types where++import Prelude+import Data.Text (Text)++data Statement+ =+ -- | CREATE TABLE name ( columns );+ StatementCreateTable { unsafeGetCreateTable :: CreateTable }+ -- | CREATE TYPE name AS ENUM ( values );+ | CreateEnumType { name :: Text, values :: [Text] }+ -- | DROP TYPE name;+ | DropEnumType { name :: Text }+ -- | CREATE EXTENSION IF NOT EXISTS "name";+ | CreateExtension { name :: Text, ifNotExists :: Bool }+ -- | ALTER TABLE tableName ADD CONSTRAINT constraint;+ | AddConstraint { tableName :: Text, constraint :: Constraint, deferrable :: Maybe Bool, deferrableType :: Maybe DeferrableType }+ -- | ALTER TABLE tableName DROP CONSTRAINT constraintName;+ | DropConstraint { tableName, constraintName :: Text }+ -- | ALTER TABLE tableName ADD COLUMN column;+ | AddColumn { tableName :: Text, column :: Column }+ -- | ALTER TABLE tableName DROP COLUMN columnName;+ | DropColumn { tableName :: Text, columnName :: Text }+ -- | DROP TABLE tableName;+ | DropTable { tableName :: Text }+ | UnknownStatement { raw :: Text }+ | Comment { content :: Text }+ -- | CREATE INDEX indexName ON tableName (columnName); CREATE INDEX indexName ON tableName (LOWER(columnName));+ -- | CREATE UNIQUE INDEX name ON table (column [, ...]);+ | CreateIndex { indexName :: Text, unique :: Bool, tableName :: Text, columns :: [IndexColumn], whereClause :: Maybe Expression, indexType :: Maybe IndexType }+ -- | DROP INDEX indexName;+ | DropIndex { indexName :: Text }+ -- | CREATE OR REPLACE FUNCTION functionName(param1 TEXT, param2 INT) RETURNS TRIGGER AS $$functionBody$$ language plpgsql;+ | CreateFunction { functionName :: Text, functionArguments :: [(Text, PostgresType)], functionBody :: Text, orReplace :: Bool, returns :: PostgresType, language :: Text, securityDefiner :: Bool }+ -- | ALTER TABLE tableName ENABLE ROW LEVEL SECURITY;+ | EnableRowLevelSecurity { tableName :: Text }+ -- CREATE POLICY name ON tableName USING using WITH CHECK check;+ | CreatePolicy { name :: Text, tableName :: Text, action :: Maybe PolicyAction, using :: Maybe Expression, check :: Maybe Expression }+ -- SET name = value;+ | Set { name :: Text, value :: Expression }+ -- SELECT query;+ | SelectStatement { query :: Text }+ -- CREATE SEQUENCE name;+ | CreateSequence { name :: Text }+ -- ALTER TABLE tableName RENAME COLUMN from TO to;+ | RenameColumn { tableName :: Text, from :: Text, to :: Text }+ -- ALTER TYPE enumName ADD VALUE newValue;+ | AddValueToEnumType { enumName :: Text, newValue :: Text, ifNotExists :: Bool }+ -- ALTER TABLE tableName ALTER COLUMN columnName DROP NOT NULL;+ | DropNotNull { tableName :: Text, columnName :: Text }+ -- ALTER TABLE tableName ALTER COLUMN columnName SET NOT NULL;+ | SetNotNull { tableName :: Text, columnName :: Text }+ -- | ALTER TABLE from RENAME TO to;+ | RenameTable { from :: Text, to :: Text }+ -- | DROP POLICY policyName ON tableName;+ | DropPolicy { tableName :: Text, policyName :: Text }+ -- ALTER TABLE tableName ALTER COLUMN columnName SET DEFAULT 'value';+ | SetDefaultValue { tableName :: Text, columnName :: Text, value :: Expression }+ -- ALTER TABLE tableName ALTER COLUMN columnName DROP DEFAULT;+ | DropDefaultValue { tableName :: Text, columnName :: Text }+ -- | CREATE TRIGGER ..;+ | CreateTrigger { name :: !Text, eventWhen :: !TriggerEventWhen, event :: ![TriggerEvent], tableName :: !Text, for :: !TriggerFor, whenCondition :: Maybe Expression, functionName :: !Text, arguments :: ![Expression] }+ -- | CREATE EVENT TRIGGER ..;+ | CreateEventTrigger { name :: !Text, eventOn :: !Text, whenCondition :: Maybe Expression, functionName :: !Text, arguments :: ![Expression] }+ -- | DROP TRIGGER .. ON ..;+ | DropTrigger { name :: !Text, tableName :: !Text }+ -- | DROP EVENT TRIGGER ..;+ | DropEventTrigger { name :: !Text }+ -- | BEGIN;+ | Begin+ -- | COMMIT;+ | Commit+ | DropFunction { functionName :: !Text }+ deriving (Eq, Show)++data DeferrableType+ = InitiallyImmediate+ | InitiallyDeferred+ deriving (Eq, Show)++data CreateTable+ = CreateTable+ { name :: Text+ , columns :: [Column]+ , primaryKeyConstraint :: PrimaryKeyConstraint+ , constraints :: [Constraint]+ , unlogged :: !Bool+ , inherits :: !(Maybe Text)+ }+ deriving (Eq, Show)++data Column = Column+ { name :: Text+ , columnType :: PostgresType+ , defaultValue :: Maybe Expression+ , notNull :: Bool+ , isUnique :: Bool+ , generator :: Maybe ColumnGenerator+ }+ deriving (Eq, Show)++data OnDelete+ = NoAction+ | Restrict+ | SetNull+ | SetDefault+ | Cascade+ deriving (Show, Eq)++data ColumnGenerator+ = ColumnGenerator+ { generate :: !Expression+ , stored :: !Bool+ } deriving (Show, Eq)++newtype PrimaryKeyConstraint+ = PrimaryKeyConstraint { primaryKeyColumnNames :: [Text] }+ deriving (Eq, Show)++data Constraint+ -- | FOREIGN KEY (columnName) REFERENCES referenceTable (referenceColumn) ON DELETE onDelete;+ = ForeignKeyConstraint+ { name :: !(Maybe Text)+ , columnName :: !Text+ , referenceTable :: !Text+ , referenceColumn :: !(Maybe Text)+ , onDelete :: !(Maybe OnDelete)+ }+ | UniqueConstraint+ { name :: !(Maybe Text)+ , columnNames :: ![Text]+ }+ | CheckConstraint+ { name :: !(Maybe Text)+ , checkExpression :: !Expression+ }+ | ExcludeConstraint+ { name :: !(Maybe Text)+ , excludeElements :: ![ExcludeConstraintElement]+ , predicate :: !(Maybe Expression)+ , indexType :: !(Maybe IndexType)+ }+ | AlterTableAddPrimaryKey+ { name :: !(Maybe Text)+ , primaryKeyConstraint :: !PrimaryKeyConstraint+ }+ deriving (Eq, Show)++data ExcludeConstraintElement = ExcludeConstraintElement { element :: !Text, operator :: !Text }+ deriving (Eq, Show)++data Expression =+ -- | Sql string like @'hello'@+ TextExpression Text+ -- | Simple variable like @users@+ | VarExpression Text+ -- | Simple call, like @COALESCE(name, 'unknown name')@+ | CallExpression Text [Expression]+ -- | Not equal operator, a <> b+ | NotEqExpression Expression Expression+ -- | Equal operator, a = b+ | EqExpression Expression Expression+ -- | a AND b+ | AndExpression Expression Expression+ -- | a IS b+ | IsExpression Expression Expression+ -- | a IN b+ | InExpression Expression Expression+ -- | ('a', 'b')+ | InArrayExpression [Expression]+ -- | NOT a+ | NotExpression Expression+ -- | EXISTS a+ | ExistsExpression Expression+ -- | a OR b+ | OrExpression Expression Expression+ -- | a < b+ | LessThanExpression Expression Expression+ -- | a <= b+ | LessThanOrEqualToExpression Expression Expression+ -- | a > b+ | GreaterThanExpression Expression Expression+ -- | a >= b+ | GreaterThanOrEqualToExpression Expression Expression+ -- | Double literal value, e.g. 0.1337+ | DoubleExpression Double+ -- | Integer literal value, e.g. 1337+ | IntExpression Int+ -- | value::type+ | TypeCastExpression Expression PostgresType+ | SelectExpression Select+ | DotExpression Expression Text+ | ConcatenationExpression Expression Expression -- ^ a || b+ deriving (Eq, Show)++data Select = Select+ { columns :: [Expression]+ , from :: Expression+ , alias :: Maybe Text+ , whereClause :: Expression+ } deriving (Eq, Show)++data PostgresType+ = PUUID+ | PText+ | PInt+ | PSmallInt+ | PBigInt+ | PBoolean+ | PTimestampWithTimezone+ | PTimestamp+ | PReal+ | PDouble+ | PPoint+ | PPolygon+ | PDate+ | PBinary+ | PTime+ | PInterval { fields :: Maybe Text }+ | PNumeric { precision :: Maybe Int, scale :: Maybe Int }+ | PVaryingN (Maybe Int)+ | PCharacterN Int+ | PSingleChar+ | PSerial+ | PBigserial+ | PJSONB+ | PInet+ | PTSVector+ | PArray PostgresType+ | PTrigger+ | PEventTrigger+ | PCustomType Text+ deriving (Eq, Show)++data TriggerEventWhen+ = Before+ | After+ | InsteadOf+ deriving (Eq, Show)++data TriggerEvent+ = TriggerOnInsert+ | TriggerOnUpdate+ | TriggerOnDelete+ | TriggerOnTruncate+ deriving (Eq, Show)++data TriggerFor+ = ForEachRow+ | ForEachStatement+ deriving (Eq, Show)++data PolicyAction+ = PolicyForAll+ | PolicyForSelect+ | PolicyForInsert+ | PolicyForUpdate+ | PolicyForDelete+ deriving (Eq, Show)++data IndexType = Btree | Gin | Gist+ deriving (Eq, Show)++data IndexColumn+ = IndexColumn { column :: Expression, columnOrder :: [IndexColumnOrder] }+ deriving (Eq, Show)++data IndexColumnOrder+ = Asc | Desc | NullsFirst | NullsLast+ deriving (Eq, Show)++-- | Helper to create a 'CreateTable' with sensible defaults (empty columns, no constraints, logged).+table :: Text -> CreateTable+table name = CreateTable+ { name = name+ , columns = []+ , primaryKeyConstraint = PrimaryKeyConstraint []+ , constraints = []+ , unlogged = False+ , inherits = Nothing+ }++-- | Helper to create a 'Column' with sensible defaults (nullable, no default, not unique, no generator).+col :: Text -> PostgresType -> Column+col columnName columnType = Column+ { name = columnName+ , columnType = columnType+ , defaultValue = Nothing+ , notNull = False+ , isUnique = False+ , generator = Nothing+ }++-- | Helper to create a 'CreateFunction' with sensible defaults (no args, empty body, plpgsql trigger).+function :: Text -> Statement+function functionName = CreateFunction+ { functionName = functionName+ , functionArguments = []+ , functionBody = ""+ , orReplace = False+ , returns = PTrigger+ , language = "plpgsql"+ , securityDefiner = False+ }++-- | Helper to create an 'IndexColumn' with no column ordering.+indexCol :: Expression -> IndexColumn+indexCol column = IndexColumn { column = column, columnOrder = [] }++-- | Helper to create a 'CreatePolicy' with sensible defaults (no action, no using, no check).+policy :: Text -> Text -> Statement+policy name tableName = CreatePolicy+ { name = name+ , tableName = tableName+ , action = Nothing+ , using = Nothing+ , check = Nothing+ }++-- | Helper to create an 'AddConstraint' with a foreign key (no name, no onDelete, no deferrable).+foreignKey :: Text -> Text -> Text -> Statement+foreignKey tableName columnName referenceTable = AddConstraint+ { tableName = tableName+ , constraint = ForeignKeyConstraint+ { name = Nothing+ , columnName = columnName+ , referenceTable = referenceTable+ , referenceColumn = Nothing+ , onDelete = Nothing+ }+ , deferrable = Nothing+ , deferrableType = Nothing+ }
+ Test/Postgres/CompilerSpec.hs view
@@ -0,0 +1,189 @@+{-|+Module: Postgres.CompilerSpec+Copyright: (c) digitally induced GmbH, 2020+-}+module Postgres.CompilerSpec where++import Prelude+import Test.Hspec+import IHP.Postgres.Compiler (compileSql)+import IHP.Postgres.Types+import Data.Text (Text)+import qualified Data.Text as Text+import Data.String.Conversions (cs)+import qualified Text.Megaparsec as Megaparsec+import IHP.Postgres.Parser (parseDDL)++spec :: Spec+spec = do+ describe "The Schema.sql Compiler" do+ it "should compile an empty CREATE TABLE statement" do+ compileSql [StatementCreateTable (table "users")] `shouldBe` "CREATE TABLE users (\n\n);\n"++ it "should compile a CREATE EXTENSION for the UUID extension" do+ compileSql [CreateExtension { name = "uuid-ossp", ifNotExists = True }] `shouldBe` "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";\n"++ it "should compile a line comment" do+ compileSql [Comment { content = " Comment value" }] `shouldBe` "-- Comment value\n"++ it "should compile a empty line comments" do+ compileSql [Comment { content = "" }, Comment { content = "" }] `shouldBe` "--\n--\n"++ it "should compile a CREATE TABLE with columns" do+ let sql = "CREATE TABLE users (\n id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n firstname TEXT NOT NULL,\n lastname TEXT NOT NULL,\n password_hash TEXT NOT NULL,\n email TEXT NOT NULL,\n company_id UUID NOT NULL,\n picture_url TEXT,\n created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n);\n"+ let statement = StatementCreateTable (table "users")+ { columns = [+ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+ , (col "firstname" PText) { notNull = True }+ , (col "lastname" PText) { notNull = True }+ , (col "password_hash" PText) { notNull = True }+ , (col "email" PText) { notNull = True }+ , (col "company_id" PUUID) { notNull = True }+ , col "picture_url" PText+ , (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+ ]+ , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+ }+ compileSql [statement] `shouldBe` sql++ it "should compile a CREATE TABLE with quoted identifiers" do+ compileSql [StatementCreateTable (table "quoted name")] `shouldBe` "CREATE TABLE \"quoted name\" (\n\n);\n"++ it "should compile ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do+ let statement = AddConstraint+ { tableName = "users"+ , constraint = ForeignKeyConstraint+ { name = Just "users_ref_company_id"+ , columnName = "company_id"+ , referenceTable = "companies"+ , referenceColumn = Just "id"+ , onDelete = Just Cascade+ }+ , deferrable = Nothing+ , deferrableType = Nothing+ }+ compileSql [statement] `shouldBe` "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE CASCADE;\n"++ it "should compile ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+ let statement = AddConstraint+ { tableName = "posts"+ , constraint = CheckConstraint+ { name = Just "check_title_length"+ , checkExpression = NotEqExpression (VarExpression "title") (TextExpression "")+ }+ , deferrable = Nothing+ , deferrableType = Nothing+ }+ compileSql [statement] `shouldBe` "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');\n"++ it "should compile a CREATE TYPE .. AS ENUM" do+ let sql = "CREATE TYPE colors AS ENUM ('yellow', 'red', 'blue');\n"+ let statement = CreateEnumType+ { name = "colors"+ , values = ["yellow", "red", "blue"]+ }+ compileSql [statement] `shouldBe` sql++ it "should compile a CREATE TABLE statement with a serial id" do+ let sql = "CREATE TABLE orders (\n id SERIAL PRIMARY KEY NOT NULL\n);\n"+ let statement = StatementCreateTable (table "orders")+ { columns = [ (col "id" PSerial) { notNull = True } ]+ , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+ }+ compileSql [statement] `shouldBe` sql++ it "should compile a CREATE INDEX statement" do+ let sql = "CREATE INDEX users_index ON users (user_name);\n"+ let statement = CreateIndex+ { indexName = "users_index"+ , unique = False+ , tableName = "users"+ , columns = [indexCol (VarExpression "user_name")]+ , whereClause = Nothing+ , indexType = Nothing+ }+ compileSql [statement] `shouldBe` sql++ it "should compile a CREATE UNIQUE INDEX statement" do+ let sql = "CREATE UNIQUE INDEX users_index ON users (user_name);\n"+ let statement = CreateIndex+ { indexName = "users_index"+ , unique = True+ , tableName = "users"+ , columns = [indexCol (VarExpression "user_name")]+ , whereClause = Nothing+ , indexType = Nothing+ }+ compileSql [statement] `shouldBe` sql++ it "should compile 'ENABLE ROW LEVEL SECURITY' statements" do+ let sql = "ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;\n"+ let statements = [EnableRowLevelSecurity { tableName = "tasks" }]+ compileSql statements `shouldBe` sql++ it "should compile 'CREATE POLICY' statements" do+ let sql = "CREATE POLICY \"Users can manage their tasks\" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());\n"+ let p = (policy "Users can manage their tasks" "tasks")+ { using = Just (+ EqExpression+ (VarExpression "user_id")+ (CallExpression "ihp_user_id" [])+ )+ , check = Just (+ EqExpression+ (VarExpression "user_id")+ (CallExpression "ihp_user_id" [])+ )+ }+ compileSql [p] `shouldBe` sql++ it "should compile 'DROP TABLE ..' statements" do+ let sql = "DROP TABLE tasks;\n"+ let statements = [ DropTable { tableName = "tasks" } ]+ compileSql statements `shouldBe` sql++ it "should compile 'CREATE SEQUENCE ..' statements" do+ let sql = "CREATE SEQUENCE a;\n"+ let statements = [ CreateSequence { name = "a" } ]+ compileSql statements `shouldBe` sql++ it "should compile 'DROP TYPE ..;' statements" do+ let sql = "DROP TYPE colors;\n"+ let statements = [ DropEnumType { name = "colors" } ]+ compileSql statements `shouldBe` sql++ it "should compile 'BEGIN;' statements" do+ let sql = "BEGIN;\n"+ let statements = [ Begin ]+ compileSql statements `shouldBe` sql++ it "should compile 'COMMIT;' statements" do+ let sql = "COMMIT;\n"+ let statements = [ Commit ]+ compileSql statements `shouldBe` sql++ it "should compile 'CREATE TABLE .. INHERITS (..)' statements" do+ let sql = "CREATE TABLE post_revisions (\n revision_content TEXT NOT NULL\n) INHERITS (posts);\n"+ let statements = [+ StatementCreateTable (table "post_revisions")+ { columns = [(col "revision_content" PText) { notNull = True }]+ , inherits = Just "posts"+ }+ ]+ compileSql statements `shouldBe` sql++ it "should compile 'CREATE UNLOGGED TABLE' statements" do+ let sql = "CREATE UNLOGGED TABLE pg_large_notifications (\n\n);\n"+ let statements = [+ StatementCreateTable (table "pg_large_notifications")+ { unlogged = True, inherits = Nothing+ }+ ]+ compileSql statements `shouldBe` sql++parseSql :: Text -> Statement+parseSql sql =+ case Megaparsec.runParser parseDDL "input" sql of+ Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError)+ Right [statement] -> statement+ Right statements -> error $ "Expected single statement but got: " <> show (length statements)
+ Test/Postgres/ParserSpec.hs view
@@ -0,0 +1,192 @@+{-|+Module: Postgres.ParserSpec+Copyright: (c) digitally induced GmbH, 2020+-}+module Postgres.ParserSpec where++import Prelude+import Test.Hspec+import IHP.Postgres.Parser+import IHP.Postgres.Types+import Data.Text (Text)+import qualified Data.Text as Text+import Data.String.Conversions (cs)+import qualified Text.Megaparsec as Megaparsec+import GHC.IO (evaluate)++spec :: Spec+spec = do+ describe "The Schema.sql Parser" do+ it "should parse an empty CREATE TABLE statement" do+ parseSql "CREATE TABLE users ();" `shouldBe` StatementCreateTable (table "users")++ it "should parse an CREATE EXTENSION for the UUID extension" do+ parseSql "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" `shouldBe` CreateExtension { name = "uuid-ossp", ifNotExists = True }++ it "should parse an CREATE EXTENSION with schema suffix" do+ parseSql "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\" WITH SCHEMA public;" `shouldBe` CreateExtension { name = "uuid-ossp", ifNotExists = True }++ it "should parse a line comment" do+ parseSql "-- Comment value" `shouldBe` Comment { content = " Comment value" }++ it "should parse an empty comment" do+ parseSqlStatements "--\n--" `shouldBe` [ Comment { content = "" }, Comment { content = "" } ]++ it "should parse a CREATE TABLE with columns" do+ let sql = "CREATE TABLE users (\n id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,\n firstname TEXT NOT NULL,\n lastname TEXT NOT NULL,\n password_hash TEXT NOT NULL,\n email TEXT NOT NULL,\n company_id UUID NOT NULL,\n picture_url TEXT,\n created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL\n ); "+ parseSql sql `shouldBe` StatementCreateTable (table "users")+ { columns = [+ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True }+ , (col "firstname" PText) { notNull = True }+ , (col "lastname" PText) { notNull = True }+ , (col "password_hash" PText) { notNull = True }+ , (col "email" PText) { notNull = True }+ , (col "company_id" PUUID) { notNull = True }+ , col "picture_url" PText+ , (col "created_at" PTimestampWithTimezone) { defaultValue = Just (CallExpression "NOW" []), notNull = True }+ ]+ , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+ , constraints = []+ , unlogged = False+ , inherits = Nothing+ }++ it "should parse a CREATE TABLE with quoted identifiers" do+ parseSql "CREATE TABLE \"quoted name\" ();" `shouldBe` StatementCreateTable (table "quoted name")++ it "should parse a CREATE TABLE with public schema prefix" do+ parseSql "CREATE TABLE public.users ();" `shouldBe` StatementCreateTable (table "users")++ it "should parse ALTER TABLE .. ADD FOREIGN KEY .. ON DELETE CASCADE" do+ parseSql "ALTER TABLE users ADD CONSTRAINT users_ref_company_id FOREIGN KEY (company_id) REFERENCES companies (id) ON DELETE CASCADE;" `shouldBe` AddConstraint+ { tableName = "users"+ , constraint = ForeignKeyConstraint+ { name = Just "users_ref_company_id"+ , columnName = "company_id"+ , referenceTable = "companies"+ , referenceColumn = Just "id"+ , onDelete = Just Cascade+ }+ , deferrable = Nothing+ , deferrableType = Nothing+ }++ it "should parse ALTER TABLE .. ADD CONSTRAINT .. CHECK .." do+ parseSql "ALTER TABLE posts ADD CONSTRAINT check_title_length CHECK (title <> '');" `shouldBe` AddConstraint+ { tableName = "posts"+ , constraint = CheckConstraint+ { name = Just "check_title_length"+ , checkExpression = NotEqExpression (VarExpression "title") (TextExpression "")+ }+ , deferrable = Nothing+ , deferrableType = Nothing+ }++ it "should parse CREATE TYPE .. AS ENUM" do+ parseSql "CREATE TYPE colors AS ENUM ('yellow', 'red', 'green');" `shouldBe` CreateEnumType { name = "colors", values = ["yellow", "red", "green"] }++ it "should parse ALTER TYPE .. ADD VALUE .." do+ parseSql "ALTER TYPE colors ADD VALUE 'blue';" `shouldBe` AddValueToEnumType { enumName = "colors", newValue = "blue", ifNotExists = False }++ 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` StatementCreateTable (table "orders")+ { columns = [ (col "id" PSerial) { notNull = True} ]+ , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+ }++ it "should parse a column with NOT NULL before DEFAULT" do+ parseSql "CREATE TABLE tasks (is_completed BOOLEAN NOT NULL DEFAULT false);" `shouldBe` StatementCreateTable (table "tasks")+ { columns = [ (col "is_completed" PBoolean) { defaultValue = Just (VarExpression "false"), notNull = True } ]+ }++ it "should parse column modifiers in mixed order" do+ parseSql "CREATE TABLE orders (id UUID PRIMARY KEY DEFAULT uuid_generate_v4() NOT NULL);" `shouldBe` StatementCreateTable (table "orders")+ { columns = [ (col "id" PUUID) { defaultValue = Just (CallExpression "uuid_generate_v4" []), notNull = True } ]+ , primaryKeyConstraint = PrimaryKeyConstraint ["id"]+ }++ it "should parse a CREATE INDEX statement" do+ parseSql "CREATE INDEX users_index ON users (user_name);\n" `shouldBe` CreateIndex+ { indexName = "users_index"+ , unique = False+ , tableName = "users"+ , columns = [indexCol (VarExpression "user_name")]+ , whereClause = Nothing+ , indexType = Nothing+ }++ it "should parse a CREATE UNIQUE INDEX statement" do+ parseSql "CREATE UNIQUE INDEX users_index ON users (user_name);\n" `shouldBe` CreateIndex+ { indexName = "users_index"+ , unique = True+ , tableName = "users"+ , columns = [indexCol (VarExpression "user_name")]+ , whereClause = Nothing+ , indexType = Nothing+ }++ it "should parse 'ENABLE ROW LEVEL SECURITY' statements" do+ parseSql "ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;" `shouldBe` EnableRowLevelSecurity { tableName = "tasks" }++ it "should parse 'CREATE POLICY' statements" do+ parseSql "CREATE POLICY \"Users can manage their tasks\" ON tasks USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());" `shouldBe`+ (policy "Users can manage their tasks" "tasks")+ { using = Just (+ EqExpression+ (VarExpression "user_id")+ (CallExpression "ihp_user_id" [])+ )+ , check = Just (+ EqExpression+ (VarExpression "user_id")+ (CallExpression "ihp_user_id" [])+ )+ }++ it "should parse 'DROP TABLE ..' statements" do+ parseSql "DROP TABLE tasks;" `shouldBe` DropTable { tableName = "tasks" }++ it "should parse 'DROP TYPE ..' statements" do+ parseSql "DROP TYPE colors;" `shouldBe` DropEnumType { name = "colors" }++ it "should parse 'CREATE SEQUENCE ..' statements" do+ parseSql "CREATE SEQUENCE a;" `shouldBe` CreateSequence { name = "a" }++ it "should parse 'BEGIN' statements" do+ parseSql "BEGIN;" `shouldBe` Begin++ it "should parse 'COMMIT' statements" do+ parseSql "COMMIT;" `shouldBe` Commit++ it "should parse 'CREATE UNLOGGED TABLE' statement" do+ parseSql "CREATE UNLOGGED TABLE pg_large_notifications ();" `shouldBe` StatementCreateTable (table "pg_large_notifications") { unlogged = True }++ it "should parse 'CREATE TABLE .. INHERITS (..)' statement" do+ parseSql "CREATE TABLE post_revisions (revision_content TEXT NOT NULL) INHERITS (posts);" `shouldBe` StatementCreateTable (table "post_revisions") { columns = [(col "revision_content" PText) { notNull = True }], inherits = Just "posts" }++ it "should parse positive IntExpression's" do+ parseExpression "1" `shouldBe` (IntExpression 1)++ it "should parse negative IntExpression's" do+ parseExpression "-1" `shouldBe` (IntExpression (-1))++ it "should parse positive DoubleExpression's" do+ parseExpression "1.337" `shouldBe` (DoubleExpression 1.337)++ it "should parse negative DoubleExpression's" do+ parseExpression "-1.337" `shouldBe` (DoubleExpression (-1.337))++parseSql :: Text -> Statement+parseSql sql = let [statement] = parseSqlStatements sql in statement++parseSqlStatements :: Text -> [Statement]+parseSqlStatements sql =+ case Megaparsec.runParser parseDDL "input" sql of+ Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError)+ Right statements -> statements++parseExpression :: Text -> Expression+parseExpression sql =+ case Megaparsec.runParser expression "input" sql of+ Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError)+ Right expr -> expr
+ Test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ ihp-postgres-parser.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.2+name: ihp-postgres-parser+version: 1.0.0+synopsis: PostgreSQL DDL parser and compiler+description: A standalone PostgreSQL DDL parser and SQL compiler extracted from IHP.+license: MIT+author: digitally induced GmbH+maintainer: hello@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Database, Parsing+stability: Stable+tested-with: GHC == 9.8.4+build-type: Simple++Flag FastBuild+ Default: False+ Description: Disables all optimisations, leads to faster build time++common shared-properties+ default-language: GHC2021+ build-depends:+ base >= 4.17.0 && < 4.22+ , filepath >= 1.5+ , text+ , megaparsec+ , parser-combinators+ , string-conversions+ , bytestring+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , DisambiguateRecordFields+ , DuplicateRecordFields+ , DataKinds+ , RecordWildCards+ , BlockArguments+ , LambdaCase+ , OverloadedRecordDot+ if flag(FastBuild)+ ghc-options:+ -Wunused-imports+ -Wunused-foralls+ -Werror=missing-fields+ -Winaccessible-code+ -Wno-ambiguous-fields+ -Werror=incomplete-patterns+ else+ ghc-options:+ -fstatic-argument-transformation+ -funbox-strict-fields+ -haddock++ -Wunused-imports+ -Wunused-foralls+ -Werror=missing-fields+ -Winaccessible-code+ -fspecialise-aggressively+ -Wno-ambiguous-fields+ -Werror=incomplete-patterns++library+ import: shared-properties+ hs-source-dirs: .+ exposed-modules:+ IHP.Postgres.Types+ , IHP.Postgres.Parser+ , IHP.Postgres.Compiler++test-suite spec+ import: shared-properties+ type: exitcode-stdio-1.0+ hs-source-dirs: Test+ main-is: Spec.hs+ other-modules:+ Postgres.ParserSpec+ , Postgres.CompilerSpec+ build-depends:+ ihp-postgres-parser+ , hspec++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp