From d292789dd2bd8f0ba4d815ef4f3ab11e96b4f9ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate=20Kleidukos?= Date: Tue, 1 Apr 2025 13:58:30 +0200 Subject: [PATCH] Add uploader's username to package json API --- src/Distribution/Server/Features.hs | 1 + .../Server/Features/PackageInfoJSON.hs | 23 ++++++++++++------- .../Server/Features/PackageInfoJSON/State.hs | 16 ++++++++----- src/Distribution/Server/Users/Types.hs | 6 +++-- 4 files changed, 30 insertions(+), 16 deletions(-) diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index b4e2d96d5..9755fce2d 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -379,6 +379,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do packageInfoJSONFeature <- mkPackageJSONFeature coreFeature versionsFeature + usersFeature #endif diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index ceabedefd..2bcdc7781 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -54,6 +54,8 @@ 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.Features.Users (UserFeature(lookupUserInfo)) data PackageInfoJSONFeature = PackageInfoJSONFeature { @@ -79,10 +81,10 @@ data PackageInfoJSONResource = PackageInfoJSONResource { -- line for a package when it changes initPackageInfoJSONFeature :: Framework.ServerEnv - -> IO (CoreFeature -> Preferred.VersionsFeature -> IO PackageInfoJSONFeature) + -> IO (CoreFeature -> Preferred.VersionsFeature -> UserFeature -> IO PackageInfoJSONFeature) initPackageInfoJSONFeature env = do packageInfoState <- packageInfoStateComponent False (Framework.serverStateDir env) - return $ \core preferred -> do + return $ \core preferred userFeature -> do let coreR = coreResource core info = "Get basic package information: \ @@ -94,13 +96,13 @@ initPackageInfoJSONFeature env = do (Framework.extendResource (corePackagePage coreR)) { Framework.resourceDesc = [(Framework.GET, info)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } , (Framework.extendResource (coreCabalFileRev coreR)) { Framework.resourceDesc = [(Framework.GET, vInfo)] , Framework.resourceGet = - [("json", servePackageBasicDescription coreR + [("json", servePackageBasicDescription coreR userFeature preferred packageInfoState)] } ] @@ -133,14 +135,15 @@ initPackageInfoJSONFeature env = do -- | Pure function for extracting basic package info from a Cabal file getBasicDescription - :: UTCTime + :: UserName + -> UTCTime -- ^ Time of upload -> CabalFileText -> Int -- ^ Metadata revision. This will be added to the resulting -- @PackageBasicDescription@ -> Either String PackageBasicDescription -getBasicDescription uploadedAt (CabalFileText cf) metadataRev = +getBasicDescription uploader uploadedAt (CabalFileText cf) metadataRev = let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf) in case PkgDescr.runParseResult parseResult of (_, Right pkg) -> let @@ -154,6 +157,7 @@ getBasicDescription 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)) -> @@ -168,12 +172,13 @@ getBasicDescription uploadedAt (CabalFileText cf) metadataRev = -- A listing of versions and their deprecation states 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 preferred packageInfoState dpath = do +servePackageBasicDescription resource userFeature preferred packageInfoState dpath = do let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI @@ -220,7 +225,9 @@ servePackageBasicDescription resource preferred packageInfoState dpath = do let cabalFile = metadataRevs Vector.! metadataInd uploadedAt = fst $ uploadInfos Vector.! metadataInd - pkgDescr = getBasicDescription uploadedAt cabalFile metadataInd + uploaderId = snd $ uploadInfos Vector.! metadataInd + uploader <- userName <$> lookupUserInfo userFeature uploaderId + let pkgDescr = getBasicDescription uploader uploadedAt cabalFile metadataInd case pkgDescr of Left e -> Framework.errInternalError [Framework.MText e] Right d -> return d diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs index 53adfa242..4c50e278a 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -41,7 +41,8 @@ import qualified Distribution.Parsec as Parsec import qualified Distribution.Server.Features.PreferredVersions as Preferred import Distribution.Server.Framework.MemSize (MemSize, - memSize, memSize8) + memSize, memSize9) +import Distribution.Server.Users.Types (UserName) -- | Basic information about a package. These values are @@ -55,6 +56,7 @@ 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 @@ -67,6 +69,7 @@ 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 @@ -80,6 +83,7 @@ instance SafeCopy PackageBasicDescription where pbd_homepage <- T.decodeUtf8 <$> get pbd_metadata_revision <- get pbd_uploaded_at <- safeGet + pbd_uploader <- safeGet return PackageBasicDescription{..} @@ -96,9 +100,9 @@ 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 parseJSON = Aeson.withObject "PackageBasicDescription" $ \obj -> do pbd_version' <- obj .: Key.fromString "license" @@ -114,8 +118,8 @@ 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" - return $ - PackageBasicDescription {..} + pbd_uploader <- obj .: Key.fromString "uploader" + return $ PackageBasicDescription {..} -- | An index of versions for one Hackage package -- and their preferred/deprecated status @@ -229,8 +233,8 @@ 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 + memSize9 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis + pbd_description pbd_author pbd_homepage pbd_metadata_revision pbd_uploaded_at pbd_uploader instance MemSize PackageVersions where memSize (PackageVersions ps) = getSum $ diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs index 14f484475..f1f62bd74 100644 --- a/src/Distribution/Server/Users/Types.hs +++ b/src/Distribution/Server/Users/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} module Distribution.Server.Users.Types ( module Distribution.Server.Users.Types, module Distribution.Server.Users.AuthToken, @@ -26,13 +27,14 @@ import Data.Aeson (ToJSON, FromJSON) import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) import Data.Typeable (Typeable) import Data.Hashable +import Data.Serialize (Serialize) newtype UserId = UserId Int - deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Pretty) + deriving newtype (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Pretty) newtype UserName = UserName String - deriving (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Hashable) + deriving newtype (Eq, Ord, Read, Show, Typeable, MemSize, ToJSON, FromJSON, Hashable, Serialize) data UserInfo = UserInfo { userName :: !UserName,