Adapt to persistent-migration changes

We have gained:

* Haskell-side validation of schema changes before their execution
* Report of results of migration process
* Handling of old deployments

However:

* The validation code hasn't been tested yet at all
* Most of the migration list hasn't been applied at all yet
* Adding lists of entities from a model file is NOT VALIDATED!!! It's totally
  possible to implement, just need to catch all the small details right

src/Vervis/Application.hs

@@ -31,7 +31,7 @@ module Vervis.Application
 where
 
 import Control.Concurrent (forkIO)
-import Control.Monad.Logger                 (liftLoc, runLoggingT)
+import Control.Monad.Logger                 (liftLoc, runLoggingT, logInfo, logError)
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
 import Vervis.Import
@@ -115,7 +115,15 @@ makeFoundation appSettings = do
 
     -- Perform database migration using our application's logging settings.
     --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-    runLoggingT (runSqlPool migrateDB pool) logFunc
+    flip runLoggingT logFunc $
+        flip runSqlPool pool $ do
+            r <- migrateDB
+            case r of
+                Left err -> do
+                    let msg = "DB migration failed: " <> msg
+                    $logError msg
+                    error msg
+                Right (_from, _to) -> $logInfo "DB migration success"
 
     -- Return the foundation
     return $ mkFoundation pool

src/Vervis/Migration.hs

@@ -30,29 +30,39 @@ import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Proxy
 import Data.Text (Text)
 import Database.Persist
+import Database.Persist.BackendDataType (backendDataType)
 import Database.Persist.Migration
-import Database.Persist.Schema
+import Database.Persist.Schema (SchemaT, Migration)
+import Database.Persist.Schema.Types
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Database.Persist.Sql (SqlBackend, toSqlKey)
 import Web.PathPieces (toPathPiece)
 
+import qualified Database.Persist.Schema as U (addEntity, unsetFieldDefault)
+
 import Vervis.Migration.Model
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Workflow
 
-changes :: MonadIO m => [SchemaT SqlBackend m ()]
+type Apply m = SchemaT SqlBackend m ()
+type Mig m   = Migration SqlBackend m
+
+withPrepare :: Monad m => Mig m -> Apply m -> Mig m
+withPrepare (validate, apply) prepare = (validate, prepare >> apply)
+
+changes :: MonadIO m => [Mig m]
 changes =
     [ -- 1
-      traverse_ addEntity model_2016_08_04
+      unchecked $ traverse_ U.addEntity model_2016_08_04
       -- 2
-    , unsetFieldDefault "Sharer" "created"
+    , unchecked $ U.unsetFieldDefault "Sharer" "created"
       -- 3
-    , unsetFieldDefault "Project" "nextTicket"
+    , unchecked $ U.unsetFieldDefault "Project" "nextTicket"
       -- 4
-    , unsetFieldDefault "Repo" "vcs"
+    , unchecked $ U.unsetFieldDefault "Repo" "vcs"
       -- 5
-    , unsetFieldDefault "Repo" "mainBranch"
+    , unchecked $ U.unsetFieldDefault "Repo" "mainBranch"
       -- 6
     , removeField "Ticket" "done"
       -- 7
@@ -61,24 +71,27 @@ changes =
         (FTPrim $ backendDataType (Proxy :: Proxy Text))
         FieldRequired
       -- 8
-    , traverse_ addEntity model_2016_09_01_just_workflow
+    , unchecked $ traverse_ U.addEntity model_2016_09_01_just_workflow
       -- 9
-    , traverse_ addEntity model_2016_09_01_rest
+    , unchecked $ traverse_ U.addEntity model_2016_09_01_rest
       -- 10
-    , do
-        let key = fromBackendKey defaultBackendKey :: Key Workflow2016
-        noProjects <-
-            lift $ null <$> selectKeysList [] [LimitTo 1 :: SelectOpt Project]
+    , let key = fromBackendKey defaultBackendKey :: Key Workflow2016
+      in  withPrepare
+            (addField "Project" (Just $ toPathPiece key) $ Field
+                "workflow"
+                (FTRef "Workflow")
+                FieldRequired
+            ) $ do
+                noProjects <- lift $
+                    null <$> selectKeysList [] [LimitTo 1 :: SelectOpt Project]
                 unless noProjects $ lift $ do
-            msid <- listToMaybe <$> selectKeysList [] [Asc SharerId, LimitTo 1]
+                    msid <-
+                        listToMaybe <$>
+                        selectKeysList [] [Asc SharerId, LimitTo 1]
                     for_ msid $ \ sid -> do
                         let ident = text2wfl "dummy"
                             w = Workflow2016 sid ident Nothing Nothing WSPublic
                         insertKey key w
-        addField "Project" (Just $ toPathPiece key) $ Field
-            "workflow"
-            (FTRef "Workflow")
-            FieldRequired
       -- 11
     , addField "Workflow"
         (Just "'WSSharer'")
@@ -114,5 +127,7 @@ changes =
     , renameField "Person" "hash" "passphraseHash"
     ]
 
-migrateDB :: MonadIO m => ReaderT SqlBackend m ()
-migrateDB = runMigrations schemaBackend changes
+migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
+migrateDB =
+    let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
+    in  f changes

src/Vervis/Migration/Model.hs

@@ -27,7 +27,7 @@ import Prelude
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
-import Database.Persist.Schema (Entity)
+import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Sql (SqlBackend)