Merge pull request #347 from flora-pm/flora-345-store-and-display-dep…

…recation-info-for-releases

[FLORA-345] Store and display deprecated release information

CHANGELOG.md

@@ -6,6 +6,7 @@
 * Fetch and store deprecation information about packages ([#342](/~https://github.com/flora-pm/flora-server/pull/342))
 * Only index versionless package pages ([#343](/~https://github.com/flora-pm/flora-server/pull/343))
 * Display deprecation information on the package page ([#344](/~https://github.com/flora-pm/flora-server/pull/344))
+* Display deprecation information for releases ([#347](/~https://github.com/flora-pm/flora-server/pull/347))
 
 ## 1.0.9 -- 2023-01-06
 * Fix package title size in smaller screens ([#297](/~https://github.com/flora-pm/flora-server/pull/297))

assets/css/package.css

@@ -52,6 +52,10 @@
     margin-bottom: 0.75rem;
   }
 
+  .release-deprecated {
+    color: var(--deprecated-version);
+  }
+
   .package-right-column {
     order: 3;
   }

assets/css/variables.css

@@ -40,6 +40,7 @@
   --main-page-button-background: hsl(218 12% 84%);
   --main-page-button-focus-border-color: hsl(294 40% 30%);
   --main-page-button-divider: hsl(294 40% 20%);
+  --deprecated-version: hsl(358 80% 60%);
 }
 
 html[data-theme="dark"] {
@@ -81,4 +82,5 @@ html[data-theme="dark"] {
   --main-page-button-background: hsl(218 29% 30%);
   --main-page-button-focus-border-color: hsl(294 40% 30%);
   --main-page-button-divider: hsl(218 30% 15%);
+  --deprecated-version: hsl(358 80% 60%);
 }

flora.cabal

@@ -71,7 +71,6 @@ library
   extra-libraries: stdc++
   cxx-options:     -std=c++17 -Wall -D__EMBEDDED_SOUFFLE__
   cxx-sources:     cbits/categorise.cpp
-  cabal-fmt:       expand src
   hs-source-dirs:  ./src/core ./src/orphans
 
   -- cabal-fmt: expand src/core

src/core/Flora/Import/Package.hs

@@ -300,6 +300,7 @@ extractPackageDataFromCabal userId genericDesc = do
           , description = display packageDesc.description
           , flags = flags
           , testedWith = getVersions . extractTestedWith . Vector.fromList $! packageDesc.testedWith
+          , deprecated = Nothing
           }
 
   let release =

src/core/Flora/Model/Job.hs

@@ -13,6 +13,7 @@ import OddJobs.Job (Job, LogEvent (..))
 import OddJobs.Types (FailureMode)
 import Servant (ToHttpApiData)
 
+import Data.Vector (Vector)
 import Flora.Import.Package.Types (ImportOutput)
 import Flora.Model.Package (PackageName (..))
 import Flora.Model.Release.Types (ReleaseId (..))
@@ -63,7 +64,8 @@ data FloraOddJobs
   | FetchChangelog ChangelogJobPayload
   | ImportHackageIndex ImportHackageIndexPayload
   | ImportPackage ImportOutput
-  | FetchDeprecationList
+  | FetchPackageDeprecationList
+  | FetchReleaseDeprecationList PackageName (Vector ReleaseId)
   deriving stock (Generic)
   deriving anyclass (ToJSON, FromJSON)
 
@@ -75,7 +77,8 @@ instance ToJSON LogEvent where
   toJSON = \case
     LogJobStart job -> toJSON ("start" :: Text, job)
     LogJobSuccess job time -> toJSON ("success" :: Text, job, time)
-    LogJobFailed job exception failuremode finishTime -> toJSON ("failed" :: Text, show exception, job, failuremode, finishTime)
+    LogJobFailed job exception failuremode finishTime ->
+      toJSON ("failed" :: Text, show exception, job, failuremode, finishTime)
     LogJobTimeout job -> toJSON ("timed-out" :: Text, job)
     LogPoll -> toJSON ("poll" :: Text)
     LogWebUIRequest -> toJSON ("web-ui-request" :: Text)

src/core/Flora/Model/Release/Query.hs

@@ -11,16 +11,18 @@ module Flora.Model.Release.Query
   , getAllReleases
   , getNumberOfReleases
   , getReleaseComponents
+  , getPackagesWithoutReleaseDeprecationInformation
+  , getVersionFromManyReleaseIds
   )
 where
 
 import Data.Vector (Vector)
 import Data.Vector qualified as Vector
 import Data.Vector.Algorithms.Intro as MVector
 import Database.PostgreSQL.Entity
-import Database.PostgreSQL.Entity.DBT (QueryNature (..), query, queryOne)
+import Database.PostgreSQL.Entity.DBT (QueryNature (..), query, queryOne, query_)
 import Database.PostgreSQL.Entity.Types (field)
-import Database.PostgreSQL.Simple (Only (..), Query)
+import Database.PostgreSQL.Simple (In (..), Only (..), Query)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Distribution.Version (Version)
 import Effectful
@@ -48,6 +50,20 @@ getAllReleases pid =
       then pure results
       else pure $! Vector.reverse $! Vector.modify MVector.sort results
 
+getVersionFromManyReleaseIds
+  :: (DB :> es)
+  => Vector ReleaseId
+  -> Eff es (Vector (ReleaseId, Version))
+getVersionFromManyReleaseIds releaseIds = do
+  dbtToEff $! query Select q (Only (In (Vector.toList releaseIds)))
+  where
+    q =
+      [sql| 
+        select r0.release_id, r0.version
+        from releases as r0
+        where r0.release_id in ?
+      |]
+
 getPackageReleases :: (DB :> es) => Eff es (Vector (ReleaseId, Version, PackageName))
 getPackageReleases =
   dbtToEff $
@@ -62,7 +78,9 @@ getPackageReleases =
         on p.package_id = r.package_id
       |]
 
-getPackageReleasesWithoutReadme :: (DB :> es) => Eff es (Vector (ReleaseId, Version, PackageName))
+getPackageReleasesWithoutReadme
+  :: (DB :> es)
+  => Eff es (Vector (ReleaseId, Version, PackageName))
 getPackageReleasesWithoutReadme =
   dbtToEff $
     query Select querySpec ()
@@ -77,7 +95,9 @@ getPackageReleasesWithoutReadme =
         where r.readme_status = 'not-imported'
       |]
 
-getPackageReleasesWithoutUploadTimestamp :: (DB :> es) => Eff es (Vector (ReleaseId, Version, PackageName))
+getPackageReleasesWithoutUploadTimestamp
+  :: (DB :> es)
+  => Eff es (Vector (ReleaseId, Version, PackageName))
 getPackageReleasesWithoutUploadTimestamp =
   dbtToEff $
     query Select querySpec ()
@@ -92,7 +112,9 @@ getPackageReleasesWithoutUploadTimestamp =
         where r.uploaded_at is null
       |]
 
-getPackageReleasesWithoutChangelog :: (DB :> es) => Eff es (Vector (ReleaseId, Version, PackageName))
+getPackageReleasesWithoutChangelog
+  :: (DB :> es)
+  => Eff es (Vector (ReleaseId, Version, PackageName))
 getPackageReleasesWithoutChangelog =
   dbtToEff $
     query Select querySpec ()
@@ -107,8 +129,29 @@ getPackageReleasesWithoutChangelog =
         where r.changelog_status = 'not-imported'
       |]
 
-getReleaseByVersion :: (DB :> es) => PackageId -> Version -> Eff es (Maybe Release)
-getReleaseByVersion packageId version = dbtToEff $! queryOne Select (_selectWhere @Release [[field| package_id |], [field| version |]]) (packageId, version)
+getPackagesWithoutReleaseDeprecationInformation
+  :: (DB :> es)
+  => Eff es (Vector (PackageName, Vector ReleaseId))
+getPackagesWithoutReleaseDeprecationInformation =
+  dbtToEff $! query_ Select q
+  where
+    q =
+      [sql| 
+        select p1.name, array_agg(r0.release_id) 
+        from releases as r0
+        join packages as p1 on r0.package_id = p1.package_id
+        where r0.metadata ->> 'deprecated' is null
+        group by p1.name;
+        |]
+
+getReleaseByVersion
+  :: (DB :> es)
+  => PackageId
+  -> Version
+  -> Eff es (Maybe Release)
+getReleaseByVersion packageId version =
+  dbtToEff $!
+    queryOne Select (_selectWhere @Release [[field| package_id |], [field| version |]]) (packageId, version)
 
 getNumberOfReleases :: (DB :> es) => PackageId -> Eff es Word
 getNumberOfReleases pid =

src/core/Flora/Model/Release/Types.hs

@@ -5,6 +5,7 @@ module Flora.Model.Release.Types
   , ReleaseMetadata (..)
   , ImportStatus (..)
   , SupportedCompilers (..)
+  , ReleaseDeprecation (..)
   )
 where
 
@@ -151,7 +152,16 @@ data ReleaseMetadata = ReleaseMetadata
   , description :: Text
   , flags :: Vector PackageFlag
   , testedWith :: Vector Version
+  , deprecated :: Maybe Bool
   }
   deriving stock (Eq, Show, Generic, Typeable)
   deriving anyclass (ToJSON, FromJSON, NFData)
   deriving (ToField, FromField) via Aeson ReleaseMetadata
+
+data ReleaseDeprecation = ReleaseDeprecation
+  { deprecated :: Bool
+  , release :: ReleaseId
+  }
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON, NFData)
+  deriving (ToField, FromField) via Aeson ReleaseDeprecation

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

