diff --git a/src/Database/Persist/Schema.hs b/src/Database/Persist/Schema.hs index 9af5775..88a9b8d 100644 --- a/src/Database/Persist/Schema.hs +++ b/src/Database/Persist/Schema.hs @@ -22,6 +22,7 @@ module Database.Persist.Schema , Field (..) , Entity (..) , Unique (..) + , SchemaT , PersistSchema (..) ) where @@ -56,27 +57,38 @@ data Entity = Entity } data Unique = Unique - { uniqueEntity :: EntityName - , uniqueName :: UniqueName + { uniqueName :: UniqueName , uniqueFields :: [FieldName] } +type SchemaT b m a = ReaderT (SchemaBackend b) (ReaderT b m) a + +-- | Ideally we'd make the @backend@ provide schema related specifics. The +-- problem is that e.g. @SqlBackend@ is already defined in @persistent@ and +-- I'll need a patch to get it updated. A patch that will take time to get +-- accpted, if the maintainer likes it at all. So instead, I'm letting these +-- specifics be specified in a separate, associated data type. +-- +-- The only benefit I see for this approach is schema changes are separate from +-- data manipulations. You can't mix them in a single transaction without +-- explicitly specifying the schema backend and using 'lift' for data manip. class PersistSchema backend where + data SchemaBackend backend -- :: * addEntity - :: MonadIO m => Entity -> ReaderT backend m () + :: MonadIO m => Entity -> SchemaT backend m () removeEntity - :: MonadIO m => EntityName -> ReaderT backend m () + :: MonadIO m => EntityName -> SchemaT backend m () addField - :: MonadIO m => Field -> ReaderT backend m () + :: MonadIO m => EntityName -> Field -> SchemaT backend m () renameField :: MonadIO m - => EntityName -> FieldName -> FieldName -> ReaderT backend m () + => EntityName -> FieldName -> FieldName -> SchemaT backend m () removeField - :: MonadIO m => EntityName -> FieldName -> ReaderT backend m () + :: MonadIO m => EntityName -> FieldName -> SchemaT backend m () addUnique - :: MonadIO m => Unique -> ReaderT backend m () + :: MonadIO m => EntityName -> Unique -> SchemaT backend m () renameUnique :: MonadIO m - => EntityName -> UniqueName -> UniqueName -> ReaderT backend m () + => EntityName -> UniqueName -> UniqueName -> SchemaT backend m () removeUnique - :: MonadIO m => EntityName -> UniqueName -> ReaderT backend m () + :: MonadIO m => EntityName -> UniqueName -> SchemaT backend m () diff --git a/src/Database/Persist/Schema/PostgreSQL.hs b/src/Database/Persist/Schema/PostgreSQL.hs index f65261f..ca677cd 100644 --- a/src/Database/Persist/Schema/PostgreSQL.hs +++ b/src/Database/Persist/Schema/PostgreSQL.hs @@ -14,13 +14,14 @@ -} module Database.Persist.Schema.PostgreSQL - ( + ( schemaBackend ) where import Prelude import Data.Text (Text) +import Database.Persist.Sql (SqlBackend) import Database.Persist.Types (SqlType (..)) import Formatting @@ -74,9 +75,10 @@ idCol = ColumnName "id" idSql :: Text idSql = "id SERIAL8 PRIMARY KEY UNIQUE" -ssb :: SqlSchemaBackend -ssb = SqlSchemaBackend - { ssbCreateTable = \ table columns -> mconcat +schemaBackend :: SchemaBackend SqlBackend +schemaBackend = SqlSchemaBackend + { ssbRefType = SqlInt64 + , ssbCreateTable = \ table columns -> mconcat [ "CREATE TABLE ", table2sql table, " (" , idSql , if null columns then T.empty else ", " @@ -133,6 +135,10 @@ ssb = SqlSchemaBackend , " FOREIGN KEY(", column2sql column , ") REFERENCES ", table2sql target, "(", column2sql idCol, ")" ] + , ssbRenameConstraint = \ _table old new -> mconcat + [ "ALTER INDEX ", constraint2sql old + , " RENAME TO ", constraint2sql new + ] , 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 index 7c9ae1e..54309b9 100644 --- a/src/Database/Persist/Schema/Sql.hs +++ b/src/Database/Persist/Schema/Sql.hs @@ -20,16 +20,23 @@ module Database.Persist.Schema.Sql , ColumnName (..) , ConstraintName (..) , Column (..) - , SqlSchemaBackend (..) + , SchemaBackend (..) ) where import Prelude +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) +import Data.Char (isUpper, toLower) +import Data.Foldable (traverse_) import Data.Text (Text) -import Database.Persist.Sql (Sql) +import Database.Persist.Sql (Sql, SqlBackend, rawExecute) import Database.Persist.Types (SqlType) +import qualified Data.Text as T + import Database.Persist.Schema newtype TableName = TableName { unTableName :: Text } @@ -44,18 +51,110 @@ data Column = Column , 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 +exec :: MonadIO m => Sql -> SchemaT SqlBackend m () +exec t = lift $ rawExecute t [] + +camelWords :: Text -> [Text] +camelWords ident = + let low = toLower + slow = T.singleton . toLower + go c t l = + let (x, y) = T.break isUpper t + in case (T.null x, T.uncons y) of + (True, Nothing) -> slow c : l + (True, Just (d, r)) -> go d r $ slow c : l + (False, Nothing) -> (low c `T.cons` x) : l + (False, Just (d, r)) -> go d r $ (low c `T.cons` x) : l + (a, b) = T.break isUpper ident + in reverse $ case (T.null a, T.uncons b) of + (True, Nothing) -> [] + (True, Just (c, r)) -> go c r [] + (False, Nothing) -> [a] + (False, Just (c, r)) -> go c r [a] + +dbname :: Text -> Text +dbname = T.intercalate (T.singleton '_') . camelWords + +entity2table :: EntityName -> TableName +entity2table (EntityName t) = TableName $ dbname t + +field2column :: FieldName -> ColumnName +field2column (FieldName t) = ColumnName $ dbname t + +unique2constraint :: UniqueName -> ConstraintName +unique2constraint (UniqueName t) = ConstraintName $ dbname t + +type2sql :: SchemaBackend SqlBackend -> FieldType -> SqlType +type2sql _ (FTPrim t) = t +type2sql ssb FTRef = ssbRefType ssb + +mkcolumn :: SchemaBackend SqlBackend -> Field -> Column +mkcolumn ssb (Field name typ mnull) = Column + { colName = field2column name + , colType = type2sql ssb typ + , colNull = mnull } + +instance PersistSchema SqlBackend where + data SchemaBackend SqlBackend = SqlSchemaBackend + { ssbRefType :: SqlType + , 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 + , ssbRenameConstraint + :: TableName -> ConstraintName -> ConstraintName -> Sql + , ssbDropConstraint :: TableName -> ConstraintName -> Sql + } + addEntity (Entity name fields uniques) = do + ssb <- ask + exec $ + ssbCreateTable ssb (entity2table name) (map (mkcolumn ssb) fields) + traverse_ (addUnique name) uniques + removeEntity name = do + ssb <- ask + exec $ ssbDropTable ssb $ entity2table name + addField ent (Field name typ mnull) = do + ssb <- ask + exec $ + ssbAddColumn ssb (entity2table ent) $ + Column (field2column name) (type2sql ssb typ) mnull + renameField entity old new = do + ssb <- ask + exec $ + ssbRenameColumn ssb + (entity2table entity) + (field2column old) + (field2column new) + removeField entity field = do + ssb <- ask + exec $ ssbDropColumn ssb (entity2table entity) (field2column field) + addUnique entity (Unique name fields) = do + ssb <- ask + exec $ + ssbAddUnique ssb + (entity2table entity) + (unique2constraint name) + (map field2column fields) + renameUnique entity old new = do + ssb <- ask + exec $ + ssbRenameConstraint ssb + (entity2table entity) + (unique2constraint old) + (unique2constraint new) + removeUnique entity name = do + ssb <- ask + exec $ + ssbDropConstraint ssb + (entity2table entity) + (unique2constraint name)