diff --git a/src/Database/Persist/Schema.hs b/src/Database/Persist/Schema.hs new file mode 100644 index 0000000..9af5775 --- /dev/null +++ b/src/Database/Persist/Schema.hs @@ -0,0 +1,82 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Database.Persist.Schema + ( FieldName (..) + , EntityName (..) + , UniqueName (..) + , FieldType (..) + , MaybeNull (..) + , Field (..) + , Entity (..) + , Unique (..) + , PersistSchema (..) + ) +where + +import Prelude + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Text (Text) +import Database.Persist.Types (SqlType) + +newtype FieldName = FieldName { unFieldName :: Text } + +newtype EntityName = EntityName { unEntityName :: Text } + +newtype UniqueName = UniqueName { unUniqueName :: Text } + +data FieldType = FTPrim SqlType | FTRef + +data MaybeNull = MaybeNull | NotNull + +data Field = Field + { fieldName :: FieldName + , fieldType :: FieldType + , fieldNull :: MaybeNull + } + +data Entity = Entity + { entityName :: EntityName + , entityFields :: [Field] + , entityUniques :: [Unique] + } + +data Unique = Unique + { uniqueEntity :: EntityName + , uniqueName :: UniqueName + , uniqueFields :: [FieldName] + } + +class PersistSchema backend where + addEntity + :: MonadIO m => Entity -> ReaderT backend m () + removeEntity + :: MonadIO m => EntityName -> ReaderT backend m () + addField + :: MonadIO m => Field -> ReaderT backend m () + renameField + :: MonadIO m + => EntityName -> FieldName -> FieldName -> ReaderT backend m () + removeField + :: MonadIO m => EntityName -> FieldName -> ReaderT backend m () + addUnique + :: MonadIO m => Unique -> ReaderT backend m () + renameUnique + :: MonadIO m + => EntityName -> UniqueName -> UniqueName -> ReaderT backend m () + removeUnique + :: MonadIO m => EntityName -> UniqueName -> ReaderT backend m () diff --git a/src/Database/Persist/Schema/PostgreSQL.hs b/src/Database/Persist/Schema/PostgreSQL.hs new file mode 100644 index 0000000..f65261f --- /dev/null +++ b/src/Database/Persist/Schema/PostgreSQL.hs @@ -0,0 +1,140 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Database.Persist.Schema.PostgreSQL + ( + ) +where + +import Prelude + +import Data.Text (Text) +import Database.Persist.Types (SqlType (..)) +import Formatting + +import qualified Data.Text as T (empty, pack, intercalate, foldr) + +import Database.Persist.Schema +import Database.Persist.Schema.Sql + +quoteName :: Text -> Text +quoteName = + let f '\0' _ = error "quoteName found \\0 character, invalid in names" + f '"' cs = '"' : '"' : cs + f c cs = c : cs + in T.pack . T.foldr f [] + +table2sql :: TableName -> Text +table2sql = quoteName . unTableName + +column2sql :: ColumnName -> Text +column2sql = quoteName . unColumnName + +constraint2sql :: ConstraintName -> Text +constraint2sql = quoteName . unConstraintName + +typeSql :: SqlType -> Text +typeSql SqlString = "VARCHAR" +typeSql SqlInt32 = "INT4" +typeSql SqlInt64 = "INT8" +typeSql SqlReal = "DOUBLE PRECISION" +typeSql (SqlNumeric prec scale) = + sformat ("NUMERIC(" % int % "," % int % ")") prec scale +typeSql SqlDay = "DATE" +typeSql SqlTime = "TIME" +typeSql SqlDayTime = "TIMESTAMP WITH TIME ZONE" +typeSql SqlBlob = "BYTEA" +typeSql SqlBool = "BOOLEAN" +typeSql (SqlOther t) = t + +columnSql :: Column -> Text +columnSql (Column name typ mnull) = mconcat + [ column2sql name, " " + , typeSql typ + , case mnull of + MaybeNull -> " NULL" + NotNull -> " NOT NULL" + ] + +idCol :: ColumnName +idCol = ColumnName "id" + +idSql :: Text +idSql = "id SERIAL8 PRIMARY KEY UNIQUE" + +ssb :: SqlSchemaBackend +ssb = SqlSchemaBackend + { ssbCreateTable = \ table columns -> mconcat + [ "CREATE TABLE ", table2sql table, " (" + , idSql + , if null columns then T.empty else ", " + , T.intercalate ", " $ map columnSql columns + , ")" + ] + , ssbRenameTable = \ old new -> mconcat + [ "ALTER TABLE ", table2sql old + , " RENAME TO ", table2sql new + ] + , ssbDropTable = \ table -> mconcat + [ "DROP TABLE ", table2sql table + ] + , ssbAddColumn = \ table column -> mconcat + [ "ALTER TABLE ", table2sql table + , " ADD COLUMN ", columnSql column + ] + , ssbRenameColumn = \ table old new -> mconcat + [ "ALTER TABLE ", table2sql table + , " RENAME COLUMN ", column2sql old, " TO ", column2sql new + ] + , ssbRetypeColumn = \ table column typ -> mconcat + [ "ALTER TABLE ", table2sql table + , " ALTER COLUMN ", column2sql column + , " TYPE ", typeSql typ + ] + , ssbRenullColumn = \ table column mnull -> mconcat + [ "ALTER TABLE ", table2sql table + , " ALTER COLUMN ", column2sql column + , case mnull of + MaybeNull -> " DROP" + NotNull -> " SET" + , " NOT NULL" + ] + , ssbUnnullColumn = \ table column val -> mconcat + [ "UPDATE ", table2sql table + , " SET ", column2sql column, " = ", val + , " WHERE ", column2sql column, " IS NULL" + ] + , ssbDropColumn = \ table column -> mconcat + [ "ALTER TABLE ", table2sql table + , " DROP COLUMN ", column2sql column + ] + , ssbAddUnique = \ table constraint columns -> mconcat + [ "ALTER TABLE ", table2sql table + , " ADD CONSTRAINT ", constraint2sql constraint + , " UNIQUE(" + , T.intercalate ", " $ map column2sql columns + , ")" + ] + , ssbAddForeignKey = \ table constraint column target -> mconcat + [ "ALTER TABLE ", table2sql table + , " ADD CONSTRAINT ", constraint2sql constraint + , " FOREIGN KEY(", column2sql column + , ") REFERENCES ", table2sql target, "(", column2sql idCol, ")" + ] + , ssbDropConstraint = \ table constraint -> mconcat + [ "ALTER TABLE ", table2sql table + , " DROP CONSTRAINT ", constraint2sql constraint + ] + } diff --git a/src/Database/Persist/Schema/Sql.hs b/src/Database/Persist/Schema/Sql.hs new file mode 100644 index 0000000..7c9ae1e --- /dev/null +++ b/src/Database/Persist/Schema/Sql.hs @@ -0,0 +1,61 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | SQL schema backend specifying SQL statements for manipulating a SQL +-- database's table schema. +module Database.Persist.Schema.Sql + ( TableName (..) + , ColumnName (..) + , ConstraintName (..) + , Column (..) + , SqlSchemaBackend (..) + ) +where + +import Prelude + +import Data.Text (Text) +import Database.Persist.Sql (Sql) +import Database.Persist.Types (SqlType) + +import Database.Persist.Schema + +newtype TableName = TableName { unTableName :: Text } + +newtype ColumnName = ColumnName { unColumnName :: Text } + +newtype ConstraintName = ConstraintName { unConstraintName :: Text } + +data Column = Column + { colName :: ColumnName + , colType :: SqlType + , colNull :: MaybeNull + } + +data SqlSchemaBackend = SqlSchemaBackend + { ssbCreateTable :: TableName -> [Column] -> Sql + , ssbRenameTable :: TableName -> TableName -> Sql + , ssbDropTable :: TableName -> Sql + , ssbAddColumn :: TableName -> Column -> Sql + , ssbRenameColumn :: TableName -> ColumnName -> ColumnName -> Sql + , ssbRetypeColumn :: TableName -> ColumnName -> SqlType -> Sql + , ssbRenullColumn :: TableName -> ColumnName -> MaybeNull -> Sql + , ssbUnnullColumn :: TableName -> ColumnName -> Text -> Sql + , ssbDropColumn :: TableName -> ColumnName -> Sql + , ssbAddUnique :: TableName -> ConstraintName -> [ColumnName] -> Sql + , ssbAddForeignKey + :: TableName -> ConstraintName -> ColumnName -> TableName -> Sql + , ssbDropConstraint :: TableName -> ConstraintName -> Sql + } diff --git a/vervis.cabal b/vervis.cabal index 8d7fb99..f8dedf1 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -83,6 +83,9 @@ library Database.Persist.Local.Sql Database.Persist.Local.Sql.Orphan.Common Database.Persist.Local.Sql.Orphan.PersistQueryForest + Database.Persist.Schema + Database.Persist.Schema.PostgreSQL + Database.Persist.Schema.Sql Development.DarcsRev Diagrams.IntransitiveDAG Formatting.CaseInsensitive