Run DB migrations in Worker monad, to allow convenient MonadSite access

src/Vervis/Application.hs

@@ -167,24 +167,25 @@ makeFoundation appSettings = do
     hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
     let hashidsCtx = hashidsContext hashidsSalt
 
+        app = mkFoundation pool capSignKey hashidsCtx
+
     -- Perform database migration using our application's logging settings.
     --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-    flip runLoggingT logFunc $
+    flip runWorker app $ runSiteDB $ do
-        flip runSqlPool pool $ do
+        let hLocal = appInstanceHost appSettings
-            let hLocal = appInstanceHost appSettings
+        r <- migrateDB hLocal hashidsCtx
-            r <- migrateDB hLocal hashidsCtx
+        case r of
-            case r of
+            Left err -> do
-                Left err -> do
+                let msg = "DB migration failed: " <> err
-                    let msg = "DB migration failed: " <> err
+                $logError msg
-                    $logError msg
+                error $ T.unpack msg
-                    error $ T.unpack msg
+            Right (_from, _to) -> do
-                Right (_from, _to) -> do
+                $logInfo "DB migration success"
-                    $logInfo "DB migration success"
+                fixRunningDeliveries
-                    fixRunningDeliveries
+                deleteUnusedURAs
-                    deleteUnusedURAs
 
     -- Return the foundation
-    return $ mkFoundation pool capSignKey hashidsCtx
+    return app
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.

src/Vervis/Migration.hs

@@ -62,6 +62,7 @@ import Database.Persist.JSON
 import Web.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import Data.Either.Local
 import Database.Persist.Local
@@ -86,7 +87,7 @@ withPrepare (validate, apply) prepare = (validate, prepare >> apply)
 --withPrePost :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
 --withPrePost pre (validate, apply) post = (validate, pre >> apply >> post)
 
-changes :: MonadIO m => Text -> HashidsContext -> [Mig m]
+changes :: MonadSite m => Text -> HashidsContext -> [Mig m]
 changes hLocal ctx =
     [ -- 1
       addEntities model_2016_08_04
@@ -671,7 +672,7 @@ changes hLocal ctx =
     ]
 
 migrateDB
-    :: MonadIO m
+    :: MonadSite m
     => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
 migrateDB hLocal ctx =
     let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs