[FLORA-345] Store and display deprecated release information

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

@@ -151,6 +151,7 @@ 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)

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

@@ -5,14 +5,16 @@ 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.Time (UTCTime)
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
 import Flora.Model.Release.Types (ImportStatus (..), Release, ReleaseId, TextHtml (..))
 
 insertRelease :: (DB :> es) => Release -> Eff es ()
@@ -54,3 +56,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 (Vector.toList releaseVersions)
+  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,35 @@ fetchDeprecationList = do
               DeprecatedPackage package (assignNamespace inFavourOf)
           )
         & Update.deprecatePackages
-    Left _ -> do
-      logAttention_ "Could not fetch deprecation list from Hackage"
+    Left _ -> logAttention_ "Could not fetch deprecation list from Hackage"
+
+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'
+      Update.setReleasesDeprecationMarker deprecatedVersions
+      Update.setReleasesDeprecationMarker preferredVersions
+    Left _ ->
+      logAttention "Could not fetch release deprecation list from Hackage" $
+        object ["package" .= display packageName]
 
 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

src/jobs-worker/FloraJobs/ThirdParties/Hackage/API.hs

@@ -15,6 +15,7 @@ import Servant.API
 import Servant.API.Generic
 
 import Distribution.Orphans ()
+import Distribution.Types.Version (Version)
 import Flora.Model.Job (IntAesonVersion)
 import Flora.Model.Package.Types (DeprecatedPackage' (..), PackageName)
 
@@ -44,6 +45,7 @@ data HackageAPI' mode = HackageAPI'
   , withUser :: mode :- "user" :> Capture "username" Text :> NamedRoutes HackageUserAPI
   , packages :: mode :- "packages" :> NamedRoutes HackagePackagesAPI
   , withPackage :: mode :- "package" :> Capture "versioned_package" VersionedPackage :> NamedRoutes HackagePackageAPI
+  , withPackageName :: mode :- "package" :> Capture "pacakgeName" PackageName :> NamedRoutes HackagePackageAPI
   }
   deriving stock (Generic)
 
@@ -56,6 +58,7 @@ data HackagePackageAPI mode = HackagePackageAPI
   { getReadme :: mode :- "readme.txt" :> Get '[PlainerText] Text
   , getUploadTime :: mode :- "upload-time" :> Get '[PlainText] UTCTime
   , getChangelog :: mode :- "changelog.txt" :> Get '[PlainerText] Text
+  , getDeprecatedReleases :: mode :- "preferred" :> Get '[JSON] HackagePreferredVersions
   }
   deriving stock (Generic)
 
@@ -78,3 +81,15 @@ data HackageUserDetailsObject = HackageUserDetailsOject
   }
   deriving stock (Eq, Show, Generic)
   deriving anyclass (FromJSON)
+
+data HackagePreferredVersions = HackagePreferredVersions
+  { deprecatedVersions :: Vector Version
+  , normalVersions :: Vector Version
+  }
+  deriving stock (Eq, Show, Generic)
+
+instance FromJSON HackagePreferredVersions where
+  parseJSON = withObject "Hacakge preferred versions" $ \o -> do
+    deprecatedVersions <- o .: "deprecated-version"
+    normalVersions <- o .: "normal-version"
+    pure HackagePreferredVersions{..}

src/jobs-worker/FloraJobs/ThirdParties/Hackage/Client.hs

@@ -13,7 +13,7 @@ import Effectful.Reader.Static
 import Servant.API ()
 import Servant.Client
 
-import Flora.Model.Package.Types (DeprecatedPackage')
+import Flora.Model.Package.Types
 import FloraJobs.ThirdParties.Hackage.API as API
 import FloraJobs.Types (JobsRunner, JobsRunnerEnv (..))
 
@@ -61,3 +61,10 @@ getDeprecatedPackages =
   hackageClient
     // API.packages
     // getDeprecated
+
+getDeprecatedReleasesList :: PackageName -> ClientM HackagePreferredVersions
+getDeprecatedReleasesList packageName =
+  hackageClient
+    // API.withPackageName
+    /: packageName
+    // getDeprecatedReleases