haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-28 11:50:24 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Enable running stackage-server-cron on an empty DB

Browse Source 
It did run migrations, but ran them in the wrong spot.
This commit is contained in:
Bryan Richter 2023-12-22 18:48:30 +02:00
parent 96522f62ea
commit 6331131b68
No known key found for this signature in database
GPG Key ID: B202264020068BFB
2 changed files with 25 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/Stackage/Database/Cron.hs
View File

@ -179,8 +179,9 @@ stackageServerCron StackageCronOptions {..} = do
, pcCasaMaxPerRequest = defaultCasaMaxPerRequest , pcCasaMaxPerRequest = defaultCasaMaxPerRequest
, pcSnapshotLocation = defaultSnapshotLocation , pcSnapshotLocation = defaultSnapshotLocation
} }
currentHoogleVersionId <- currentHoogleVersionId <- runRIO logFunc $ do
runRIO logFunc $ getCurrentHoogleVersionIdWithPantryConfig pantryConfig runStackageMigrations' pantryConfig
getCurrentHoogleVersionIdWithPantryConfig pantryConfig
let stackage = let stackage =
StackageCron StackageCron
{ scPantryConfig = pantryConfig { scPantryConfig = pantryConfig

35
src/Stackage/Database/Schema.hs
View File

@ -23,6 +23,7 @@ module Stackage.Database.Schema
, GetStackageDatabase(..) , GetStackageDatabase(..)
, withStackageDatabase , withStackageDatabase
, runStackageMigrations , runStackageMigrations
, runStackageMigrations'
, getCurrentHoogleVersionId , getCurrentHoogleVersionId
, getCurrentHoogleVersionIdWithPantryConfig , getCurrentHoogleVersionIdWithPantryConfig
-- * Tables -- * Tables
@ -217,25 +218,33 @@ withStackageDatabase shouldLog dbs inner = do
bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool -> do bracket (liftIO getPoolIO) (liftIO . destroyAllResources) $ \pool -> do
inner (StackageDatabase (`runSqlPool` pool)) inner (StackageDatabase (`runSqlPool` pool))
getSchema :: (HasLogFunc env, GetStackageDatabase env (RIO env)) => RIO env (Maybe Int) getSchema :: ReaderT SqlBackend (RIO RIO.LogFunc) (Maybe Int)
getSchema = getSchema =
run $ do do
eres <- tryAny (selectList [] []) eres <- tryAny (selectList [] [])
lift $ logInfo $ "getSchema result: " <> displayShow eres lift $ logInfo $ "getSchema result: " <> displayShow eres
case eres of case eres of
Right [Entity _ (Schema v)] -> return $ Just v Right [Entity _ (Schema v)] -> return $ Just v
_ -> return Nothing _ -> 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 :: (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 actualSchema <- getSchema
run $ do unless (actualSchema == Just currentSchema) $ do
runMigration Pantry.migrateAll lift $
runMigration migrateAll logWarn $
unless (actualSchema == Just currentSchema) $ do "Current schema does not match actual schema: " <>
lift $ displayShow (actualSchema, currentSchema)
logWarn $ deleteWhere ([] :: [Filter Schema])
"Current schema does not match actual schema: " <> insert_ $ Schema currentSchema
displayShow (actualSchema, currentSchema)
deleteWhere ([] :: [Filter Schema])
insert_ $ Schema currentSchema