Persistent schema backend, and PostgreSQL impl

src/Database/Persist/Schema.hs

@@ -0,0 +1,82 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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 ()

src/Database/Persist/Schema/PostgreSQL.hs

@@ -0,0 +1,140 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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
+        ]
+    }

src/Database/Persist/Schema/Sql.hs

@@ -0,0 +1,61 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | 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
+    }

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