[NO-ISSUE] Implement database consistency checks at startup (#545)

app/cli/Main.hs

@@ -12,7 +12,7 @@ import Distribution.Version (Version)
 import Effectful
 import Effectful.Fail
 import Effectful.FileSystem
-import Effectful.Log
+import Effectful.Log (Log, runLog)
 import Effectful.PostgreSQL.Transact.Effect
 import Effectful.Time (Time, runTime)
 import GHC.Conc (getNumCapabilities)
@@ -173,26 +173,30 @@ runOptions (Options (CreateUser opts)) = do
   let username = opts ^. #username
       email = opts ^. #email
       canLogin = opts ^. #canLogin
-  password <- liftIO $ Sel.hashText opts.password
-  if opts ^. #isAdmin
-    then
-      addAdmin AdminCreationForm{..}
-        >>= \admin ->
-          if canLogin
-            then pure ()
-            else lockAccount (admin ^. #userId)
-    else do
-      templateUser <- mkUser UserCreationForm{..}
-      let user = if canLogin then templateUser else templateUser & #userFlags % #canLogin .~ False
-      insertUser user
+  mUser <- Query.getUserByEmail email
+  case mUser of
+    Just _ -> pure ()
+    Nothing -> do
+      password <- liftIO $ Sel.hashText opts.password
+      if opts ^. #isAdmin
+        then
+          addAdmin AdminCreationForm{..}
+            >>= \admin ->
+              if canLogin
+                then pure ()
+                else lockAccount (admin ^. #userId)
+        else do
+          templateUser <- mkUser UserCreationForm{..}
+          let user = if canLogin then templateUser else templateUser & #userFlags % #canLogin .~ False
+          insertUser user
 runOptions (Options GenDesignSystemComponents) = generateComponents
 runOptions (Options (ImportPackages path repository)) = importFolderOfCabalFiles path repository
 runOptions (Options (ImportIndex path repository)) = importIndex path repository
 runOptions (Options (ProvisionRepository name url description)) = provisionRepository name url description
 runOptions (Options (ImportPackageTarball pname version path)) = importPackageTarball pname version path
 
 provisionRepository :: (DB :> es, IOE :> es) => Text -> Text -> Text -> Eff es ()
-provisionRepository name url description = Update.createPackageIndex name url description Nothing
+provisionRepository name url description = Update.upsertPackageIndex name url description Nothing
 
 importFolderOfCabalFiles
   :: ( FileSystem :> es

app/server/Main.hs

@@ -1,9 +1,90 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
 module Main where
 
-import FloraWeb.Server
+import Control.Monad (forM_, unless, void)
+import Data.Function ((&))
+import Data.List qualified as List
+import Data.Pool (Pool)
+import Data.Set qualified as Set
+import Data.Text (Text)
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import Database.PostgreSQL.Entity
+import Database.PostgreSQL.Entity.DBT
+import Database.PostgreSQL.Entity.Types (field)
+import Database.PostgreSQL.Simple (Only (..))
+import Effectful
+import Effectful.Fail (runFailIO)
+import Effectful.Log (Log, runLog)
+import Effectful.PostgreSQL.Transact.Effect (DB, dbtToEff, runDB)
+import Log qualified
+import System.Exit
 import System.IO
 
+import Data.Text qualified as Text
+import Database.PostgreSQL.Simple qualified as PG
+import Flora.Environment (FloraEnv (..), LoggingEnv (..), getFloraEnv)
+import Flora.Logging qualified as Logging
+import Flora.Model.PackageIndex.Types
+import FloraJobs.Scheduler (checkIfIndexRefreshJobIsPlanned, scheduleRefreshIndexes)
+import FloraWeb.Server
+
 main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
+  env <- getFloraEnv & runFailIO & runEff
+  runEff $ do
+    let withLogger = Logging.makeLogger env.logging.logger
+    withLogger $ \appLogger ->
+      runDB env.pool
+        . withUnliftStrategy (ConcUnlift Ephemeral Unlimited)
+        $ runLog
+          "flora-server"
+          appLogger
+          Log.LogTrace
+        $ do
+          checkRepositoriesAreConfigured
+          checkIndexRefreshScheduling env.pool
   runFlora
+
+checkIndexRefreshScheduling :: (DB :> es, Log :> es, IOE :> es) => Pool PG.Connection -> Eff es ()
+checkIndexRefreshScheduling pool = do
+  indexRefreshIsPlanned <-
+    checkIfIndexRefreshJobIsPlanned
+  unless indexRefreshIsPlanned $ do
+    Log.logInfo_ "Scheduling index refresh"
+    void $ liftIO $ scheduleRefreshIndexes pool
+
+checkRepositoriesAreConfigured :: (DB :> es, Log :> es, IOE :> es) => Eff es ()
+checkRepositoriesAreConfigured = do
+  let expectedRepositories = Set.fromList ["hackage", "cardano", "horizon"]
+  (result :: (Vector (Only Text))) <-
+    dbtToEff $
+      query_
+        Select
+        (_selectWithFields @PackageIndex [[field| repository |]])
+  let actualRepositories = Set.fromList $ Vector.toList $ Vector.map fromOnly result
+  let missingExpectedIndexes = Set.difference expectedRepositories actualRepositories
+  let unexpectedIndexes = Set.difference actualRepositories expectedRepositories
+  let (messages :: Vector Text) =
+        let missingIndexMessage =
+              if not $ null missingExpectedIndexes
+                then
+                  "Database validation failed: Expected package indexes: "
+                    <> mconcat (List.intersperse ", " (Set.toList missingExpectedIndexes))
+                    <> "."
+                else ""
+            unexpectedIndexMessage =
+              if not $ null unexpectedIndexes
+                then
+                  Text.pack "Database validation failed: Unexpected package indexes: "
+                    <> mconcat (List.intersperse ", " (Set.toList unexpectedIndexes))
+                    <> "."
+                else ""
+         in Vector.fromList $ filter (/= "") [missingIndexMessage, unexpectedIndexMessage]
+  unless (null messages) $ do
+    forM_ messages Log.logAttention_
+    liftIO exitFailure

flora.cabal

@@ -367,6 +367,7 @@ library flora-jobs
     , commonmark
     , commonmark-extensions
     , containers
+    , effectful
     , effectful-core
     , flora
     , http-client
@@ -389,6 +390,7 @@ library flora-jobs
     , text
     , text-display
     , time
+    , typed-process-effectful
     , vector
 
 executable flora-server
@@ -399,7 +401,19 @@ executable flora-server
   hs-source-dirs: app/server
   build-depends:
     , base
+    , containers
+    , effectful
+    , flora
+    , flora-jobs
     , flora-web
+    , log-base
+    , log-effectful
+    , pg-entity
+    , pg-transact-effectful
+    , postgresql-simple
+    , resource-pool
+    , text
+    , vector
 
 executable flora-cli
   import:         common-extensions

src/core/Flora/Model/Job.hs

@@ -86,6 +86,7 @@ data FloraOddJobs
   | FetchPackageDeprecationList
   | FetchReleaseDeprecationList PackageName (Vector ReleaseId)
   | RefreshLatestVersions
+  | RefreshIndexes
   deriving stock (Generic)
 
 -- TODO: Upstream these two ToJSON instances

src/core/Flora/Model/PackageIndex/Update.hs

@@ -4,12 +4,14 @@
 module Flora.Model.PackageIndex.Update
   ( updatePackageIndexByName
   , createPackageIndex
+  , upsertPackageIndex
   ) where
 
 import Control.Monad (void)
 import Data.Text (Text)
 import Data.Time (UTCTime)
-import Database.PostgreSQL.Entity (insert, updateFieldsBy)
+import Database.PostgreSQL.Entity (insert, updateFieldsBy, _insert)
+import Database.PostgreSQL.Entity.DBT (QueryNature (Insert), execute)
 import Database.PostgreSQL.Entity.Types
 import Database.PostgreSQL.Simple (Only (..))
 import Effectful
@@ -33,3 +35,8 @@ createPackageIndex :: (IOE :> es, DB :> es) => Text -> Text -> Text -> Maybe UTC
 createPackageIndex repositoryName url description timestamp = do
   packageIndex <- mkPackageIndex repositoryName url description timestamp
   void $ dbtToEff $ insert @PackageIndex packageIndex
+
+upsertPackageIndex :: (IOE :> es, DB :> es) => Text -> Text -> Text -> Maybe UTCTime -> Eff es ()
+upsertPackageIndex repositoryName url description timestamp = do
+  packageIndex <- mkPackageIndex repositoryName url description timestamp
+  dbtToEff $ void $ execute Insert (_insert @PackageIndex <> " ON CONFLICT DO NOTHING") packageIndex

src/jobs-worker/FloraJobs/Runner.hs

@@ -10,8 +10,12 @@ import Data.Text.Display
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
 import Effectful (Eff, IOE, type (:>))
+import Effectful.FileSystem (FileSystem)
+import Effectful.FileSystem qualified as FileSystem
 import Effectful.Log
+import Effectful.Poolboy (Poolboy)
 import Effectful.PostgreSQL.Transact.Effect (DB)
+import Effectful.Process.Typed
 import Effectful.Reader.Static (Reader)
 import Effectful.Time (Time)
 import Log
@@ -20,17 +24,28 @@ import OddJobs.Job (Job (..))
 import Servant.Client (ClientError (..))
 import Servant.Client.Core (ResponseF (..))
 
+import Data.Maybe (fromJust)
+import Data.Text qualified as Text
 import Flora.Import.Package (coreLibraries, persistImportOutput)
+import Flora.Import.Package.Bulk qualified as Import
 import Flora.Model.BlobIndex.Update qualified as Update
 import Flora.Model.BlobStore.API
 import Flora.Model.Job
 import Flora.Model.Package.Types
 import Flora.Model.Package.Update qualified as Update
+import Flora.Model.PackageIndex.Query qualified as Query
+import Flora.Model.PackageIndex.Types (PackageIndex (..))
 import Flora.Model.Release.Query qualified as Query
 import Flora.Model.Release.Types
 import Flora.Model.Release.Update qualified as Update
+import Flora.Model.User (User (..))
+import Flora.Model.User.Query qualified as Query
 import FloraJobs.Render (renderMarkdown)
-import FloraJobs.ThirdParties.Hackage.API (HackagePackageInfo (..), HackagePreferredVersions (..), VersionedPackage (..))
+import FloraJobs.ThirdParties.Hackage.API
+  ( HackagePackageInfo (..)
+  , HackagePreferredVersions (..)
+  , VersionedPackage (..)
+  )
 import FloraJobs.ThirdParties.Hackage.Client qualified as Hackage
 import FloraJobs.Types
 
@@ -50,6 +65,7 @@ runner job = localDomain "job-runner" $
         fetchReleaseDeprecationList packageName releases
       RefreshLatestVersions ->
         Update.refreshLatestVersions
+      RefreshIndexes -> refreshIndexes
 
 fetchChangeLog :: ChangelogJobPayload -> JobsRunner ()
 fetchChangeLog payload@ChangelogJobPayload{packageName, packageVersion, releaseId} =
@@ -203,3 +219,31 @@ assignNamespace =
             then PackageAlternative (Namespace "haskell") p
             else PackageAlternative (Namespace "hackage") p
       )
+
+refreshIndexes
+  :: ( Time :> es
+     , DB :> es
+     , TypedProcess :> es
+     , Log :> es
+     , Poolboy :> es
+     , IOE :> es
+     , FileSystem :> es
+     )
+  => Eff es ()
+refreshIndexes = do
+  runProcess_ $ shell "cabal update"
+  let packageIndexes =
+        [ ("hackage", "hackage.haskell.org")
+        , ("cardano", "cardano")
+        , ("horizon", "horizon")
+        ]
+  user <- fromJust <$> Query.getUserByUsername "hackage-user"
+  forM_ packageIndexes $ \(indexName, repoPath) -> do
+    homeDir <- FileSystem.getHomeDirectory
+    let path = homeDir <> "/.cabal/packages/" <> repoPath <> "/01-index.tar.gz"
+    mPackageIndex <- Query.getPackageIndexByName indexName
+    case mPackageIndex of
+      Nothing ->
+        error $ Text.unpack $ "Package index " <> indexName <> " not found in the database!"
+      Just packageIndex ->
+        Import.importFromIndex user.userId (indexName, packageIndex.url) path

src/jobs-worker/FloraJobs/Scheduler.hs

@@ -9,7 +9,8 @@ module FloraJobs.Scheduler
   , schedulePackageDeprecationListJob
   , scheduleReleaseDeprecationListJob
   , scheduleRefreshLatestVersions
-  , checkIfIndexImportJobIsNotRunning
+  , scheduleRefreshIndexes
+  , checkIfIndexRefreshJobIsPlanned
   , jobTableName
   --   prefer using smart constructors.
   , ReadmeJobPayload (..)
@@ -20,15 +21,18 @@ where
 
 import Data.Aeson (ToJSON)
 import Data.Pool
+import Data.Time qualified as Time
 import Data.Vector (Vector)
 import Database.PostgreSQL.Entity.DBT
 import Database.PostgreSQL.Simple (Only (..))
 import Database.PostgreSQL.Simple qualified as PG
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Distribution.Types.Version
+import Effectful
+import Effectful.Log (Log)
 import Effectful.PostgreSQL.Transact.Effect
 import Log
-import OddJobs.Job (Job (..), createJob)
+import OddJobs.Job (Job (..), createJob, scheduleJob)
 
 import Flora.Model.Job
 import Flora.Model.Package
@@ -72,32 +76,36 @@ scheduleReleaseDeprecationListJob pool (package, releaseIds) =
 scheduleRefreshLatestVersions :: Pool PG.Connection -> IO Job
 scheduleRefreshLatestVersions pool = createJobWithResource pool RefreshLatestVersions
 
+scheduleRefreshIndexes :: Pool PG.Connection -> IO Job
+scheduleRefreshIndexes pool = withResource pool $ \conn -> do
+  now <- Time.getCurrentTime
+  scheduleJob conn jobTableName RefreshIndexes (Time.addUTCTime Time.nominalDay now)
+
 createJobWithResource :: ToJSON p => Pool PG.Connection -> p -> IO Job
 createJobWithResource pool job =
   withResource pool $ \conn -> createJob conn jobTableName job
 
-checkIfIndexImportJobIsNotRunning :: JobsRunner Bool
-checkIfIndexImportJobIsNotRunning = do
-  Log.logInfo_ "Checking if the index import job is not running…"
+checkIfIndexRefreshJobIsPlanned
+  :: ( DB :> es
+     , Log :> es
+     )
+  => Eff es Bool
+checkIfIndexRefreshJobIsPlanned = do
+  Log.logInfo_ "Checking if the index refresh job is planned…"
   (result :: Maybe (Only Int)) <-
     dbtToEff $
       queryOne_
         Select
         [sql|
               select count(*)
               from "oddjobs"
-              where payload ->> 'tag' = 'ImportHackageIndex'
+              where payload ->> 'tag' = 'RefreshIndexes'
+              and status = 'queued'
       |]
   case result of
-    Nothing -> do
-      Log.logInfo_ "Index import job is running"
-      pure True
-    Just (Only 0) -> do
-      Log.logInfo_ "Index import job is running"
-      pure True
     Just (Only 1) -> do
-      Log.logInfo_ "Index import job is running"
+      Log.logInfo_ "Index refresh job is planned"
       pure True
     _ -> do
-      Log.logInfo_ "Index import job not running"
+      Log.logInfo_ "Index refresh job not not planned"
       pure False