diff --git a/app/cli/Main.hs b/app/cli/Main.hs index d59cdb58..c2e689c4 100644 --- a/app/cli/Main.hs +++ b/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,18 +173,22 @@ 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 @@ -192,7 +196,7 @@ runOptions (Options (ProvisionRepository name url description)) = provisionRepos 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 diff --git a/app/server/Main.hs b/app/server/Main.hs index 8398c49e..67b7d40f 100644 --- a/app/server/Main.hs +++ b/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 diff --git a/flora.cabal b/flora.cabal index 5c0e467e..6170725c 100644 --- a/flora.cabal +++ b/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 diff --git a/src/core/Flora/Model/Job.hs b/src/core/Flora/Model/Job.hs index a4c586f3..969d6693 100644 --- a/src/core/Flora/Model/Job.hs +++ b/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 diff --git a/src/core/Flora/Model/PackageIndex/Update.hs b/src/core/Flora/Model/PackageIndex/Update.hs index 5b8ef702..cac3e0aa 100644 --- a/src/core/Flora/Model/PackageIndex/Update.hs +++ b/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 diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index e9e0ffa1..f4552d6e 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/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 diff --git a/src/jobs-worker/FloraJobs/Scheduler.hs b/src/jobs-worker/FloraJobs/Scheduler.hs index f14fb9a0..e88d218a 100644 --- a/src/jobs-worker/FloraJobs/Scheduler.hs +++ b/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,13 +76,22 @@ 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_ @@ -86,18 +99,13 @@ checkIfIndexImportJobIsNotRunning = do [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 diff --git a/src/jobs-worker/FloraJobs/Types.hs b/src/jobs-worker/FloraJobs/Types.hs index 62fd0294..2258f17c 100644 --- a/src/jobs-worker/FloraJobs/Types.hs +++ b/src/jobs-worker/FloraJobs/Types.hs @@ -14,10 +14,12 @@ import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple qualified as PG import Database.PostgreSQL.Simple.Types (QualifiedIdentifier) import Effectful +import Effectful.FileSystem import Effectful.Log hiding (LogLevel) import Effectful.Log qualified as LogEff hiding (LogLevel) import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect (DB, runDB) +import Effectful.Process.Typed import Effectful.Reader.Static (Reader, runReader) import Effectful.Time (Time, runTime) import GHC.Generics (Generic) @@ -42,12 +44,15 @@ type JobsRunner = , BlobStoreAPI , Log , Time + , TypedProcess + , FileSystem , IOE ] runJobRunner :: Pool Connection -> JobsRunnerEnv -> FloraEnv -> Logger -> JobsRunner a -> IO a runJobRunner pool runnerEnv floraEnv logger jobRunner = jobRunner + & withUnliftStrategy (ConcUnlift Ephemeral Unlimited) & runDB pool & runPoolboy (poolboySettingsWith floraEnv.dbConfig.connections) & runReader runnerEnv @@ -57,6 +62,8 @@ runJobRunner pool runnerEnv floraEnv logger jobRunner = ) & LogEff.runLog "flora-jobs" logger defaultLogLevel & runTime + & runTypedProcess + & runFileSystem & runEff data OddJobException where @@ -109,6 +116,7 @@ makeUIConfig cfg logger pool = structuredLogging :: FloraConfig -> Logger -> LogLevel -> LogEvent -> IO () structuredLogging FloraConfig{..} logger level event = runEff + . withUnliftStrategy (ConcUnlift Ephemeral Unlimited) . runTime . Logging.runLog environment logger $ localDomain "odd-jobs" diff --git a/src/web/FloraWeb/Server.hs b/src/web/FloraWeb/Server.hs index 3ac747f9..c366c78f 100644 --- a/src/web/FloraWeb/Server.hs +++ b/src/web/FloraWeb/Server.hs @@ -4,6 +4,7 @@ import Colourista.IO (blueMessage) import Control.Exception (bracket) import Control.Exception.Safe qualified as Safe import Control.Monad (void, when) +import Control.Monad.Except qualified as Except import Data.Maybe (isJust) import Data.OpenApi (OpenApi) import Data.Pool qualified as Pool @@ -51,17 +52,28 @@ import Servant import Servant.OpenApi import Servant.Server.Generic (AsServerT) -import Control.Monad.Except qualified as Except -import Flora.Environment (BlobStoreImpl (..), DeploymentEnv, FeatureEnv (..), FloraEnv (..), LoggingEnv (..), getFloraEnv) +import Flora.Environment + ( BlobStoreImpl (..) + , DeploymentEnv + , FeatureEnv (..) + , FloraEnv (..) + , LoggingEnv (..) + , getFloraEnv + ) import Flora.Environment.Config (Assets) -import Flora.Logging (runLog) import Flora.Logging qualified as Logging import Flora.Model.BlobStore.API import FloraJobs.Runner (runner) import FloraJobs.Types (JobsRunnerEnv (..), makeConfig, makeUIConfig) import FloraWeb.API.Routes qualified as API import FloraWeb.API.Server qualified as API -import FloraWeb.Common.Auth (OptionalAuthContext, StrictAuthContext, adminAuthHandler, optionalAuthHandler, strictAuthHandler) +import FloraWeb.Common.Auth + ( OptionalAuthContext + , StrictAuthContext + , adminAuthHandler + , optionalAuthHandler + , strictAuthHandler + ) import FloraWeb.Common.OpenSearch import FloraWeb.Common.Tracing import FloraWeb.Embedded @@ -85,7 +97,7 @@ runFlora = (getFloraEnv & runFailIO & runEff) (runEff . shutdownFlora) ( \env -> - runEff . runTime . runConcurrent $ do + runEff . withUnliftStrategy (ConcUnlift Ephemeral Unlimited) . runTime . runConcurrent $ do let baseURL = "http://localhost:" <> display env.httpPort liftIO $ blueMessage $ "🌺 Starting Flora server on " <> baseURL liftIO $ when (isJust env.logging.sentryDSN) (blueMessage "📋 Connected to Sentry endpoint") @@ -191,7 +203,7 @@ naturalTransform floraEnv logger _webEnvStore app = do Just (BlobStoreFS fp) -> runBlobStoreFS fp _ -> runBlobStorePure ) - & runLog floraEnv.environment logger + & Logging.runLog floraEnv.environment logger & runErrorWith (\_callstack err -> pure $ Left err) & runEff either Except.throwError pure result