diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 77ce0cf..d966618 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -179,8 +179,9 @@ stackageServerCron StackageCronOptions {..} = do , pcCasaMaxPerRequest = defaultCasaMaxPerRequest , pcSnapshotLocation = defaultSnapshotLocation } - currentHoogleVersionId <- - runRIO logFunc $ getCurrentHoogleVersionIdWithPantryConfig pantryConfig + currentHoogleVersionId <- runRIO logFunc $ do + runStackageMigrations' pantryConfig + getCurrentHoogleVersionIdWithPantryConfig pantryConfig let stackage = StackageCron { scPantryConfig = pantryConfig diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index 0e45bab..f5ef5a8 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -23,6 +23,7 @@ module Stackage.Database.Schema , GetStackageDatabase(..) , withStackageDatabase , runStackageMigrations + , runStackageMigrations' , getCurrentHoogleVersionId , getCurrentHoogleVersionIdWithPantryConfig -- * Tables @@ -217,25 +218,33 @@ withStackageDatabase shouldLog dbs inner = do bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool -> do inner (StackageDatabase (`runSqlPool` pool)) -getSchema :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env (Maybe Int) +getSchema :: ReaderT SqlBackend (RIO RIO.LogFunc) (Maybe Int) getSchema = - run $ do + do eres <- tryAny (selectList [] []) lift $ logInfo $ "getSchema result: " <> displayShow eres case eres of Right [Entity _ (Schema v)] -> return $ Just v _ -> return Nothing +runStackageMigrations' :: PantryConfig -> RIO RIO.LogFunc () -- HasLogFunc env => PantryConfig -> RIO env () +runStackageMigrations' pantryConfig = do + stackageDb <- getStackageDatabaseFromPantry pantryConfig + runDatabase stackageDb stackageMigrations + + runStackageMigrations :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env () -runStackageMigrations = do +runStackageMigrations = run stackageMigrations + +stackageMigrations :: ReaderT SqlBackend (RIO RIO.LogFunc) () -- ReaderT SqlBackend (RIO RIO.LogFunc) () +stackageMigrations = do + runMigration Pantry.migrateAll + runMigration migrateAll actualSchema <- getSchema - run $ do - runMigration Pantry.migrateAll - runMigration migrateAll - unless (actualSchema == Just currentSchema) $ do - lift $ - logWarn $ - "Current schema does not match actual schema: " <> - displayShow (actualSchema, currentSchema) - deleteWhere ([] :: [Filter Schema]) - insert_ $ Schema currentSchema + unless (actualSchema == Just currentSchema) $ do + lift $ + logWarn $ + "Current schema does not match actual schema: " <> + displayShow (actualSchema, currentSchema) + deleteWhere ([] :: [Filter Schema]) + insert_ $ Schema currentSchema