I made upgrades to the DB migration system in Funbot, apply them here too

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 ()

src/Database/Persist/Schema/PostgreSQL.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2017 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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

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 ()

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