Skip to content

Commit 9ea6c75

Browse files
imalsogregKleidukos
imalsogreg
authored and
Kleidukos
committed
Add JSON endpoints for basic package information
1 parent 2e61047 commit 9ea6c75

File tree

7 files changed

+554
-3
lines changed

7 files changed

+554
-3
lines changed

‎Distribution/Server/Features.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Distribution.Server.Features.Distro (initDistroFeature)
2929
import Distribution.Server.Features.PackageContents (initPackageContentsFeature)
3030
import Distribution.Server.Features.Documentation (initDocumentationFeature)
3131
import Distribution.Server.Features.BuildReports (initBuildReportsFeature)
32+
import Distribution.Server.Features.PackageInfoJSON (initPackageInfoJSONFeature)
3233
import Distribution.Server.Features.LegacyRedirects (legacyRedirectsFeature)
3334
import Distribution.Server.Features.PreferredVersions (initVersionsFeature)
3435
-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies (initReverseFeature)
@@ -151,6 +152,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
151152
initSitemapFeature env
152153
mkPackageFeedFeature <- logStartup "package feed" $
153154
initPackageFeedFeature env
155+
mkPackageJSONFeature <- logStartup "package info JSON" $
156+
initPackageInfoJSONFeature env
154157
#endif
155158

156159
loginfo verbosity "Initialising features, part 2"
@@ -324,6 +327,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
324327
usersFeature
325328
tarIndexCacheFeature
326329

330+
packageInfoJSONFeature <- mkPackageJSONFeature
331+
coreFeature
332+
versionsFeature
333+
327334
#endif
328335

329336
-- The order of initialization above should be the same as
@@ -364,6 +371,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
364371
, getFeatureInterface adminLogFeature
365372
, getFeatureInterface siteMapFeature
366373
, getFeatureInterface packageFeedFeature
374+
, getFeatureInterface packageInfoJSONFeature
367375
#endif
368376
, staticFilesFeature
369377
, serverIntrospectFeature allFeatures

