diff --git a/src/core/Flora/Model/Job.hs b/src/core/Flora/Model/Job.hs index 6d61cf7c..d1452913 100644 --- a/src/core/Flora/Model/Job.hs +++ b/src/core/Flora/Model/Job.hs @@ -18,7 +18,7 @@ import Servant (ToHttpApiData) import Distribution.Orphans.Version () import Flora.Import.Package.Types (ImportOutput) -import Flora.Model.Package (PackageName (..)) +import Flora.Model.Package import Flora.Model.Release.Types (ReleaseId (..)) newtype IntAesonVersion = MkIntAesonVersion {unIntAesonVersion :: Version} @@ -87,6 +87,7 @@ data FloraOddJobs | FetchReleaseDeprecationList PackageName (Vector ReleaseId) | RefreshLatestVersions | RefreshIndex Text + | ComputeIncompatibleReleasesWith Namespace PackageName deriving stock (Generic) -- TODO: Upstream these two ToJSON instances diff --git a/src/core/Flora/Model/Package/Query.hs b/src/core/Flora/Model/Package/Query.hs index 0a069a52..71d7117f 100644 --- a/src/core/Flora/Model/Package/Query.hs +++ b/src/core/Flora/Model/Package/Query.hs @@ -818,3 +818,22 @@ WITH RECURSIVE transitive_dependencies( dependent_id, dependent_namespace, depe FROM transitive_dependencies AS t3 GROUP BY (t3.dependent_id, t3.dependent_namespace, t3.dependent_name) |] + +getDependentsOfPackage :: DB :> es => PackageId -> Vector (PackageId, Version, VersionRange) +getDependentsOfPackage dependencyId = dbtToEff $ query getDependentsOfPackageQuery (Only dependencyId) + +getDependentsOfPackageQuery :: SQL +getDependentsOfPackageQuery = + [sql| +SELECT lv.package_id + , r1.version + , r3.requirement +FROM latest_versions AS lv + INNER JOIN releases AS r1 ON r1.package_id = lv.package_id + AND r1.version = lv.version + INNER JOIN package_components AS p2 ON p2.release_id = r1.release_id + INNER JOIN requirements AS r3 ON r3.package_component_id = p2.package_component_id +WHERE r3.package_id = ? + AND r3.requirement <> '>=0' +GROUP BY lv.name, r1.version, r3.requirement + |] diff --git a/src/jobs-worker/FloraJobs/Runner.hs b/src/jobs-worker/FloraJobs/Runner.hs index d32976ea..7782e644 100644 --- a/src/jobs-worker/FloraJobs/Runner.hs +++ b/src/jobs-worker/FloraJobs/Runner.hs @@ -14,7 +14,7 @@ import Data.Vector (Vector) import Data.Vector qualified as Vector import Database.PostgreSQL.Simple qualified as PG import Distribution.Types.Version (Version) -import Effectful (IOE, Limit (..), Persistence (..), UnliftStrategy (..), runEff, withUnliftStrategy, type (:>)) +import Effectful import Effectful.Concurrent (Concurrent) import Effectful.Error.Static (Error) import Effectful.FileSystem (FileSystem) @@ -58,10 +58,6 @@ import Flora.Monad import FloraJobs.Render (renderMarkdown) import FloraJobs.Scheduler (scheduleRefreshIndex) import FloraJobs.ThirdParties.Hackage.API - ( HackagePackageInfo (..) - , HackagePreferredVersions (..) - , VersionedPackage (..) - ) import FloraJobs.ThirdParties.Hackage.Client qualified as Hackage import FloraJobs.Types @@ -79,6 +75,7 @@ runner job = localDomain "job-runner" $ FetchReleaseDeprecationList packageName releases -> fetchReleaseDeprecationList packageName releases RefreshLatestVersions -> Update.refreshLatestVersions RefreshIndex indexName -> refreshIndex indexName + ComputeIncompatibleReleasesWith namespace packageName -> computeIncompatibleReleasesWith namespace packageName makeConfig :: RequireCallStack @@ -289,6 +286,7 @@ refreshIndex indexName = do Import.importFromArchive indexName indexDependencies packagesPath pool <- getPool void $ liftIO $ scheduleRefreshIndex pool indexName + void $ liftIO $ scheduleIncompatibleReleaseJob pool (Namespae "hackage") (PackageName "base") getCabalPackagesDirectory :: FileSystem :> es => FloraM es FilePath getCabalPackagesDirectory = do @@ -300,3 +298,31 @@ getCabalPackagesDirectory = do homeDir <- FileSystem.getHomeDirectory let legacyPackagesDirectory = homeDir ".cabal/packages" pure legacyPackagesDirectory + +computeIncompatibleReleasesWith + :: ( Concurrent :> es + , DB :> es + , Error ImportError :> es + , FileSystem :> es + , IOE :> es + , Log :> es + , Metrics AppMetrics :> es + , Reader FloraEnv :> es + , Time :> es + ) + => Namespace + -> PackageName + -> FloraM es () +computeIncompatibleReleasesWith namespace packageName = do + package <- guardThatPackageExists namespace packageName + latestRelease <- Query.getLatestPackageRelease package.packageId + dependents <- Query.getDependentsOfPackage package.packageId + forM_ dependents $ \(packageId, dependentVersion, dependentRequirement) -> do + if latestRelease.version `withinRange` dependentRequirement + then pure () + else do + Log.logInfo "Incompatible release" $ + object + [ "incompatible_dependent" .= display package.namespace <> "/" <> display package.packageName + , "package" .= display namespace <> "/" <> display packageName + ] diff --git a/src/jobs-worker/FloraJobs/Scheduler.hs b/src/jobs-worker/FloraJobs/Scheduler.hs index 0594bc99..ae971a7a 100644 --- a/src/jobs-worker/FloraJobs/Scheduler.hs +++ b/src/jobs-worker/FloraJobs/Scheduler.hs @@ -10,6 +10,7 @@ module FloraJobs.Scheduler , scheduleReleaseDeprecationListJob , scheduleRefreshLatestVersions , scheduleRefreshIndex + , scheduleIncompatibleReleaseJob , checkIfIndexRefreshJobIsPlanned , jobTableName -- prefer using smart constructors. @@ -86,6 +87,10 @@ scheduleRefreshIndex pool indexName = withResource pool $ \conn -> do now <- Time.getCurrentTime scheduleJob conn jobTableName (RefreshIndex indexName) (Time.addUTCTime Time.nominalDay now) +scheduleIncompatibleReleaseJob :: Pool PG.Connection -> Namespace -> PackageName -> IO Job +scheduleIncompatibleReleaseJob pool namespace packageName = + createJobWithResource pool (ComputeIncompatibleReleasesWith namespace packageName) + createJobWithResource :: ToJSON p => Pool PG.Connection -> p -> IO Job createJobWithResource pool job = withResource pool $ \conn -> createJob conn jobTableName job