diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 2bcdc778..224de154 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 4c50e278..8c326baa 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON/State.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs @@ -41,12 +41,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 @@ -56,7 +82,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 @@ -69,7 +94,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 @@ -83,7 +107,6 @@ instance SafeCopy PackageBasicDescription where pbd_homepage <- T.decodeUtf8 <$> get pbd_metadata_revision <- get pbd_uploaded_at <- safeGet - pbd_uploader <- safeGet return PackageBasicDescription{..} @@ -100,7 +123,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 @@ -118,7 +140,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 @@ -233,8 +254,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 $