‎Distribution/Server/Features/Core.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -221,6 +221,8 @@ data CoreResource = CoreResource {
221221
coreCabalFile :: Resource,
222222
-- | A tarball for a package version.
223223
corePackageTarball :: Resource,
224+
-- | A Cabal file metatada revision.
225+
coreCabalFileRev :: Resource,
224226

225227
-- Rendering resources.
226228
-- | URI for `corePackagesPage`, given a format (blank for none).

‎Distribution/Server/Features/PackageInfoJSON.hs

Lines changed: 272 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,272 @@
1+
{-# LANGUAGE RankNTypes #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
5+
module Distribution.Server.Features.PackageInfoJSON (
6+
PackageInfoJSONFeature(..)
7+
, PackageInfoJSONResource(..)
8+
, initPackageInfoJSONFeature
9+
10+
, PackageBasicDescription(..)
11+
, PackageVersions(..)
12+
) where
13+
14+
import Prelude ()
15+
import Distribution.Server.Prelude
16+
17+
import qualified Data.Aeson as Aeson
18+
import qualified Data.ByteString.Lazy.Char8 as BS (toStrict)
19+
import qualified Data.Text as T
20+
import qualified Data.Vector as Vector
21+
22+
import Distribution.License (licenseToSPDX)
23+
import Distribution.Package (PackageIdentifier(..),
24+
PackageName, packageName,
25+
packageVersion)
26+
import qualified Distribution.Parsec as Parsec
27+
import qualified Distribution.PackageDescription.Parsec as PkgDescr
28+
import qualified Distribution.Types.GenericPackageDescription as PkgDescr
29+
import qualified Distribution.Types.PackageDescription as PkgDescr
30+
import Distribution.Version (nullVersion)
31+
32+
import Distribution.Server.Framework ((</>))
33+
import qualified Distribution.Server.Framework as Framework
34+
import Distribution.Server.Features.Core (CoreFeature(..),
35+
CoreResource(..),
36+
isPackageChangeAny)
37+
import qualified Distribution.Server.Features.PreferredVersions as Preferred
38+
import Distribution.Server.Packages.Types (CabalFileText(..), pkgMetadataRevisions)
39+
import Distribution.Server.Framework.BackupRestore (RestoreBackup(..))
40+
41+
import Distribution.Server.Features.PackageInfoJSON.State (PackageBasicDescription(..),
42+
PackageVersions(..),
43+
PackageInfoState(..),
44+
GetPackageInfo(..),
45+
ReplacePackageInfo(..),
46+
GetDescriptionFor(..),
47+
SetDescriptionFor(..),
48+
GetVersionsFor(..),
49+
SetVersionsFor(..),
50+
initialPackageInfoState
51+
)
52+
import Distribution.Utils.ShortText (fromShortText)
53+
import Data.Foldable (toList)
54+
import Data.Traversable (for)
55+
import qualified Data.List as List
56+
57+
58+
data PackageInfoJSONFeature = PackageInfoJSONFeature {
59+
packageInfoJSONFeatureInterface :: Framework.HackageFeature
60+
}
61+
62+
63+
instance Framework.IsHackageFeature PackageInfoJSONFeature where
64+
getFeatureInterface = packageInfoJSONFeatureInterface
65+
66+
67+
data PackageInfoJSONResource = PackageInfoJSONResource {
68+
packageJSONResource :: Framework.Resource,
69+
packageVersionJSONResource :: Framework.Resource
70+
}
71+
72+
73+
-- | Initializing our feature involves adding JSON variants to the
74+
-- endpoints that serve basic information about a package-version,
75+
-- and a packages version deprecation status.
76+
-- Aditionally we set up caching for these endpoints,
77+
-- and attach a package change hook that invalidates the cache
78+
-- line for a package when in changes
79+
initPackageInfoJSONFeature
80+
:: Framework.ServerEnv
81+
-> IO (CoreFeature -> Preferred.VersionsFeature -> IO PackageInfoJSONFeature)
82+
initPackageInfoJSONFeature env = do
83+
packageInfoState <- packageInfoStateComponent False (Framework.serverStateDir env)
84+
return $ \core preferred -> do
85+
86+
let coreR = coreResource core
87+
info = "Get basic package information"
88+
vInfo = "Get basic package information at a specific metadata revision"
89+
90+
jsonResources = [
91+
(Framework.extendResource (corePackagePage coreR)) {
92+
Framework.resourceDesc = [(Framework.GET, info)]
93+
, Framework.resourceGet =
94+
[("json", servePackageBasicDescription coreR
95+
preferred packageInfoState)]
96+
}
97+
, (Framework.extendResource (coreCabalFileRev coreR)) {
98+
Framework.resourceDesc = [(Framework.GET, vInfo)]
99+
, Framework.resourceGet =
100+
[("json", servePackageBasicDescription coreR
101+
preferred packageInfoState)]
102+
}
103+
]
104+
105+
-- When a package is modified in any way, delet all its
106+
-- PackageInfoState cache lines.
107+
-- They will be recalculated next time the endpoint
108+
-- is hit
109+
postInit = Framework.registerHookJust
110+
(packageChangeHook core)
111+
isPackageChangeAny $ \(pkgid, _) -> do
112+
113+
Framework.updateState packageInfoState $
114+
SetDescriptionFor (pkgid, Nothing) Nothing
115+
Framework.updateState packageInfoState $
116+
SetVersionsFor (packageName pkgid) Nothing
117+
118+
return $ PackageInfoJSONFeature {
119+
packageInfoJSONFeatureInterface =
120+
(Framework.emptyHackageFeature "package-info-json")
121+
{ Framework.featureDesc = "Provide JSON endpoints for basic package descriptions"
122+
, Framework.featureResources = jsonResources
123+
, Framework.featureCaches = []
124+
, Framework.featurePostInit = postInit
125+
, Framework.featureState =
126+
[Framework.abstractAcidStateComponent packageInfoState]
127+
}
128+
}
129+
130+
131+
-- | Pure function for extrcacting basic package info from a Cabal file
132+
getBasicDescription
133+
:: CabalFileText
134+
-> Int
135+
-- ^ Metadata revision. This will be added to the resulting
136+
-- @PackageBasicDescription@
137+
-> Either String PackageBasicDescription
138+
getBasicDescription (CabalFileText cf) metadataRev =
139+
let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf)
140+
in case PkgDescr.runParseResult parseResult of
141+
(_, Right pkg) -> let
142+
pkgd = PkgDescr.packageDescription pkg
143+
pbd_author = T.pack . fromShortText $ PkgDescr.author pkgd
144+
pbd_copyright = T.pack . fromShortText $ PkgDescr.copyright pkgd
145+
pbd_synopsis = T.pack . fromShortText $ PkgDescr.synopsis pkgd
146+
pbd_description = T.pack . fromShortText $ PkgDescr.description pkgd
147+
pbd_license = either id licenseToSPDX $
148+
PkgDescr.licenseRaw pkgd
149+
pbd_homepage = T.pack . fromShortText $ PkgDescr.homepage pkgd
150+
pbd_metadata_revision = metadataRev
151+
in
152+
return $ PackageBasicDescription {..}
153+
(_, Left (_, perrs)) ->
154+
let errs = List.intersperse '\n' $ mconcat $ for (toList perrs) $ \err -> Parsec.showPError "" err
155+
in Left $ "Could not parse cabal file: "
156+
<> errs
157+
158+
159+
-- | Get a JSON @PackageBasicDescription@ for a particular
160+
-- package/version/metadata-revision
161+
-- OR
162+
-- A listing of versions and their deprecation states
163+
servePackageBasicDescription
164+
:: CoreResource
165+
-> Preferred.VersionsFeature
166+
-> Framework.StateComponent Framework.AcidState PackageInfoState
167+
-> Framework.DynamicPath
168+
-- ^ URI specifying a package and version `e.g. lens or lens-4.11`
169+
-> Framework.ServerPartE Framework.Response
170+
servePackageBasicDescription resource preferred packageInfoState dpath = do
171+
172+
let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI
173+
174+
pkgid@(PackageIdentifier name version) <- packageInPath resource dpath
175+
guardValidPackageName resource name
176+
177+
if version /= nullVersion
178+
then lookupOrInsertDescr pkgid metadataRev
179+
else lookupOrInsertVersions name
180+
181+
where
182+
183+
lookupOrInsertDescr
184+
:: PackageIdentifier
185+
-> Maybe Int
186+
-> Framework.ServerPartE Framework.Response
187+
lookupOrInsertDescr pkgid metadataRev = do
188+
cachedDescr <- Framework.queryState packageInfoState $
189+
GetDescriptionFor (pkgid, metadataRev)
190+
descr :: PackageBasicDescription <- case cachedDescr of
191+
Just d -> return d
192+
Nothing -> do
193+
d <- getPackageDescr pkgid metadataRev
194+
Framework.updateState packageInfoState $
195+
SetDescriptionFor (pkgid, metadataRev) (Just d)
196+
return d
197+
return $ Framework.toResponse $ Aeson.toJSON descr
198+
199+
getPackageDescr pkgid metadataRev = do
200+
guardValidPackageId resource pkgid
201+
pkg <- lookupPackageId resource pkgid
202+
203+
let metadataRevs = fst <$> pkgMetadataRevisions pkg
204+
nMetadata = Vector.length metadataRevs
205+
metadataInd = fromMaybe (nMetadata - 1) metadataRev
206+
207+
when (metadataInd < 0 || metadataInd >= nMetadata)
208+
(Framework.errNotFound "Revision not found"
209+
[Framework.MText
210+
$ "There are " <> show nMetadata <> " metadata revisions. Index "
211+
<> show metadataInd <> " is out of bounds."]
212+
)
213+
214+
let cabalFile = metadataRevs Vector.! metadataInd
215+
pkgDescr = getBasicDescription cabalFile metadataInd
216+
case pkgDescr of
217+
Left e -> Framework.errInternalError [Framework.MText e]
218+
Right d -> return d
219+
220+
lookupOrInsertVersions
221+
:: PackageName
222+
-> Framework.ServerPartE Framework.Response
223+
lookupOrInsertVersions pkgname = do
224+
cachedVersions <- Framework.queryState packageInfoState $
225+
GetVersionsFor pkgname
226+
vers :: PackageVersions <- case cachedVersions of
227+
Just vs -> return vs
228+
Nothing -> do
229+
vs <- getVersionListing pkgname
230+
Framework.updateState packageInfoState $
231+
SetVersionsFor pkgname (Just vs)
232+
return vs
233+
return $ Framework.toResponse $ Aeson.toJSON vers
234+
235+
getVersionListing name = do
236+
pkgs <- lookupPackageName resource name
237+
prefInfo <- Preferred.queryGetPreferredInfo preferred name
238+
return
239+
. PackageVersions
240+
. Preferred.classifyVersions prefInfo
241+
$ fmap packageVersion pkgs
242+
243+
244+
-- | Our backup doesn't produce any entries, and backup restore
245+
-- returns an empty state. Our responses are cheap enough to
246+
-- compute that we would rather regenerate them by need than
247+
-- deal with the complexity persisting backups in
248+
-- yet-another-format
249+
packageInfoStateComponent
250+
:: Bool
251+
-> FilePath
252+
-> IO (Framework.StateComponent Framework.AcidState PackageInfoState)
253+
packageInfoStateComponent freshDB stateDir = do
254+
st <- Framework.openLocalStateFrom
255+
(stateDir </> "db" </> "PackageInfoJSON")
256+
(initialPackageInfoState freshDB)
257+
return Framework.StateComponent {
258+
stateDesc = "Preferred package versions"
259+
, stateHandle = st
260+
, getState = Framework.query st GetPackageInfo
261+
, putState = Framework.update st . ReplacePackageInfo
262+
, resetState = packageInfoStateComponent True
263+
, backupState = \_ -> return []
264+
, restoreState = nullRestore (initialPackageInfoState True)
265+
}
266+
where
267+
268+
nullRestore :: PackageInfoState -> RestoreBackup PackageInfoState
269+
nullRestore st = RestoreBackup {
270+
restoreEntry = \_ -> nullRestore <$> pure (initialPackageInfoState True)
271+
, restoreFinalize = return st
272+
}

0 commit comments

Comments
 (0)