Merge pull request #1375 from haskell/add-uploader-username-to-package-json-api

Add uploader's username to package json API

Author: gbaz

src/Distribution/Server/Features.hs

@@ -379,6 +379,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
     packageInfoJSONFeature <- mkPackageJSONFeature
                                 coreFeature
                                 versionsFeature
+                                usersFeature
 
 #endif
 

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

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 $

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,