@@ -5,15 +5,18 @@ module Flora.Model.Release.Update where
 
 import Control.Monad (void)
 import Database.PostgreSQL.Entity
-import Database.PostgreSQL.Entity.DBT (QueryNature (Update), execute)
+import Database.PostgreSQL.Entity.DBT (QueryNature (Update), execute, executeMany)
 import Database.PostgreSQL.Entity.Types (field)
 import Database.PostgreSQL.Simple (Only (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Effectful
 import Effectful.PostgreSQL.Transact.Effect
 
+import Data.Function ((&))
 import Data.Time (UTCTime)
-import Flora.Model.Release.Types (ImportStatus (..), Release, ReleaseId, TextHtml (..))
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import Flora.Model.Release.Types
 
 insertRelease :: (DB :> es) => Release -> Eff es ()
 insertRelease = dbtToEff . insert @Release
@@ -54,3 +57,15 @@ updateChangelog releaseId changelogBody status =
         ]
         ([field| release_id |], releaseId)
         (changelogBody, status)
+
+setReleasesDeprecationMarker :: (DB :> es) => Vector (Bool, ReleaseId) -> Eff es ()
+setReleasesDeprecationMarker releaseVersions =
+  dbtToEff $! void $! executeMany Update q (releaseVersions & Vector.toList)
+  where
+    q =
+      [sql|
+    UPDATE releases as r0
+    SET metadata = jsonb_set(r0.metadata, '{deprecated}', to_jsonb(upd.x), true)
+    FROM (VALUES (?,?)) as upd(x,y)
+    WHERE r0.release_id = (upd.y :: uuid) 
+    |]

src/jobs-worker/FloraJobs/Runner.hs

@@ -28,7 +28,7 @@ import Flora.Model.Release.Types
 import Flora.Model.Release.Update qualified as Update
 import FloraJobs.Render (renderMarkdown)
 import FloraJobs.Scheduler
-import FloraJobs.ThirdParties.Hackage.API (VersionedPackage (..))
+import FloraJobs.ThirdParties.Hackage.API (HackagePreferredVersions (..), VersionedPackage (..))
 import FloraJobs.ThirdParties.Hackage.Client qualified as Hackage
 import FloraJobs.Types
 
@@ -47,8 +47,7 @@ fetchNewIndex =
       forkIO $!
         forM_
           releases
-          ( \(releaseId, version, packagename) -> do
-              scheduleReadmeJob pool releaseId packagename version
+          ( \(releaseId, version, packagename) -> scheduleReadmeJob pool releaseId packagename version
           )
     liftIO $! void $! scheduleIndexImportJob pool
 
@@ -62,7 +61,9 @@ runner job = localDomain "job-runner" $
       FetchChangelog x -> fetchChangeLog x
       ImportHackageIndex _ -> fetchNewIndex
       ImportPackage x -> persistImportOutput x
-      FetchDeprecationList -> fetchDeprecationList
+      FetchPackageDeprecationList -> fetchPackageDeprecationList
+      FetchReleaseDeprecationList packageName releases ->
+        fetchReleaseDeprecationList packageName releases
 
 fetchChangeLog :: ChangelogJobPayload -> JobsRunner ()
 fetchChangeLog payload@ChangelogJobPayload{packageName, packageVersion, releaseId} =
@@ -124,8 +125,8 @@ fetchUploadTime payload@UploadTimeJobPayload{packageName, packageVersion, releas
       Left e -> throw e
 
 -- | This job fetches the deprecation list and inserts the appropriate metadata in the packages
-fetchDeprecationList :: JobsRunner ()
-fetchDeprecationList = do
+fetchPackageDeprecationList :: JobsRunner ()
+fetchPackageDeprecationList = do
   result <- Hackage.request $! Hackage.getDeprecatedPackages
   case result of
     Right deprecationList -> do
@@ -136,15 +137,46 @@ fetchDeprecationList = do
               DeprecatedPackage package (assignNamespace inFavourOf)
           )
         & Update.deprecatePackages
-    Left _ -> do
-      logAttention_ "Could not fetch deprecation list from Hackage"
+    Left e@(FailureResponse _ response) -> do
+      logAttention "Could not fetch package deprecation list from Hackage" $
+        object
+          [ "status_code" .= statusCode (response.responseStatusCode)
+          ]
+      throw e
+    Left e -> throw e
+
+fetchReleaseDeprecationList :: PackageName -> Vector ReleaseId -> JobsRunner ()
+fetchReleaseDeprecationList packageName releases = do
+  result <- Hackage.request $! Hackage.getDeprecatedReleasesList packageName
+  case result of
+    Right deprecationList -> do
+      logInfo "Release deprecation list retrieved" $
+        object ["package" .= display packageName]
+      releasesAndVersions <- Query.getVersionFromManyReleaseIds releases
+      let (deprecatedVersions', preferredVersions') =
+            Vector.unstablePartition
+              ( \(_, v) ->
+                  Vector.elem v deprecationList.deprecatedVersions
+              )
+              releasesAndVersions
+      let deprecatedVersions = fmap (\(releaseId, _) -> (True, releaseId)) deprecatedVersions'
+      let preferredVersions = fmap (\(releaseId, _) -> (False, releaseId)) preferredVersions'
+      unless (Vector.null deprecatedVersions) $ Update.setReleasesDeprecationMarker deprecatedVersions
+      unless (Vector.null preferredVersions) $ Update.setReleasesDeprecationMarker preferredVersions
+    Left e@(FailureResponse _ response) -> do
+      logAttention "Could not fetch release deprecation list from Hackage" $
+        object
+          [ "package" .= display packageName
+          , "status_code" .= statusCode (response.responseStatusCode)
+          ]
+      throw e
+    Left e -> throw e
 
 assignNamespace :: Vector PackageName -> Vector PackageAlternative
-assignNamespace packages =
+assignNamespace =
   Vector.map
     ( \p ->
         if Set.member p coreLibraries
           then PackageAlternative (Namespace "haskell") p
           else PackageAlternative (Namespace "hackage") p
     )
-    packages

src/jobs-worker/FloraJobs/Scheduler.hs

@@ -6,7 +6,8 @@ module FloraJobs.Scheduler
   , scheduleChangelogJob
   , scheduleUploadTimeJob
   , scheduleIndexImportJob
-  , scheduleDeprecationListJob
+  , schedulePackageDeprecationListJob
+  , scheduleReleaseDeprecationListJob
   , checkIfIndexImportJobIsNotRunning
   , jobTableName
   --   prefer using smart constructors.
@@ -18,6 +19,7 @@ where
 
 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
@@ -79,15 +81,26 @@ scheduleIndexImportJob pool =
           runAt
     )
 
-scheduleDeprecationListJob :: Pool PG.Connection -> IO Job
-scheduleDeprecationListJob pool =
+schedulePackageDeprecationListJob :: Pool PG.Connection -> IO Job
+schedulePackageDeprecationListJob pool =
   withResource
     pool
     ( \conn ->
         createJob
           conn
           jobTableName
-          FetchDeprecationList
+          FetchPackageDeprecationList
+    )
+
+scheduleReleaseDeprecationListJob :: Pool PG.Connection -> (PackageName, Vector ReleaseId) -> IO Job
+scheduleReleaseDeprecationListJob pool (package, releaseIds) =
+  withResource
+    pool
+    ( \conn ->
+        createJob
+          conn
+          jobTableName
+          (FetchReleaseDeprecationList package releaseIds)
     )
 
 checkIfIndexImportJobIsNotRunning :: JobsRunner Bool