From 829fd72fef3a934eaded02946005cd3029ba82bd Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 26 Feb 2018 14:23:02 +0000 Subject: [PATCH] Use my new persistent-migration library, to which I moved the related modules --- config/models | 9 +- src/Database/Persist/Schema.hs | 160 ------------------ src/Database/Persist/Schema/PostgreSQL.hs | 165 ------------------- src/Database/Persist/Schema/Sql.hs | 191 ---------------------- stack.yaml | 1 + vervis.cabal | 5 +- 6 files changed, 3 insertions(+), 528 deletions(-) delete mode 100644 src/Database/Persist/Schema.hs delete mode 100644 src/Database/Persist/Schema/PostgreSQL.hs delete mode 100644 src/Database/Persist/Schema/Sql.hs diff --git a/config/models b/config/models index 8f6db68..6fe05d0 100644 --- a/config/models +++ b/config/models @@ -1,6 +1,6 @@ -- This file is part of Vervis. -- --- Written in 2016 by fr33domlover . +-- Written in 2016, 2018 by fr33domlover . -- -- ♡ Copying is an act of love. Please copy, reuse and share. -- @@ -12,13 +12,6 @@ -- with this software. If not, see -- . -------------------------------------------------------------------------------- --- Meta -------------------------------------------------------------------------------- - -SchemaVersion - number Int - ------------------------------------------------------------------------------- -- People ------------------------------------------------------------------------------- diff --git a/src/Database/Persist/Schema.hs b/src/Database/Persist/Schema.hs deleted file mode 100644 index 6db52fb..0000000 --- a/src/Database/Persist/Schema.hs +++ /dev/null @@ -1,160 +0,0 @@ -{- 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 (..) - , SchemaT - , PersistSchema (..) - ) -where - -import Prelude - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Char (isAsciiLower, isAsciiUpper) -import Data.String (IsString (..)) -import Data.Text (Text) -import Database.Persist.Types (SqlType) - -import qualified Data.Text as T (uncons, all, stripPrefix) - -import Data.Char.Local (isAsciiLetter) - -newtype FieldName = FieldName { unFieldName :: Text } - -instance IsString FieldName where - fromString s = - let t = fromString s - in case T.uncons t of - Nothing -> error "empty field name" - Just (c, r) -> - if isAsciiLower c - then - if T.all isAsciiLetter r - then FieldName t - else - error "non ascii-letter char in field name" - else - error - "field name doesn't start with lowercase \ - \ascii letter" - -newtype EntityName = EntityName { unEntityName :: Text } - -instance IsString EntityName where - fromString s = - let t = fromString s - in case T.uncons t of - Nothing -> error "empty entity name" - Just (c, r) -> - if isAsciiUpper c - then - if T.all isAsciiLetter r - then EntityName t - else - error - "non ascii-letter char in entity name" - else - error - "entity name doesn't start with uppercase \ - \ascii letter" - -newtype UniqueName = UniqueName { unUniqueName :: Text } - -instance IsString UniqueName where - fromString s = - let t = fromString s - in case T.stripPrefix "Unique" t of - Nothing -> error "unique name doesn't start with \"Unique\"" - Just u -> - case T.uncons u of - Nothing -> error "unique name is just \"Unique\"" - Just (c, r) -> - if isAsciiUpper c - then - if T.all isAsciiLetter r - then UniqueName t - else - error - "non ascii-letter char in \ - \unique name" - else - error - "unique name doesn't follow with \ - \uppercase ascii letter after Unique" - -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 - { uniqueName :: UniqueName - , uniqueFields :: [FieldName] - } - -type SchemaT b m = ReaderT (SchemaBackend b) (ReaderT b m) - --- | 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 -- :: * - hasSchemaEntity - :: MonadIO m => SchemaT backend m Bool - addEntity - :: MonadIO m => Entity -> SchemaT backend m () - removeEntity - :: MonadIO m => EntityName -> SchemaT backend m () - addField - :: MonadIO m - => EntityName -> Maybe Text -> Field -> SchemaT backend m () - renameField - :: MonadIO m - => EntityName -> FieldName -> FieldName -> SchemaT backend m () - removeField - :: MonadIO m => EntityName -> FieldName -> SchemaT backend m () - addUnique - :: MonadIO m => EntityName -> Unique -> SchemaT backend m () - renameUnique - :: MonadIO m - => EntityName -> UniqueName -> UniqueName -> SchemaT backend m () - removeUnique - :: MonadIO m => EntityName -> UniqueName -> SchemaT backend m () diff --git a/src/Database/Persist/Schema/PostgreSQL.hs b/src/Database/Persist/Schema/PostgreSQL.hs deleted file mode 100644 index b0008c8..0000000 --- a/src/Database/Persist/Schema/PostgreSQL.hs +++ /dev/null @@ -1,165 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016, 2017 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 - ( schemaBackend - ) -where - -import Prelude - -import Data.Monoid ((<>)) -import Data.Text (Text) -import Database.Persist.Sql (SqlBackend) -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" - -schemaBackend :: SchemaBackend SqlBackend -schemaBackend = SqlSchemaBackend - { ssbRefType = SqlInt64 - , ssbDoesTableExist = - "SELECT COUNT(*) FROM pg_catalog.pg_tables \ - \ WHERE schemaname != 'pg_catalog' AND \ - \ schemaname != 'information_schema' AND \ - \ tablename = ?" - , 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 mdef -> mconcat - [ "ALTER TABLE ", table2sql table - , " ADD COLUMN ", columnSql column - , case mdef of - Nothing -> T.empty - Just t -> " DEFAULT " <> t - ] - , 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" - ] - , ssbDefColumn = \ table column val -> mconcat - [ "ALTER TABLE ", table2sql table - , " ALTER COLUMN ", column2sql column - , " SET DEFAULT ", val - ] - , ssbUndefColumn = \ table column -> mconcat - [ "ALTER TABLE ", table2sql table - , " ALTER COLUMN ", column2sql column - , " DROP DEFAULT" - ] - , 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, ")" - ] - , 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 deleted file mode 100644 index 60497c1..0000000 --- a/src/Database/Persist/Schema/Sql.hs +++ /dev/null @@ -1,191 +0,0 @@ -{- 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 (..) - , SchemaBackend (..) - ) -where - -import Prelude - -import Control.Monad (when) -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.Maybe (isJust) -import Data.Text (Text) -import Database.Persist.Sql hiding (FieldType, Entity, Column) -import Database.Persist.Types (SqlType) - -import qualified Data.Conduit.List as CL (head) -import qualified Data.Text as T - -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 - } - -exec :: MonadIO m => Sql -> SchemaT SqlBackend m () -exec t = lift $ rawExecute t [] - -inquire - :: MonadIO m => Sql -> [PersistValue] -> SchemaT SqlBackend m PersistValue -inquire t vs = lift $ withRawQuery t vs $ do - l <- CL.head - case l of - Just [x] -> return x - Just [] -> error $ "inquire: got empty list " ++ show t - Just xs -> error $ "inquire: got multiple values " ++ show xs ++ show t - Nothing -> error $ "inquire: got nothing " ++ show 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 - , ssbDoesTableExist :: Sql - , ssbCreateTable :: TableName -> [Column] -> Sql - , ssbRenameTable :: TableName -> TableName -> Sql - , ssbDropTable :: TableName -> Sql - , ssbAddColumn :: TableName -> Column -> Maybe Text -> Sql - , ssbRenameColumn :: TableName -> ColumnName -> ColumnName -> Sql - , ssbRetypeColumn :: TableName -> ColumnName -> SqlType -> Sql - , ssbRenullColumn :: TableName -> ColumnName -> MaybeNull -> Sql - , ssbUnnullColumn :: TableName -> ColumnName -> Text -> Sql - , ssbDefColumn :: TableName -> ColumnName -> Text -> Sql - , ssbUndefColumn :: TableName -> ColumnName -> 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 - } - hasSchemaEntity = do - ssb <- ask - let table = - toPersistValue $ unTableName $ entity2table $ EntityName $ - T.pack "SchemaVersion" - v <- inquire (ssbDoesTableExist ssb) [table] - case v of - PersistInt64 1 -> return True - PersistInt64 0 -> return False - _ -> error "hasSchemaEntity: count inquiry didn't return a number" - 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 mdef (Field name typ mnull) = do - ssb <- ask - exec $ - ssbAddColumn ssb - (entity2table ent) - (Column (field2column name) (type2sql ssb typ) mnull) - mdef - when (isJust mdef) $ - exec $ - ssbUndefColumn ssb (entity2table ent) (field2column name) - 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) diff --git a/stack.yaml b/stack.yaml index 154094d..7180303 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,6 +12,7 @@ packages: - '../hit-graph' - '../hit-harder' - '../hit-network' + - '../persistent-migration' # Packages to be pulled from upstream that are not in the resolver (e.g., # acme-missiles-0.3) diff --git a/vervis.cabal b/vervis.cabal index f374831..0f28b33 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -83,10 +83,6 @@ library Database.Persist.Local.Sql Database.Persist.Local.Sql.Orphan.Common Database.Persist.Local.Sql.Orphan.PersistQueryForest - Database.Persist.Migration - Database.Persist.Schema - Database.Persist.Schema.PostgreSQL - Database.Persist.Schema.Sql Development.DarcsRev Diagrams.IntransitiveDAG Formatting.CaseInsensitive @@ -276,6 +272,7 @@ library -- for PathPiece instance for CI, Web.PathPieces.Local , path-pieces , persistent + , persistent-migration , persistent-postgresql , persistent-template , process