|
| 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 it 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