From 6331131b6889ddcea45ce49bae04323002b85e53 Mon Sep 17 00:00:00 2001
From: Bryan Richter <b@chreekat.net>
Date: Fri, 22 Dec 2023 18:48:30 +0200
Subject: [PATCH] Enable running stackage-server-cron on an empty DB

It did run migrations, but ran them in the wrong spot.
---
 src/Stackage/Database/Cron.hs   |  5 +++--
 src/Stackage/Database/Schema.hs | 35 +++++++++++++++++++++------------
 2 files changed, 25 insertions(+), 15 deletions(-)

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