forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-06-12 22:17:06 +00:00
parent b40ef116b1
commit 42febca91f
2 changed files with 18 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
src/Vervis/Application.hs
View file

@ -167,10 +167,11 @@ makeFoundation appSettings = do
hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
let hashidsCtx = hashidsContext hashidsSalt let hashidsCtx = hashidsContext hashidsSalt
app = mkFoundation pool capSignKey hashidsCtx
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
--runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc --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
@ -184,7 +185,7 @@ makeFoundation appSettings = do
deleteUnusedURAs deleteUnusedURAs
-- Return the foundation -- Return the foundation
return $ mkFoundation pool capSignKey hashidsCtx return app
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares. -- applying some additional middlewares.

5
src/Vervis/Migration.hs
View file

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