Add database consistency checks

app/server/Main.hs

@@ -16,6 +16,7 @@ import Database.PostgreSQL.Entity
 import Database.PostgreSQL.Entity.DBT
 import Database.PostgreSQL.Entity.Types (field)
 import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Effectful
 import Effectful.Fail (runFailIO)
 import Effectful.Log (Log, runLog)
@@ -34,6 +35,11 @@ import FloraWeb.Server
 main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
+  preFlightChecks
+  runFlora
+
+preFlightChecks :: IO ()
+preFlightChecks = do
   env <- getFloraEnv & runFailIO & runEff
   runEff $ do
     let withLogger = Logging.makeLogger env.mltp.logger
@@ -45,9 +51,78 @@ main = do
           appLogger
           Log.LogTrace
         $ do
+          checkExpectedTables
           checkRepositoriesAreConfigured
           checkIfIndexRefreshJobIsPlanned env.pool
-  runFlora
+
+checkExpectedTables :: (DB :> es, IOE :> es, Log :> es) => Eff es ()
+checkExpectedTables = do
+  -- Update the list in alphabetical order when adding or removing a table!
+  let expectedTables =
+        Set.fromAscList
+          [ "affected_packages"
+          , "affected_version_ranges"
+          , "blob_relations"
+          , "categories"
+          , "downloads"
+          , "oddjobs"
+          , "organisations"
+          , "package_categories"
+          , "package_components"
+          , "package_group_packages"
+          , "package_groups"
+          , "package_indexes"
+          , "package_publishers"
+          , "packages"
+          , "persistent_sessions"
+          , "releases"
+          , "requirements"
+          , "security_advisories"
+          , "user_organisation"
+          , "users"
+          ]
+  actualTables <-
+    dbtToEff $
+      Set.fromAscList . Vector.toList . Vector.map fromOnly
+        <$> query_
+          Select
+          [sql|
+      SELECT table_name
+      FROM information_schema.tables
+      WHERE table_name <> 'schema_migrations'
+        AND table_type = 'BASE TABLE'
+        AND EXISTS (SELECT TRUE
+                    FROM unnest(current_schemas(FALSE)) AS cs
+                    WHERE cs = table_schema)
+      ORDER BY table_name ASC
+        |]
+  let unexpectedTables =
+        Set.difference
+          actualTables
+          expectedTables
+  let missingExpectedTables =
+        Set.difference
+          expectedTables
+          actualTables
+  let (messages :: Vector Text) =
+        let missingTableMessage =
+              if not $ null missingExpectedTables
+                then
+                  "Database validation failed! Expected tables are missing: "
+                    <> mconcat (List.intersperse ", " (Set.toList missingExpectedTables))
+                    <> "."
+                else ""
+            unexpectedTableMessage =
+              if not $ null unexpectedTables
+                then
+                  Text.pack "Database validation failed! Unexpected tables are present: "
+                    <> mconcat (List.intersperse ", " (Set.toList unexpectedTables))
+                    <> "."
+                else ""
+         in Vector.fromList $ filter (/= "") [missingTableMessage, unexpectedTableMessage]
+  unless (null messages) $ do
+    forM_ messages Log.logAttention_
+    liftIO exitFailure
 
 checkRepositoriesAreConfigured :: (DB :> es, IOE :> es, Log :> es) => Eff es ()
 checkRepositoriesAreConfigured = do

changelog.d/flora-242

@@ -0,0 +1,2 @@
+synopsis: Add database consistency checks
+prs: #837

scripts/get-app-tables.sql

@@ -0,0 +1,8 @@
+SELECT table_name
+FROM information_schema.tables
+WHERE table_name <> 'schema_migrations'
+  AND table_type = 'BASE TABLE'
+  AND EXISTS (SELECT TRUE
+              FROM unnest(current_schemas(FALSE)) AS cs
+              WHERE cs = table_schema)
+ORDER BY table_name ASC