diff --git a/src/Database/Persist/Schema.hs b/src/Database/Persist/Schema.hs index 2a692cf..6db52fb 100644 --- a/src/Database/Persist/Schema.hs +++ b/src/Database/Persist/Schema.hs @@ -124,7 +124,7 @@ data Unique = Unique , uniqueFields :: [FieldName] } -type SchemaT b m a = ReaderT (SchemaBackend b) (ReaderT b m) a +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 @@ -137,13 +137,15 @@ type SchemaT b m a = ReaderT (SchemaBackend b) (ReaderT b m) a -- 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 -> Field -> Maybe Text -> SchemaT backend m () + => EntityName -> Maybe Text -> Field -> SchemaT backend m () renameField :: MonadIO m => EntityName -> FieldName -> FieldName -> SchemaT backend m () diff --git a/src/Database/Persist/Schema/PostgreSQL.hs b/src/Database/Persist/Schema/PostgreSQL.hs index f79854c..b0008c8 100644 --- a/src/Database/Persist/Schema/PostgreSQL.hs +++ b/src/Database/Persist/Schema/PostgreSQL.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2017 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -79,6 +79,11 @@ 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 diff --git a/src/Database/Persist/Schema/Sql.hs b/src/Database/Persist/Schema/Sql.hs index fc0dca1..60497c1 100644 --- a/src/Database/Persist/Schema/Sql.hs +++ b/src/Database/Persist/Schema/Sql.hs @@ -34,9 +34,10 @@ import Data.Char (isUpper, toLower) import Data.Foldable (traverse_) import Data.Maybe (isJust) import Data.Text (Text) -import Database.Persist.Sql (Sql, SqlBackend, rawExecute) +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 @@ -56,6 +57,16 @@ data Column = Column 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 @@ -100,6 +111,7 @@ mkcolumn ssb (Field name typ mnull) = Column instance PersistSchema SqlBackend where data SchemaBackend SqlBackend = SqlSchemaBackend { ssbRefType :: SqlType + , ssbDoesTableExist :: Sql , ssbCreateTable :: TableName -> [Column] -> Sql , ssbRenameTable :: TableName -> TableName -> Sql , ssbDropTable :: TableName -> Sql @@ -119,6 +131,16 @@ instance PersistSchema SqlBackend where :: 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 $ @@ -127,7 +149,7 @@ instance PersistSchema SqlBackend where removeEntity name = do ssb <- ask exec $ ssbDropTable ssb $ entity2table name - addField ent (Field name typ mnull) mdef = do + addField ent mdef (Field name typ mnull) = do ssb <- ask exec $ ssbAddColumn ssb diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2d42b6b..8b75999 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -28,46 +28,16 @@ import Database.Persist.Sql (SqlBackend, toSqlKey) import Database.Persist.Schema import Database.Persist.Schema.PostgreSQL (schemaBackend) +import Database.Persist.Migration import Vervis.Model -key :: SchemaVersionId -key = toSqlKey 1 - -getDbSchemaVersion :: MonadIO m => ReaderT SqlBackend m (Maybe Int) -getDbSchemaVersion = fmap schemaVersionNumber <$> get key - -setDbSchemaVersion :: MonadIO m => Int -> ReaderT SqlBackend m () -setDbSchemaVersion v = repsert key $ SchemaVersion v - --- | Run the migration system. The second parameter is the list of migration --- actions in chronological order. The migration process is: --- --- * Check the schema version of the DB --- * Compare to the schema version of the app, which is the length of the list --- * If any migrations are required, run them --- * Update the schema version in the DB -runMigrations - :: MonadIO m - => SchemaBackend SqlBackend - -> [SchemaT SqlBackend m ()] - -> ReaderT SqlBackend m () -runMigrations sb migrations = do - dver <- fromMaybe 0 <$> getDbSchemaVersion - let aver = length migrations - case compare aver dver of - LT -> error "Older app version running with newer DB schema version" - EQ -> return () - GT -> do - let migs = drop dver migrations - runReaderT (sequence migs) sb - setDbSchemaVersion aver - changes :: MonadIO m => [SchemaT SqlBackend m ()] changes = [ addField "Workflow" - (Field "scope" (FTPrim SqlString) NotNull) (Just "'WSSharer'") + (Field "scope" (FTPrim SqlString) NotNull) + --, lift $ do ] migrateDB :: MonadIO m => ReaderT SqlBackend m () diff --git a/vervis.cabal b/vervis.cabal index 9f38310..f374831 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -83,6 +83,7 @@ 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