From 06cc2fb439139960a23620677225ad9add48e46e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Mon, 12 May 2025 22:42:38 +0200 Subject: [PATCH 1/6] Move uploader out of acid-state --- .../Server/Features/PackageInfoJSON.hs | 77 +++++++++++++++---- .../Server/Features/PackageInfoJSON/State.hs | 41 +++++++--- 2 files changed, 91 insertions(+), 27 deletions(-) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 2bcdc7781..224de154a 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -1,6 +1,8 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Server.Features.PackageInfoJSON ( PackageInfoJSONFeature(..) @@ -39,6 +41,7 @@ import Distribution.Server.Packages.Types (CabalFileText(. import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) import Distribution.Server.Features.PackageInfoJSON.State (PackageBasicDescription(..), + PackageBasicDescriptionDTO(..), PackageVersions(..), PackageInfoState(..), GetPackageInfo(..), @@ -54,8 +57,10 @@ import Data.Foldable (toList) import Data.Traversable (for) import qualified Data.List as List import Data.Time (UTCTime) -import Distribution.Server.Users.Types (UserName, UserInfo(..)) +import Distribution.Server.Users.Types (UserName (..), UserInfo(..)) import Distribution.Server.Features.Users (UserFeature(lookupUserInfo)) +import Data.Map (Map) +import qualified Data.Map as Map data PackageInfoJSONFeature = PackageInfoJSONFeature { @@ -92,17 +97,18 @@ initPackageInfoJSONFeature env = do \and the values are whether the version is preferred or not" vInfo = "Get basic package information at a specific metadata revision" + uploaderCache = undefined jsonResources = [ (Framework.extendResource (corePackagePage coreR)) { Framework.resourceDesc = [(Framework.GET, info)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR userFeature + [("json", servePackageBasicDescription coreR uploaderCache userFeature preferred packageInfoState)] } , (Framework.extendResource (coreCabalFileRev coreR)) { Framework.resourceDesc = [(Framework.GET, vInfo)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR userFeature + [("json", servePackageBasicDescription coreR uploaderCache userFeature preferred packageInfoState)] } ] @@ -135,15 +141,14 @@ initPackageInfoJSONFeature env = do -- | Pure function for extracting basic package info from a Cabal file getBasicDescription - :: UserName - -> UTCTime + :: UTCTime -- ^ Time of upload -> CabalFileText -> Int -- ^ Metadata revision. This will be added to the resulting -- @PackageBasicDescription@ -> Either String PackageBasicDescription -getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = +getBasicDescription uploadedAt (CabalFileText cf) metadataRev = let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf) in case PkgDescr.runParseResult parseResult of (_, Right pkg) -> let @@ -157,7 +162,6 @@ getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = pbd_homepage = T.pack . fromShortText $ PkgDescr.homepage pkgd pbd_metadata_revision = metadataRev pbd_uploaded_at = uploadedAt - pbd_uploader = uploader in return $ PackageBasicDescription {..} (_, Left (_, perrs)) -> @@ -165,6 +169,32 @@ getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = in Left $ "Could not parse cabal file: " <> errs +basicDescriptionToDTO :: UserName -> PackageBasicDescription -> PackageBasicDescriptionDTO +basicDescriptionToDTO uploader d = + PackageBasicDescriptionDTO + { license = d.pbd_license + , copyright = d.pbd_copyright + , synopsis = d.pbd_synopsis + , description = d.pbd_description + , author = d.pbd_author + , homepage = d.pbd_homepage + , metadata_revision = d.pbd_metadata_revision + , uploaded_at = d.pbd_uploaded_at + , uploader + } + +dtoToBasicDescription :: PackageBasicDescriptionDTO -> PackageBasicDescription +dtoToBasicDescription dto = + PackageBasicDescription + { pbd_license = dto.license + , pbd_copyright = dto.copyright + , pbd_synopsis = dto.synopsis + , pbd_description = dto.description + , pbd_author = dto.author + , pbd_homepage = dto.homepage + , pbd_metadata_revision = dto.metadata_revision + , pbd_uploaded_at = dto.uploaded_at + } -- | Get a JSON @PackageBasicDescription@ for a particular -- package/version/metadata-revision @@ -172,13 +202,14 @@ getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = -- A listing of versions and their deprecation states servePackageBasicDescription :: CoreResource + -> Map PackageIdentifier UserName -> UserFeature -> Preferred.VersionsFeature -> Framework.StateComponent Framework.AcidState PackageInfoState -> Framework.DynamicPath -- ^ URI specifying a package and version `e.g. lens or lens-4.11` -> Framework.ServerPartE Framework.Response -servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do +servePackageBasicDescription resource uploaderCache userFeature preferred packageInfoState dpath = do let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI @@ -196,15 +227,17 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa -> Maybe Int -> Framework.ServerPartE Framework.Response lookupOrInsertDescr pkgid metadataRev = do - cachedDescr <- Framework.queryState packageInfoState $ - GetDescriptionFor (pkgid, metadataRev) - descr :: PackageBasicDescription <- case cachedDescr of - Just d -> return d + cachedDescr <- Framework.queryState packageInfoState $ GetDescriptionFor (pkgid, metadataRev) + descr :: PackageBasicDescriptionDTO <- case cachedDescr of + Just d -> do + uploader <- getPackageUploader pkgid uploaderCache + return $ basicDescriptionToDTO uploader d Nothing -> do - d <- getPackageDescr pkgid metadataRev + dto <- getPackageDescr pkgid metadataRev + let description = dtoToBasicDescription dto Framework.updateState packageInfoState $ - SetDescriptionFor (pkgid, metadataRev) (Just d) - return d + SetDescriptionFor (pkgid, metadataRev) (Just description) + return dto return $ Framework.toResponse $ Aeson.toJSON descr getPackageDescr pkgid metadataRev = do @@ -227,10 +260,12 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa uploadedAt = fst $ uploadInfos Vector.! metadataInd uploaderId = snd $ uploadInfos Vector.! metadataInd uploader <- userName <$> lookupUserInfo userFeature uploaderId - let pkgDescr = getBasicDescription uploader uploadedAt cabalFile metadataInd + let pkgDescr = getBasicDescription uploadedAt cabalFile metadataInd case pkgDescr of Left e -> Framework.errInternalError [Framework.MText e] - Right d -> return d + Right d -> do + let packageInfoDTO = basicDescriptionToDTO uploader d + return packageInfoDTO lookupOrInsertVersions :: PackageName @@ -255,6 +290,14 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa . Preferred.classifyVersions prefInfo $ fmap packageVersion pkgs +getPackageUploader + :: PackageIdentifier + -> Map PackageIdentifier UserName + -> Framework.ServerPartE UserName +getPackageUploader pkgId cache = + case Map.lookup pkgId cache of + Just u -> pure u + Nothing -> Framework.errNotFound "Could not find uploader" [] -- | Our backup doesn't produce any entries, and backup restore -- returns an empty state. Our responses are cheap enough to diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs index d101a345a..342c2b7c3 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -40,12 +40,38 @@ import qualified Distribution.Parsec as Parsec import qualified Distribution.Server.Features.PreferredVersions as Preferred import Distribution.Server.Framework.MemSize (MemSize, - memSize, memSize9) + memSize, memSize8) import Distribution.Server.Users.Types (UserName) +-- | Data type used in the `/package/:packagename` JSON endpoint +data PackageBasicDescriptionDTO = PackageBasicDescriptionDTO + { license :: !License + , copyright :: !T.Text + , synopsis :: !T.Text + , description :: !T.Text + , author :: !T.Text + , homepage :: !T.Text + , metadata_revision :: !Int + , uploaded_at :: !UTCTime + , uploader :: !UserName + } deriving (Eq, Show, Generic) + +instance Aeson.ToJSON PackageBasicDescriptionDTO where + toJSON PackageBasicDescriptionDTO {..} = + Aeson.object + [ Key.fromString "license" .= Pretty.prettyShow license + , Key.fromString "copyright" .= copyright + , Key.fromString "synopsis" .= synopsis + , Key.fromString "description" .= description + , Key.fromString "author" .= author + , Key.fromString "homepage" .= homepage + , Key.fromString "metadata_revision" .= metadata_revision + , Key.fromString "uploaded_at" .= uploaded_at + , Key.fromString "uploader" .= uploader + ] --- | Basic information about a package. These values are --- used in the `/package/:packagename` JSON endpoint +-- | Basic information about a package. +-- This data type is used for storage in acid-state. data PackageBasicDescription = PackageBasicDescription { pbd_license :: !License , pbd_copyright :: !T.Text @@ -55,7 +81,6 @@ data PackageBasicDescription = PackageBasicDescription , pbd_homepage :: !T.Text , pbd_metadata_revision :: !Int , pbd_uploaded_at :: !UTCTime - , pbd_uploader :: !UserName } deriving (Eq, Show, Generic) instance SafeCopy PackageBasicDescription where @@ -68,7 +93,6 @@ instance SafeCopy PackageBasicDescription where put $ T.encodeUtf8 pbd_homepage put pbd_metadata_revision safePut pbd_uploaded_at - safePut pbd_uploader getCopy = contain $ do licenseStr <- get @@ -82,7 +106,6 @@ instance SafeCopy PackageBasicDescription where pbd_homepage <- T.decodeUtf8 <$> get pbd_metadata_revision <- get pbd_uploaded_at <- safeGet - pbd_uploader <- safeGet return PackageBasicDescription{..} @@ -99,7 +122,6 @@ instance Aeson.ToJSON PackageBasicDescription where , Key.fromString "homepage" .= pbd_homepage , Key.fromString "metadata_revision" .= pbd_metadata_revision , Key.fromString "uploaded_at" .= pbd_uploaded_at - , Key.fromString "uploader" .= pbd_uploader ] instance Aeson.FromJSON PackageBasicDescription where @@ -117,7 +139,6 @@ instance Aeson.FromJSON PackageBasicDescription where pbd_homepage <- obj .: Key.fromString "homepage" pbd_metadata_revision <- obj .: Key.fromString "metadata_revision" pbd_uploaded_at <- obj .: Key.fromString "uploaded_at" - pbd_uploader <- obj .: Key.fromString "uploader" return $ PackageBasicDescription {..} -- | An index of versions for one Hackage package @@ -232,8 +253,8 @@ deriveSafeCopy 0 'base ''PackageInfoState instance MemSize PackageBasicDescription where memSize PackageBasicDescription{..} = - memSize9 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis - pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at pbd_uploader + memSize8 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis + pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at instance MemSize PackageVersions where memSize (PackageVersions ps) = getSum $ From 31b0e6766c6a0fce1f62ed80c9582af94ac6423f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Kleidukos?= Date: Thu, 15 Jan 2026 17:30:37 +0100 Subject: [PATCH 2/6] Remove uploader cache --- .../Server/Features/PackageInfoJSON.hs | 42 +++++++------------ 1 file changed, 15 insertions(+), 27 deletions(-) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 224de154a..c6165dcec 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -59,8 +59,6 @@ import qualified Data.List as List import Data.Time (UTCTime) import Distribution.Server.Users.Types (UserName (..), UserInfo(..)) import Distribution.Server.Features.Users (UserFeature(lookupUserInfo)) -import Data.Map (Map) -import qualified Data.Map as Map data PackageInfoJSONFeature = PackageInfoJSONFeature { @@ -97,18 +95,17 @@ initPackageInfoJSONFeature env = do \and the values are whether the version is preferred or not" vInfo = "Get basic package information at a specific metadata revision" - uploaderCache = undefined jsonResources = [ (Framework.extendResource (corePackagePage coreR)) { Framework.resourceDesc = [(Framework.GET, info)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR uploaderCache userFeature + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } , (Framework.extendResource (coreCabalFileRev coreR)) { Framework.resourceDesc = [(Framework.GET, vInfo)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR uploaderCache userFeature + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } ] @@ -202,14 +199,13 @@ dtoToBasicDescription dto = -- A listing of versions and their deprecation states servePackageBasicDescription :: CoreResource - -> Map PackageIdentifier UserName -> UserFeature -> Preferred.VersionsFeature -> Framework.StateComponent Framework.AcidState PackageInfoState -> Framework.DynamicPath -- ^ URI specifying a package and version `e.g. lens or lens-4.11` -> Framework.ServerPartE Framework.Response -servePackageBasicDescription resource uploaderCache userFeature preferred packageInfoState dpath = do +servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI @@ -228,26 +224,27 @@ servePackageBasicDescription resource uploaderCache userFeature preferred packag -> Framework.ServerPartE Framework.Response lookupOrInsertDescr pkgid metadataRev = do cachedDescr <- Framework.queryState packageInfoState $ GetDescriptionFor (pkgid, metadataRev) + guardValidPackageId resource pkgid + pkg <- lookupPackageId resource pkgid + + let metadataRevs = fst <$> pkgMetadataRevisions pkg + uploadInfos = snd <$> pkgMetadataRevisions pkg + nMetadata = Vector.length metadataRevs + metadataInd = fromMaybe (nMetadata - 1) metadataRev descr :: PackageBasicDescriptionDTO <- case cachedDescr of Just d -> do - uploader <- getPackageUploader pkgid uploaderCache - return $ basicDescriptionToDTO uploader d + let uploaderId = snd $ uploadInfos Vector.! metadataInd + uploader <- userName <$> lookupUserInfo userFeature uploaderId + return $ basicDescriptionToDTO uploader d Nothing -> do - dto <- getPackageDescr pkgid metadataRev + dto <- getPackageDescr metadataInd nMetadata metadataRevs uploadInfos let description = dtoToBasicDescription dto Framework.updateState packageInfoState $ SetDescriptionFor (pkgid, metadataRev) (Just description) return dto return $ Framework.toResponse $ Aeson.toJSON descr - getPackageDescr pkgid metadataRev = do - guardValidPackageId resource pkgid - pkg <- lookupPackageId resource pkgid - - let metadataRevs = fst <$> pkgMetadataRevisions pkg - uploadInfos = snd <$> pkgMetadataRevisions pkg - nMetadata = Vector.length metadataRevs - metadataInd = fromMaybe (nMetadata - 1) metadataRev + getPackageDescr metadataInd nMetadata metadataRevs uploadInfos = do when (metadataInd < 0 || metadataInd >= nMetadata) (Framework.errNotFound "Revision not found" @@ -290,15 +287,6 @@ servePackageBasicDescription resource uploaderCache userFeature preferred packag . Preferred.classifyVersions prefInfo $ fmap packageVersion pkgs -getPackageUploader - :: PackageIdentifier - -> Map PackageIdentifier UserName - -> Framework.ServerPartE UserName -getPackageUploader pkgId cache = - case Map.lookup pkgId cache of - Just u -> pure u - Nothing -> Framework.errNotFound "Could not find uploader" [] - -- | Our backup doesn't produce any entries, and backup restore -- returns an empty state. Our responses are cheap enough to -- compute that we would rather regenerate them by need than From a8829ec5c298a1d5cafabe8f84cdb0ec15c43970 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Thu, 15 Jan 2026 21:39:31 +0100 Subject: [PATCH 3/6] Remove redundant usage of state cache --- .../Server/Features/PackageInfoJSON.hs | 27 +------------------ 1 file changed, 1 insertion(+), 26 deletions(-) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index c6165dcec..e912d9410 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -180,19 +180,6 @@ basicDescriptionToDTO uploader d = , uploader } -dtoToBasicDescription :: PackageBasicDescriptionDTO -> PackageBasicDescription -dtoToBasicDescription dto = - PackageBasicDescription - { pbd_license = dto.license - , pbd_copyright = dto.copyright - , pbd_synopsis = dto.synopsis - , pbd_description = dto.description - , pbd_author = dto.author - , pbd_homepage = dto.homepage - , pbd_metadata_revision = dto.metadata_revision - , pbd_uploaded_at = dto.uploaded_at - } - -- | Get a JSON @PackageBasicDescription@ for a particular -- package/version/metadata-revision -- OR @@ -223,7 +210,6 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa -> Maybe Int -> Framework.ServerPartE Framework.Response lookupOrInsertDescr pkgid metadataRev = do - cachedDescr <- Framework.queryState packageInfoState $ GetDescriptionFor (pkgid, metadataRev) guardValidPackageId resource pkgid pkg <- lookupPackageId resource pkgid @@ -231,21 +217,10 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa uploadInfos = snd <$> pkgMetadataRevisions pkg nMetadata = Vector.length metadataRevs metadataInd = fromMaybe (nMetadata - 1) metadataRev - descr :: PackageBasicDescriptionDTO <- case cachedDescr of - Just d -> do - let uploaderId = snd $ uploadInfos Vector.! metadataInd - uploader <- userName <$> lookupUserInfo userFeature uploaderId - return $ basicDescriptionToDTO uploader d - Nothing -> do - dto <- getPackageDescr metadataInd nMetadata metadataRevs uploadInfos - let description = dtoToBasicDescription dto - Framework.updateState packageInfoState $ - SetDescriptionFor (pkgid, metadataRev) (Just description) - return dto + descr <- getPackageDescr metadataInd nMetadata metadataRevs uploadInfos return $ Framework.toResponse $ Aeson.toJSON descr getPackageDescr metadataInd nMetadata metadataRevs uploadInfos = do - when (metadataInd < 0 || metadataInd >= nMetadata) (Framework.errNotFound "Revision not found" [Framework.MText From 9483db26a9723bb6cfc8425274085a0b8301b8dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Moonlight?= Date: Thu, 15 Jan 2026 21:40:33 +0100 Subject: [PATCH 4/6] Remove extraneous cache functions for package descriptions --- src/Distribution/Server/Features/PackageInfoJSON.hs | 4 ---- .../Server/Features/PackageInfoJSON/State.hs | 9 +-------- 2 files changed, 1 insertion(+), 12 deletions(-) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index e912d9410..aa51bdca4 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -46,8 +46,6 @@ import Distribution.Server.Features.PackageInfoJSON.State (PackageBasi PackageInfoState(..), GetPackageInfo(..), ReplacePackageInfo(..), - GetDescriptionFor(..), - SetDescriptionFor(..), GetVersionsFor(..), SetVersionsFor(..), initialPackageInfoState @@ -118,8 +116,6 @@ initPackageInfoJSONFeature env = do (packageChangeHook core) isPackageChangeAny $ \(pkgid, _) -> do - Framework.updateState packageInfoState $ - SetDescriptionFor (pkgid, Nothing) Nothing Framework.updateState packageInfoState $ SetVersionsFor (packageName pkgid) Nothing diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs index 342c2b7c3..2ec27e257 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -217,11 +217,6 @@ data PackageInfoState = PackageInfoState { , migratedEphemeralData :: Bool } deriving (Show, Eq) -getDescriptionFor - :: (PackageIdentifier, Maybe Int) - -> Query PackageInfoState (Maybe PackageBasicDescription) -getDescriptionFor pkgId = asks $ Map.lookup pkgId . descriptions - getVersionsFor :: PackageName -> Query PackageInfoState (Maybe PackageVersions) @@ -272,9 +267,7 @@ initialPackageInfoState freshDB = PackageInfoState } makeAcidic ''PackageInfoState - [ 'getDescriptionFor - , 'getVersionsFor - , 'setDescriptionFor + [ 'getVersionsFor , 'setVersionsFor , 'getPackageInfo , 'replacePackageInfo From 7711f14c4ce0f7cea97efff8ee05a18afe391224 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Thu, 15 Jan 2026 16:40:52 -0500 Subject: [PATCH 5/6] remove packageinfojson state entirely --- .../Server/Features/PackageInfoJSON.hs | 177 ++++++----- .../Server/Features/PackageInfoJSON/State.hs | 274 ------------------ 2 files changed, 85 insertions(+), 366 deletions(-) delete mode 100644 src/Distribution/Server/Features/PackageInfoJSON/State.hs diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index aa51bdca4..3e3b508f2 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -17,39 +17,31 @@ import Prelude () import Distribution.Server.Prelude import qualified Data.Aeson as Aeson +import Data.Aeson ((.=)) +import qualified Data.Aeson.Key as Key import qualified Data.ByteString.Lazy.Char8 as BS (toStrict) +import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Vector as Vector import Distribution.License (licenseToSPDX) import Distribution.Package (PackageIdentifier(..), - PackageName, packageName, packageVersion) import qualified Distribution.Parsec as Parsec import qualified Distribution.PackageDescription.Parsec as PkgDescr +import Distribution.Text (display) import qualified Distribution.Types.GenericPackageDescription as PkgDescr import qualified Distribution.Types.PackageDescription as PkgDescr -import Distribution.Version (nullVersion) +import qualified Distribution.Pretty as Pretty +import Distribution.SPDX.License (License) +import Distribution.Version (nullVersion, Version) -import Distribution.Server.Framework (()) -import qualified Distribution.Server.Framework as Framework -import Distribution.Server.Features.Core (CoreFeature(..), - CoreResource(..), - isPackageChangeAny) +import qualified Distribution.Server.Framework as Framework +import Distribution.Server.Features.Core (CoreFeature(..), + CoreResource(..)) import qualified Distribution.Server.Features.PreferredVersions as Preferred -import Distribution.Server.Packages.Types (CabalFileText(..), pkgMetadataRevisions) -import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) - -import Distribution.Server.Features.PackageInfoJSON.State (PackageBasicDescription(..), - PackageBasicDescriptionDTO(..), - PackageVersions(..), - PackageInfoState(..), - GetPackageInfo(..), - ReplacePackageInfo(..), - GetVersionsFor(..), - SetVersionsFor(..), - initialPackageInfoState - ) +import Distribution.Server.Packages.Types (CabalFileText(..), pkgMetadataRevisions) + import Distribution.Utils.ShortText (fromShortText) import Data.Foldable (toList) import Data.Traversable (for) @@ -58,6 +50,69 @@ import Data.Time (UTCTime) import Distribution.Server.Users.Types (UserName (..), UserInfo(..)) import Distribution.Server.Features.Users (UserFeature(lookupUserInfo)) +data PackageBasicDescription = PackageBasicDescription + { pbd_license :: !License + , pbd_copyright :: !T.Text + , pbd_synopsis :: !T.Text + , pbd_description :: !T.Text + , pbd_author :: !T.Text + , pbd_homepage :: !T.Text + , pbd_metadata_revision :: !Int + , pbd_uploaded_at :: !UTCTime + } deriving (Eq, Show) + + + +-- | Data type used in the `/package/:packagename` JSON endpoint +data PackageBasicDescriptionDTO = PackageBasicDescriptionDTO + { license :: !License + , copyright :: !T.Text + , synopsis :: !T.Text + , description :: !T.Text + , author :: !T.Text + , homepage :: !T.Text + , metadata_revision :: !Int + , uploaded_at :: !UTCTime + , uploader :: !UserName + } deriving (Eq, Show) + +instance Aeson.ToJSON PackageBasicDescriptionDTO where + toJSON PackageBasicDescriptionDTO {..} = + Aeson.object + [ Key.fromString "license" .= Pretty.prettyShow license + , Key.fromString "copyright" .= copyright + , Key.fromString "synopsis" .= synopsis + , Key.fromString "description" .= description + , Key.fromString "author" .= author + , Key.fromString "homepage" .= homepage + , Key.fromString "metadata_revision" .= metadata_revision + , Key.fromString "uploaded_at" .= uploaded_at + , Key.fromString "uploader" .= uploader + ] + + +-- | An index of versions for one Hackage package +-- and their preferred/deprecated status +newtype PackageVersions = PackageVersions { + unPackageVersions :: [(Version, Preferred.VersionStatus)] + } deriving (Eq, Show) + +-- | This encoding of @PackageVersions@ is used in the +-- `/package/$package` endpoint (when the URI doesn't specify) +-- a version. Any change here is an API change. +instance Aeson.ToJSON PackageVersions where + toJSON (PackageVersions p) = + Aeson.toJSON + $ Map.mapKeys display + $ fmap encodeStatus + $ Map.fromList p + where + encodeStatus = \case + Preferred.NormalVersion -> "normal" + Preferred.DeprecatedVersion -> "deprecated" + Preferred.UnpreferredVersion -> "unpreferred" + + data PackageInfoJSONFeature = PackageInfoJSONFeature { packageInfoJSONFeatureInterface :: Framework.HackageFeature @@ -77,14 +132,10 @@ data PackageInfoJSONResource = PackageInfoJSONResource { -- | Initializing our feature involves adding JSON variants to the -- endpoints that serve basic information about a package-version, -- and a packages version deprecation status. --- Additionally we set up caching for these endpoints, --- and attach a package change hook that invalidates the cache --- line for a package when it changes initPackageInfoJSONFeature :: Framework.ServerEnv -> IO (CoreFeature -> Preferred.VersionsFeature -> UserFeature -> IO PackageInfoJSONFeature) -initPackageInfoJSONFeature env = do - packageInfoState <- packageInfoStateComponent False (Framework.serverStateDir env) +initPackageInfoJSONFeature _env = do return $ \core preferred userFeature -> do let coreR = coreResource core @@ -98,36 +149,24 @@ initPackageInfoJSONFeature env = do Framework.resourceDesc = [(Framework.GET, info)] , Framework.resourceGet = [("json", servePackageBasicDescription coreR userFeature - preferred packageInfoState)] + preferred)] } , (Framework.extendResource (coreCabalFileRev coreR)) { Framework.resourceDesc = [(Framework.GET, vInfo)] , Framework.resourceGet = [("json", servePackageBasicDescription coreR userFeature - preferred packageInfoState)] + preferred)] } ] - -- When a package is modified in any way, delet all its - -- PackageInfoState cache lines. - -- They will be recalculated next time the endpoint - -- is hit - postInit = Framework.registerHookJust - (packageChangeHook core) - isPackageChangeAny $ \(pkgid, _) -> do - - Framework.updateState packageInfoState $ - SetVersionsFor (packageName pkgid) Nothing - return $ PackageInfoJSONFeature { packageInfoJSONFeatureInterface = (Framework.emptyHackageFeature "package-info-json") { Framework.featureDesc = "Provide JSON endpoints for basic package descriptions" , Framework.featureResources = jsonResources , Framework.featureCaches = [] - , Framework.featurePostInit = postInit - , Framework.featureState = - [Framework.abstractAcidStateComponent packageInfoState] + , Framework.featurePostInit = pure () + , Framework.featureState = [] } } @@ -184,11 +223,10 @@ servePackageBasicDescription :: CoreResource -> UserFeature -> Preferred.VersionsFeature - -> Framework.StateComponent Framework.AcidState PackageInfoState -> Framework.DynamicPath -- ^ URI specifying a package and version `e.g. lens or lens-4.11` -> Framework.ServerPartE Framework.Response -servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do +servePackageBasicDescription resource userFeature preferred dpath = do let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI @@ -196,16 +234,16 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa guardValidPackageName resource name if version /= nullVersion - then lookupOrInsertDescr pkgid metadataRev - else lookupOrInsertVersions name + then fetchDescr pkgid metadataRev + else Framework.toResponse . Aeson.toJSON <$> getVersionListing name where - lookupOrInsertDescr + fetchDescr :: PackageIdentifier -> Maybe Int -> Framework.ServerPartE Framework.Response - lookupOrInsertDescr pkgid metadataRev = do + fetchDescr pkgid metadataRev = do guardValidPackageId resource pkgid pkg <- lookupPackageId resource pkgid @@ -235,21 +273,6 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa let packageInfoDTO = basicDescriptionToDTO uploader d return packageInfoDTO - lookupOrInsertVersions - :: PackageName - -> Framework.ServerPartE Framework.Response - lookupOrInsertVersions pkgname = do - cachedVersions <- Framework.queryState packageInfoState $ - GetVersionsFor pkgname - vers :: PackageVersions <- case cachedVersions of - Just vs -> return vs - Nothing -> do - vs <- getVersionListing pkgname - Framework.updateState packageInfoState $ - SetVersionsFor pkgname (Just vs) - return vs - return $ Framework.toResponse $ Aeson.toJSON vers - getVersionListing name = do pkgs <- lookupPackageName resource name prefInfo <- Preferred.queryGetPreferredInfo preferred name @@ -257,33 +280,3 @@ servePackageBasicDescription resource userFeature preferred packageInfoState dpa . PackageVersions . Preferred.classifyVersions prefInfo $ fmap packageVersion pkgs - --- | Our backup doesn't produce any entries, and backup restore --- returns an empty state. Our responses are cheap enough to --- compute that we would rather regenerate them by need than --- deal with the complexity persisting backups in --- yet-another-format -packageInfoStateComponent - :: Bool - -> FilePath - -> IO (Framework.StateComponent Framework.AcidState PackageInfoState) -packageInfoStateComponent freshDB stateDir = do - st <- Framework.openLocalStateFrom - (stateDir "db" "PackageInfoJSON") - (initialPackageInfoState freshDB) - return Framework.StateComponent { - stateDesc = "Preferred package versions" - , stateHandle = st - , getState = Framework.query st GetPackageInfo - , putState = Framework.update st . ReplacePackageInfo - , resetState = packageInfoStateComponent True - , backupState = \_ -> return [] - , restoreState = nullRestore (initialPackageInfoState True) - } - where - - nullRestore :: PackageInfoState -> RestoreBackup PackageInfoState - nullRestore st = RestoreBackup { - restoreEntry = \_ -> nullRestore <$> pure (initialPackageInfoState True) - , restoreFinalize = return st - } diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs deleted file mode 100644 index 2ec27e257..000000000 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Distribution.Server.Features.PackageInfoJSON.State where - -import Control.Arrow (first, second) -import Control.Applicative ((<|>)) -import Control.Monad.Reader (ask, asks) -import qualified Control.Monad.State as State -import qualified Data.Aeson as Aeson -import Data.Aeson ((.=), (.:)) -import qualified Data.Aeson.Key as Key -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Acid (Query, Update, makeAcidic) -import qualified Data.Map.Strict as Map -import Data.Monoid (Sum(..)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.SafeCopy (SafeCopy(..), base, contain, - deriveSafeCopy, safeGet, safePut) -import Data.Serialize (Get, get, getListOf, getTwoOf, put, - putListOf, putTwoOf) -import Data.Word (Word8) -import Distribution.License (licenseToSPDX) -import Distribution.Text (display, simpleParse) -import GHC.Generics (Generic) -import Data.Time (UTCTime) - -import Distribution.SPDX.License (License) -import Distribution.Package (PackageIdentifier, PackageName) -import Distribution.Version (Version, mkVersion, versionNumbers) -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Parsec as Parsec - -import qualified Distribution.Server.Features.PreferredVersions as Preferred -import Distribution.Server.Framework.MemSize (MemSize, - memSize, memSize8) -import Distribution.Server.Users.Types (UserName) - --- | Data type used in the `/package/:packagename` JSON endpoint -data PackageBasicDescriptionDTO = PackageBasicDescriptionDTO - { license :: !License - , copyright :: !T.Text - , synopsis :: !T.Text - , description :: !T.Text - , author :: !T.Text - , homepage :: !T.Text - , metadata_revision :: !Int - , uploaded_at :: !UTCTime - , uploader :: !UserName - } deriving (Eq, Show, Generic) - -instance Aeson.ToJSON PackageBasicDescriptionDTO where - toJSON PackageBasicDescriptionDTO {..} = - Aeson.object - [ Key.fromString "license" .= Pretty.prettyShow license - , Key.fromString "copyright" .= copyright - , Key.fromString "synopsis" .= synopsis - , Key.fromString "description" .= description - , Key.fromString "author" .= author - , Key.fromString "homepage" .= homepage - , Key.fromString "metadata_revision" .= metadata_revision - , Key.fromString "uploaded_at" .= uploaded_at - , Key.fromString "uploader" .= uploader - ] - --- | Basic information about a package. --- This data type is used for storage in acid-state. -data PackageBasicDescription = PackageBasicDescription - { pbd_license :: !License - , pbd_copyright :: !T.Text - , pbd_synopsis :: !T.Text - , pbd_description :: !T.Text - , pbd_author :: !T.Text - , pbd_homepage :: !T.Text - , pbd_metadata_revision :: !Int - , pbd_uploaded_at :: !UTCTime - } deriving (Eq, Show, Generic) - -instance SafeCopy PackageBasicDescription where - putCopy PackageBasicDescription{..} = contain $ do - put (Pretty.prettyShow pbd_license) - put $ T.encodeUtf8 pbd_copyright - put $ T.encodeUtf8 pbd_synopsis - put $ T.encodeUtf8 pbd_description - put $ T.encodeUtf8 pbd_author - put $ T.encodeUtf8 pbd_homepage - put pbd_metadata_revision - safePut pbd_uploaded_at - - getCopy = contain $ do - licenseStr <- get - case Parsec.eitherParsec licenseStr of - Left e -> fail $ unwords ["Could not parse", licenseStr, "as license:" , e] - Right pbd_license -> do - pbd_copyright <- T.decodeUtf8 <$> get - pbd_synopsis <- T.decodeUtf8 <$> get - pbd_description <- T.decodeUtf8 <$> get - pbd_author <- T.decodeUtf8 <$> get - pbd_homepage <- T.decodeUtf8 <$> get - pbd_metadata_revision <- get - pbd_uploaded_at <- safeGet - return PackageBasicDescription{..} - - --- | Aeson instances are used for building the package-description --- endpoint. Any changes will impact the API endpoint. -instance Aeson.ToJSON PackageBasicDescription where - toJSON PackageBasicDescription {..} = - Aeson.object - [ Key.fromString "license" .= Pretty.prettyShow pbd_license - , Key.fromString "copyright" .= pbd_copyright - , Key.fromString "synopsis" .= pbd_synopsis - , Key.fromString "description" .= pbd_description - , Key.fromString "author" .= pbd_author - , Key.fromString "homepage" .= pbd_homepage - , Key.fromString "metadata_revision" .= pbd_metadata_revision - , Key.fromString "uploaded_at" .= pbd_uploaded_at - ] - -instance Aeson.FromJSON PackageBasicDescription where - parseJSON = Aeson.withObject "PackageBasicDescription" $ \obj -> do - pbd_version' <- obj .: Key.fromString "license" - let parseEitherLicense t = - Parsec.simpleParsec t <|> fmap licenseToSPDX (simpleParse t) - case parseEitherLicense pbd_version' of - Nothing -> fail $ concat ["Could not parse version: \"", pbd_version', "\""] - Just pbd_license -> do - pbd_copyright <- obj .: Key.fromString "copyright" - pbd_synopsis <- obj .: Key.fromString "synopsis" - pbd_description <- obj .: Key.fromString "description" - pbd_author <- obj .: Key.fromString "author" - pbd_homepage <- obj .: Key.fromString "homepage" - pbd_metadata_revision <- obj .: Key.fromString "metadata_revision" - pbd_uploaded_at <- obj .: Key.fromString "uploaded_at" - return $ PackageBasicDescription {..} - --- | An index of versions for one Hackage package --- and their preferred/deprecated status -newtype PackageVersions = PackageVersions { - unPackageVersions :: [(Version, Preferred.VersionStatus)] - } deriving (Eq, Show) - -instance SafeCopy PackageVersions where - - putCopy (PackageVersions vs) = - contain - $ putListOf (putTwoOf put put) - $ first versionNumbers . second statusTag <$> vs - where - statusTag = \case - Preferred.NormalVersion -> 0 :: Word8 - Preferred.DeprecatedVersion -> 1 - Preferred.UnpreferredVersion -> 2 - - getCopy = contain $ - fmap PackageVersions $ getListOf $ getTwoOf getVersion getStatus - where - getVersion = mkVersion <$> getListOf get - getStatus = (get :: Get Word8) >>= \case - 0 -> return Preferred.NormalVersion - 1 -> return Preferred.DeprecatedVersion - 2 -> return Preferred.UnpreferredVersion - n -> fail $ "Unsupported tag for VersionStatus: " ++ show n - - --- | This encoding of @PackageVersions@ is used in the --- `/package/$package` endpoint (when the URI doesn't specify) --- a version. Any change here is an API change. -instance Aeson.ToJSON PackageVersions where - toJSON (PackageVersions p) = - Aeson.toJSON - $ Map.mapKeys display - $ fmap encodeStatus - $ Map.fromList p - where - encodeStatus = \case - Preferred.NormalVersion -> "normal" - Preferred.DeprecatedVersion -> "deprecated" - Preferred.UnpreferredVersion -> "unpreferred" - - -instance Aeson.FromJSON PackageVersions where - parseJSON = Aeson.withObject "PackageVersions" $ \obj -> - fmap PackageVersions - $ traverse parsePair - $ KeyMap.toList obj - where - parsePair (vStr, vStatus) = - (,) <$> parseVersion (Key.toString vStr) <*> parseStatus vStatus - - parseVersion verString = - case simpleParse verString of - Just ver -> return ver - Nothing -> fail $ concat ["Could not parse \"" - , verString ++ "\" as Version. " - , "expected \"a.b.c\" form"] - - parseStatus (Aeson.String s) = case T.unpack s of - "normal" -> return Preferred.NormalVersion - "deprecated" -> return Preferred.DeprecatedVersion - "unpreferred" -> return Preferred.UnpreferredVersion - other -> fail $ "Could not parse \"" ++ other - ++ "\" as status. Expected \"normal\"" - ++ "\"deprecated\" or \"unpreferred\"" - parseStatus _ = fail "Expected a string" - -data PackageInfoState = PackageInfoState { - descriptions :: !(Map.Map (PackageIdentifier, Maybe Int) PackageBasicDescription) - , versions :: !(Map.Map PackageName PackageVersions) - , migratedEphemeralData :: Bool - } deriving (Show, Eq) - -getVersionsFor - :: PackageName - -> Query PackageInfoState (Maybe PackageVersions) -getVersionsFor pkgName = asks $ Map.lookup pkgName . versions - -setDescriptionFor - :: (PackageIdentifier, Maybe Int) - -> Maybe PackageBasicDescription - -> Update PackageInfoState () -setDescriptionFor pkgId descr = State.modify $ \p -> - case descr of - Just d -> p {descriptions = Map.alter (const (Just d)) pkgId (descriptions p)} - Nothing -> p {descriptions = Map.filterWithKey (\pkgId' _ -> fst pkgId' /= fst pkgId) (descriptions p)} - -setVersionsFor - :: PackageName - -> Maybe PackageVersions - -> Update PackageInfoState () -setVersionsFor pkgName vs = State.modify $ \p -> - p { versions = Map.alter (const vs) pkgName (versions p) } - -getPackageInfo :: Query PackageInfoState PackageInfoState -getPackageInfo = ask - -replacePackageInfo :: PackageInfoState -> Update PackageInfoState () -replacePackageInfo = State.put - -deriveSafeCopy 0 'base ''PackageInfoState - -instance MemSize PackageBasicDescription where - memSize PackageBasicDescription{..} = - memSize8 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis - pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at - -instance MemSize PackageVersions where - memSize (PackageVersions ps) = getSum $ - foldMap (\(v,_) -> Sum (memSize v) `mappend` Sum (memSize (0 :: Word))) ps - -instance MemSize PackageInfoState where - memSize (PackageInfoState {..}) = memSize descriptions + memSize versions - - -initialPackageInfoState :: Bool -> PackageInfoState -initialPackageInfoState freshDB = PackageInfoState - { descriptions = mempty - , versions = mempty - , migratedEphemeralData = freshDB - } - -makeAcidic ''PackageInfoState - [ 'getVersionsFor - , 'setVersionsFor - , 'getPackageInfo - , 'replacePackageInfo - ] From cf1d244460b6d8b36ac9537eab171995628d2c71 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Thu, 15 Jan 2026 17:21:01 -0500 Subject: [PATCH 6/6] cleanup cabal --- hackage-server.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/hackage-server.cabal b/hackage-server.cabal index 1cf7a1b16..4d31893fe 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -365,7 +365,6 @@ library Distribution.Server.Features.HaskellPlatform Distribution.Server.Features.HaskellPlatform.State Distribution.Server.Features.PackageInfoJSON - Distribution.Server.Features.PackageInfoJSON.State Distribution.Server.Features.Search Distribution.Server.Features.Search.BM25F Distribution.Server.Features.Search.DocIdSet