diff --git a/hackage-server.cabal b/hackage-server.cabal
index eaf343fb6..b7370601e 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -313,6 +313,8 @@ library lib-server
Distribution.Server.Features.HoogleData
Distribution.Server.Features.HaskellPlatform
Distribution.Server.Features.HaskellPlatform.State
+ Distribution.Server.Features.PackageInfoJSON
+ Distribution.Server.Features.PackageInfoJSON.State
Distribution.Server.Features.Search
Distribution.Server.Features.Search.BM25F
Distribution.Server.Features.Search.DocIdSet
@@ -561,3 +563,4 @@ test-suite HashTests
-- component-specific dependencies
, tasty ^>= 1.4
, tasty-hunit ^>= 0.10
+
diff --git a/shell.nix b/shell.nix
index 8051010bf..64e7ed49b 100644
--- a/shell.nix
+++ b/shell.nix
@@ -17,5 +17,6 @@ pkgs.mkShell {
# Dependencies
pkgs.icu
pkgs.zlib
+ pkgs.brotli
];
}
diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index 669342b43..76d9c5145 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -29,6 +29,7 @@ import Distribution.Server.Features.Distro (initDistroFeature)
import Distribution.Server.Features.PackageContents (initPackageContentsFeature)
import Distribution.Server.Features.Documentation (initDocumentationFeature)
import Distribution.Server.Features.BuildReports (initBuildReportsFeature)
+import Distribution.Server.Features.PackageInfoJSON (initPackageInfoJSONFeature)
import Distribution.Server.Features.LegacyRedirects (legacyRedirectsFeature)
import Distribution.Server.Features.PreferredVersions (initVersionsFeature)
-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies (initReverseFeature)
@@ -151,6 +152,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
initSitemapFeature env
mkPackageFeedFeature <- logStartup "package feed" $
initPackageFeedFeature env
+ mkPackageJSONFeature <- logStartup "package info JSON" $
+ initPackageInfoJSONFeature env
#endif
loginfo verbosity "Initialising features, part 2"
@@ -324,6 +327,10 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
usersFeature
tarIndexCacheFeature
+ packageInfoJSONFeature <- mkPackageJSONFeature
+ coreFeature
+ versionsFeature
+
#endif
-- The order of initialization above should be the same as
@@ -364,6 +371,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
, getFeatureInterface adminLogFeature
, getFeatureInterface siteMapFeature
, getFeatureInterface packageFeedFeature
+ , getFeatureInterface packageInfoJSONFeature
#endif
, staticFilesFeature
, serverIntrospectFeature allFeatures
diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs
index 3a34fe6a8..d40241c03 100644
--- a/src/Distribution/Server/Features/Core.hs
+++ b/src/Distribution/Server/Features/Core.hs
@@ -220,6 +220,8 @@ data CoreResource = CoreResource {
coreCabalFile :: Resource,
-- | A tarball for a package version.
corePackageTarball :: Resource,
+ -- | A Cabal file metatada revision.
+ coreCabalFileRev :: Resource,
-- Rendering resources.
-- | URI for `corePackagesPage`, given a format (blank for none).
diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs
new file mode 100644
index 000000000..4e2b90831
--- /dev/null
+++ b/src/Distribution/Server/Features/PackageInfoJSON.hs
@@ -0,0 +1,272 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Distribution.Server.Features.PackageInfoJSON (
+ PackageInfoJSONFeature(..)
+ , PackageInfoJSONResource(..)
+ , initPackageInfoJSONFeature
+
+ , PackageBasicDescription(..)
+ , PackageVersions(..)
+ ) where
+
+import Prelude ()
+import Distribution.Server.Prelude
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy.Char8 as BS (toStrict)
+import qualified Data.Text as T
+import qualified Data.Vector as Vector
+
+import Distribution.License (licenseToSPDX)
+import Distribution.Package (PackageIdentifier(..),
+ PackageName, packageName,
+ packageVersion)
+import qualified Distribution.Parsec as Parsec
+import qualified Distribution.PackageDescription.Parsec as PkgDescr
+import qualified Distribution.Types.GenericPackageDescription as PkgDescr
+import qualified Distribution.Types.PackageDescription as PkgDescr
+import Distribution.Version (nullVersion)
+
+import Distribution.Server.Framework (())
+import qualified Distribution.Server.Framework as Framework
+import Distribution.Server.Features.Core (CoreFeature(..),
+ CoreResource(..),
+ isPackageChangeAny)
+import qualified Distribution.Server.Features.PreferredVersions as Preferred
+import Distribution.Server.Packages.Types (CabalFileText(..), pkgMetadataRevisions)
+import Distribution.Server.Framework.BackupRestore (RestoreBackup(..))
+
+import Distribution.Server.Features.PackageInfoJSON.State (PackageBasicDescription(..),
+ PackageVersions(..),
+ PackageInfoState(..),
+ GetPackageInfo(..),
+ ReplacePackageInfo(..),
+ GetDescriptionFor(..),
+ SetDescriptionFor(..),
+ GetVersionsFor(..),
+ SetVersionsFor(..),
+ initialPackageInfoState
+ )
+import Distribution.Utils.ShortText (fromShortText)
+import Data.Foldable (toList)
+import Data.Traversable (for)
+import qualified Data.List as List
+
+
+data PackageInfoJSONFeature = PackageInfoJSONFeature {
+ packageInfoJSONFeatureInterface :: Framework.HackageFeature
+}
+
+
+instance Framework.IsHackageFeature PackageInfoJSONFeature where
+ getFeatureInterface = packageInfoJSONFeatureInterface
+
+
+data PackageInfoJSONResource = PackageInfoJSONResource {
+ packageJSONResource :: Framework.Resource,
+ packageVersionJSONResource :: Framework.Resource
+}
+
+
+-- | Initializing our feature involves adding JSON variants to the
+-- endpoints that serve basic information about a package-version,
+-- and a packages version deprecation status.
+-- Aditionally we set up caching for these endpoints,
+-- and attach a package change hook that invalidates the cache
+-- line for a package when it changes
+initPackageInfoJSONFeature
+ :: Framework.ServerEnv
+ -> IO (CoreFeature -> Preferred.VersionsFeature -> IO PackageInfoJSONFeature)
+initPackageInfoJSONFeature env = do
+ packageInfoState <- packageInfoStateComponent False (Framework.serverStateDir env)
+ return $ \core preferred -> do
+
+ let coreR = coreResource core
+ info = "Get basic package information"
+ vInfo = "Get basic package information at a specific metadata revision"
+
+ jsonResources = [
+ (Framework.extendResource (corePackagePage coreR)) {
+ Framework.resourceDesc = [(Framework.GET, info)]
+ , Framework.resourceGet =
+ [("json", servePackageBasicDescription coreR
+ preferred packageInfoState)]
+ }
+ , (Framework.extendResource (coreCabalFileRev coreR)) {
+ Framework.resourceDesc = [(Framework.GET, vInfo)]
+ , Framework.resourceGet =
+ [("json", servePackageBasicDescription coreR
+ preferred packageInfoState)]
+ }
+ ]
+
+ -- When a package is modified in any way, delet all its
+ -- PackageInfoState cache lines.
+ -- They will be recalculated next time the endpoint
+ -- is hit
+ postInit = Framework.registerHookJust
+ (packageChangeHook core)
+ isPackageChangeAny $ \(pkgid, _) -> do
+
+ Framework.updateState packageInfoState $
+ SetDescriptionFor (pkgid, Nothing) Nothing
+ Framework.updateState packageInfoState $
+ SetVersionsFor (packageName pkgid) Nothing
+
+ return $ PackageInfoJSONFeature {
+ packageInfoJSONFeatureInterface =
+ (Framework.emptyHackageFeature "package-info-json")
+ { Framework.featureDesc = "Provide JSON endpoints for basic package descriptions"
+ , Framework.featureResources = jsonResources
+ , Framework.featureCaches = []
+ , Framework.featurePostInit = postInit
+ , Framework.featureState =
+ [Framework.abstractAcidStateComponent packageInfoState]
+ }
+ }
+
+
+-- | Pure function for extrcacting basic package info from a Cabal file
+getBasicDescription
+ :: CabalFileText
+ -> Int
+ -- ^ Metadata revision. This will be added to the resulting
+ -- @PackageBasicDescription@
+ -> Either String PackageBasicDescription
+getBasicDescription (CabalFileText cf) metadataRev =
+ let parseResult = PkgDescr.parseGenericPackageDescription (BS.toStrict cf)
+ in case PkgDescr.runParseResult parseResult of
+ (_, Right pkg) -> let
+ pkgd = PkgDescr.packageDescription pkg
+ pbd_author = T.pack . fromShortText $ PkgDescr.author pkgd
+ pbd_copyright = T.pack . fromShortText $ PkgDescr.copyright pkgd
+ pbd_synopsis = T.pack . fromShortText $ PkgDescr.synopsis pkgd
+ pbd_description = T.pack . fromShortText $ PkgDescr.description pkgd
+ pbd_license = either id licenseToSPDX $
+ PkgDescr.licenseRaw pkgd
+ pbd_homepage = T.pack . fromShortText $ PkgDescr.homepage pkgd
+ pbd_metadata_revision = metadataRev
+ in
+ return $ PackageBasicDescription {..}
+ (_, Left (_, perrs)) ->
+ let errs = List.intersperse '\n' $ mconcat $ for (toList perrs) $ \err -> Parsec.showPError "" err
+ in Left $ "Could not parse cabal file: "
+ <> errs
+
+
+-- | Get a JSON @PackageBasicDescription@ for a particular
+-- package/version/metadata-revision
+-- OR
+-- A listing of versions and their deprecation states
+servePackageBasicDescription
+ :: CoreResource
+ -> 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
+
+ let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI
+
+ pkgid@(PackageIdentifier name version) <- packageInPath resource dpath
+ guardValidPackageName resource name
+
+ if version /= nullVersion
+ then lookupOrInsertDescr pkgid metadataRev
+ else lookupOrInsertVersions name
+
+ where
+
+ lookupOrInsertDescr
+ :: PackageIdentifier
+ -> 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
+ Nothing -> do
+ d <- getPackageDescr pkgid metadataRev
+ Framework.updateState packageInfoState $
+ SetDescriptionFor (pkgid, metadataRev) (Just d)
+ return d
+ return $ Framework.toResponse $ Aeson.toJSON descr
+
+ getPackageDescr pkgid metadataRev = do
+ guardValidPackageId resource pkgid
+ pkg <- lookupPackageId resource pkgid
+
+ let metadataRevs = fst <$> pkgMetadataRevisions pkg
+ nMetadata = Vector.length metadataRevs
+ metadataInd = fromMaybe (nMetadata - 1) metadataRev
+
+ when (metadataInd < 0 || metadataInd >= nMetadata)
+ (Framework.errNotFound "Revision not found"
+ [Framework.MText
+ $ "There are " <> show nMetadata <> " metadata revisions. Index "
+ <> show metadataInd <> " is out of bounds."]
+ )
+
+ let cabalFile = metadataRevs Vector.! metadataInd
+ pkgDescr = getBasicDescription cabalFile metadataInd
+ case pkgDescr of
+ Left e -> Framework.errInternalError [Framework.MText e]
+ Right d -> return d
+
+ lookupOrInsertVersions
+ :: PackageName
+ -> Framework.ServerPartE Framework.Response
+ lookupOrInsertVersions pkgname = do
+ cachedVersions <- Framework.queryState packageInfoState $
+ GetVersionsFor pkgname
+ vers :: PackageVersions <- case cachedVersions of
+ Just vs -> return vs
+ Nothing -> do
+ vs <- getVersionListing pkgname
+ Framework.updateState packageInfoState $
+ SetVersionsFor pkgname (Just vs)
+ return vs
+ return $ Framework.toResponse $ Aeson.toJSON vers
+
+ getVersionListing name = do
+ pkgs <- lookupPackageName resource name
+ prefInfo <- Preferred.queryGetPreferredInfo preferred name
+ return
+ . PackageVersions
+ . Preferred.classifyVersions prefInfo
+ $ fmap packageVersion pkgs
+
+
+-- | Our backup doesn't produce any entries, and backup restore
+-- returns an empty state. Our responses are cheap enough to
+-- compute that we would rather regenerate them by need than
+-- deal with the complexity persisting backups in
+-- yet-another-format
+packageInfoStateComponent
+ :: Bool
+ -> FilePath
+ -> IO (Framework.StateComponent Framework.AcidState PackageInfoState)
+packageInfoStateComponent freshDB stateDir = do
+ st <- Framework.openLocalStateFrom
+ (stateDir "db" "PackageInfoJSON")
+ (initialPackageInfoState freshDB)
+ return Framework.StateComponent {
+ stateDesc = "Preferred package versions"
+ , stateHandle = st
+ , getState = Framework.query st GetPackageInfo
+ , putState = Framework.update st . ReplacePackageInfo
+ , resetState = packageInfoStateComponent True
+ , backupState = \_ -> return []
+ , restoreState = nullRestore (initialPackageInfoState True)
+ }
+ where
+
+ nullRestore :: PackageInfoState -> RestoreBackup PackageInfoState
+ nullRestore st = RestoreBackup {
+ restoreEntry = \_ -> nullRestore <$> pure (initialPackageInfoState True)
+ , restoreFinalize = return st
+ }
diff --git a/src/Distribution/Server/Features/PackageInfoJSON/State.hs b/src/Distribution/Server/Features/PackageInfoJSON/State.hs
new file mode 100644
index 000000000..6aac15d91
--- /dev/null
+++ b/src/Distribution/Server/Features/PackageInfoJSON/State.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Server.Features.PackageInfoJSON.State where
+
+import Control.Arrow (first, second)
+import Control.Applicative ((<|>))
+import Control.Monad.Reader (ask, asks)
+import qualified Control.Monad.State as State
+import qualified Data.Aeson as Aeson
+import Data.Aeson ((.=), (.:))
+import Data.Acid (Query, Update, makeAcidic)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Map.Strict as Map
+import Data.Monoid (Sum(..))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.SafeCopy (SafeCopy(..), base, contain,
+ deriveSafeCopy)
+import Data.Serialize (Get, get, getListOf, getTwoOf, put,
+ putListOf, putTwoOf)
+import Data.Typeable (Typeable)
+import Data.Word (Word8)
+import Distribution.License (licenseToSPDX)
+import Distribution.Text (display, simpleParse)
+import GHC.Generics (Generic)
+
+import Distribution.SPDX.License (License)
+import Distribution.Package (PackageIdentifier, PackageName)
+import Distribution.Version (Version, mkVersion, versionNumbers)
+import qualified Distribution.Pretty as Pretty
+import qualified Distribution.Parsec as Parsec
+
+import qualified Distribution.Server.Features.PreferredVersions as Preferred
+import Distribution.Server.Framework.MemSize (MemSize,
+ memSize,
+ memSize7)
+
+
+-- | Basic information about a package. These values are
+-- used in the `/package/:packagename` JSON endpoint
+data PackageBasicDescription = PackageBasicDescription
+ { pbd_license :: !License
+ , pbd_copyright :: !T.Text
+ , pbd_synopsis :: !T.Text
+ , pbd_description :: !T.Text
+ , pbd_author :: !T.Text
+ , pbd_homepage :: !T.Text
+ , pbd_metadata_revision :: !Int
+ } deriving (Eq, Show, Generic)
+
+instance SafeCopy PackageBasicDescription where
+
+ putCopy PackageBasicDescription{..} = contain $ do
+ put (Pretty.prettyShow pbd_license)
+ put $ T.encodeUtf8 pbd_copyright
+ put $ T.encodeUtf8 pbd_synopsis
+ put $ T.encodeUtf8 pbd_description
+ put $ T.encodeUtf8 pbd_author
+ put $ T.encodeUtf8 pbd_homepage
+ put pbd_metadata_revision
+
+ getCopy = contain $ do
+ licenseStr <- get
+ case Parsec.eitherParsec licenseStr of
+ Left e -> fail $ unwords ["Could not parse", licenseStr, "as license:" , e]
+ Right pbd_license -> do
+ pbd_copyright <- T.decodeUtf8 <$> get
+ pbd_synopsis <- T.decodeUtf8 <$> get
+ pbd_description <- T.decodeUtf8 <$> get
+ pbd_author <- T.decodeUtf8 <$> get
+ pbd_homepage <- T.decodeUtf8 <$> get
+ pbd_metadata_revision <- get
+ return PackageBasicDescription{..}
+
+
+-- | Aeson instances are used for building the package-description
+-- endpoint. Any changes will impact the API endpoint.
+instance Aeson.ToJSON PackageBasicDescription where
+ toJSON PackageBasicDescription {..} =
+ Aeson.object
+ [ T.pack "license" .= Pretty.prettyShow pbd_license
+ , T.pack "copyright" .= pbd_copyright
+ , T.pack "synopsis" .= pbd_synopsis
+ , T.pack "description" .= pbd_description
+ , T.pack "author" .= pbd_author
+ , T.pack "homepage" .= pbd_homepage
+ , T.pack "metadata_revision" .= pbd_metadata_revision
+ ]
+
+
+instance Aeson.FromJSON PackageBasicDescription where
+ parseJSON = Aeson.withObject "PackageBasicDescription" $ \obj -> do
+ pbd_version' <- obj .: T.pack "license"
+ let parseEitherLicense t =
+ Parsec.simpleParsec t <|> fmap licenseToSPDX (simpleParse t)
+ case parseEitherLicense pbd_version' of
+ Nothing -> fail $ concat ["Could not parse version: \"", pbd_version', "\""]
+ Just pbd_license -> do
+ pbd_copyright <- obj .: T.pack "copyright"
+ pbd_synopsis <- obj .: T.pack "synopsis"
+ pbd_description <- obj .: T.pack "description"
+ pbd_author <- obj .: T.pack "author"
+ pbd_homepage <- obj .: T.pack "homepage"
+ pbd_metadata_revision <- obj .: T.pack "metadata_revision"
+ return $
+ PackageBasicDescription {..}
+
+-- | An index of versions for one hackage package
+-- and their preferred/deprecated status
+newtype PackageVersions = PackageVersions {
+ unPackageVersions :: [(Version, Preferred.VersionStatus)]
+ } deriving (Eq, Show)
+
+instance SafeCopy PackageVersions where
+
+ putCopy (PackageVersions vs) =
+ contain
+ $ putListOf (putTwoOf put put)
+ $ first versionNumbers . second statusTag <$> vs
+ where
+ statusTag = \case
+ Preferred.NormalVersion -> 0 :: Word8
+ Preferred.DeprecatedVersion -> 1
+ Preferred.UnpreferredVersion -> 2
+
+ getCopy = contain $
+ fmap PackageVersions $ getListOf $ getTwoOf getVersion getStatus
+ where
+ getVersion = mkVersion <$> getListOf get
+ getStatus = (get :: Get Word8) >>= \case
+ 0 -> return Preferred.NormalVersion
+ 1 -> return Preferred.DeprecatedVersion
+ 2 -> return Preferred.UnpreferredVersion
+ n -> fail $ "Unsupported tag for VersionStatus: " ++ show n
+
+
+-- | This encoding of @PackageVersions@ is used in the
+-- `/package/$package` endpoint (when the URI doesn't specify)
+-- a version. Any change here is an API change.
+instance Aeson.ToJSON PackageVersions where
+ toJSON (PackageVersions p) =
+ Aeson.toJSON
+ $ Map.mapKeys display
+ $ fmap encodeStatus
+ $ Map.fromList p
+ where
+ encodeStatus = \case
+ Preferred.NormalVersion -> "normal"
+ Preferred.DeprecatedVersion -> "deprecated"
+ Preferred.UnpreferredVersion -> "unpreferred"
+
+
+instance Aeson.FromJSON PackageVersions where
+ parseJSON = Aeson.withObject "PackageVersions" $ \obj ->
+ fmap PackageVersions
+ $ traverse (parsePair)
+ $ HashMap.toList obj
+ where
+ parsePair (vStr, vStatus) =
+ (,) <$> parseVersion vStr <*> parseStatus vStatus
+
+ parseVersion verText =
+ let verString = T.unpack verText
+ in case simpleParse verString of
+ Just ver -> return ver
+ Nothing -> fail $ concat ["Could not parse \""
+ , verString ++ "\" as Version. "
+ , "expected \"a.b.c\" form"]
+
+ parseStatus (Aeson.String s) = case T.unpack s of
+ "normal" -> return Preferred.NormalVersion
+ "deprecated" -> return Preferred.DeprecatedVersion
+ "unpreferred" -> return Preferred.UnpreferredVersion
+ other -> fail $ concat ["Could not parse \"" ++ other
+ ++ "\" as status. Expected \"normal\""
+ ++ "\"deprecated\" or \"unpreferred\""]
+ parseStatus _ = fail "Expected a string"
+
+data PackageInfoState = PackageInfoState {
+ descriptions :: !(Map.Map (PackageIdentifier, Maybe Int) PackageBasicDescription)
+ , versions :: !(Map.Map PackageName PackageVersions)
+ , migratedEphemeralData :: Bool
+ } deriving (Show, Typeable, Eq)
+
+getDescriptionFor
+ :: (PackageIdentifier, Maybe Int)
+ -> Query PackageInfoState (Maybe PackageBasicDescription)
+getDescriptionFor pkgId = asks $ Map.lookup pkgId . descriptions
+
+getVersionsFor
+ :: PackageName
+ -> Query PackageInfoState (Maybe PackageVersions)
+getVersionsFor pkgName = asks $ Map.lookup pkgName . versions
+
+setDescriptionFor
+ :: (PackageIdentifier, Maybe Int)
+ -> Maybe PackageBasicDescription
+ -> Update PackageInfoState ()
+setDescriptionFor pkgId descr = State.modify $ \p ->
+ case descr of
+ Just d -> p {descriptions = Map.alter (const (Just d)) pkgId (descriptions p)}
+ Nothing -> p {descriptions = Map.filterWithKey (\pkgId' _ -> fst pkgId' /= fst pkgId) (descriptions p)}
+
+setVersionsFor
+ :: PackageName
+ -> Maybe PackageVersions
+ -> Update PackageInfoState ()
+setVersionsFor pkgName vs = State.modify $ \p ->
+ p { versions = Map.alter (const vs) pkgName (versions p) }
+
+getPackageInfo :: Query PackageInfoState PackageInfoState
+getPackageInfo = ask
+
+replacePackageInfo :: PackageInfoState -> Update PackageInfoState ()
+replacePackageInfo = State.put
+
+makeAcidic ''PackageInfoState ['getDescriptionFor
+ ,'getVersionsFor
+ ,'setDescriptionFor
+ ,'setVersionsFor
+ ,'getPackageInfo
+ ,'replacePackageInfo
+ ]
+
+deriveSafeCopy 0 'base ''PackageInfoState
+
+instance MemSize PackageBasicDescription where
+ memSize PackageBasicDescription{..} =
+ memSize7 (Pretty.prettyShow pbd_license) pbd_copyright pbd_synopsis
+ pbd_description pbd_author pbd_homepage pbd_metadata_revision
+
+instance MemSize PackageVersions where
+ memSize (PackageVersions ps) = getSum $
+ foldMap (\(v,_) -> Sum (memSize v) `mappend` Sum (memSize (0 :: Word))) ps
+
+instance MemSize PackageInfoState where
+ memSize (PackageInfoState {..}) = memSize descriptions + memSize versions
+
+
+initialPackageInfoState :: Bool -> PackageInfoState
+initialPackageInfoState freshDB = PackageInfoState
+ { descriptions = mempty
+ , versions = mempty
+ , migratedEphemeralData = freshDB
+ }
diff --git a/src/Distribution/Server/Framework/Resource.hs b/src/Distribution/Server/Framework/Resource.hs
index 3ffbb95ce..3067d8ac4 100644
--- a/src/Distribution/Server/Framework/Resource.hs
+++ b/src/Distribution/Server/Framework/Resource.hs
@@ -521,14 +521,11 @@ negotiateContent :: (FilterMonad Response m, ServerMonad m)
negotiateContent def available = do
when (length available > 1) $
setHeaderM "Vary" "Accept"
- maccept <- getHeaderM "Accept"
- case maccept of
- Nothing -> return def
- Just accept ->
- return $ fromMaybe def $ listToMaybe $ catMaybes
+ accept <- maybe "text/html" BS.unpack <$> getHeaderM "Accept"
+ return $ fromMaybe def $ listToMaybe $ catMaybes
[ simpleContentTypeMapping ct
>>= \f -> find (\x -> fst x == f) available
- | let acceptable = parseContentAccept (BS.unpack accept)
+ | let acceptable = parseContentAccept accept
, ct <- acceptable ]
where
-- This is rather a non-extensible hack
@@ -597,4 +594,3 @@ addServerNode trunk response tree = treeFold trunk (ServerTree (Just response) M
treeFold :: Monoid a => BranchPath -> ServerTree a -> ServerTree a -> ServerTree a
treeFold [] newChild topLevel = combine newChild topLevel
treeFold (sdir:otherTree) newChild topLevel = treeFold otherTree (ServerTree Nothing $ Map.singleton sdir newChild) topLevel
-
diff --git a/tests/HighLevelTest.hs b/tests/HighLevelTest.hs
index e21ca3ac8..2063b135f 100644
--- a/tests/HighLevelTest.hs
+++ b/tests/HighLevelTest.hs
@@ -213,14 +213,27 @@ runPackageTests = do
die "Bad index contents"
do info "Getting package index with etag"
validateETagHandling "/packages/index.tar.gz"
+
do info "Getting testpackage info"
- xs <- validate NoAuth "/package/testpackage"
+ xs <- validate NoAuth "/package/testpackage.html"
unless (">testpackage: test package testpackage" `isInfixOf` xs) $
- die ("Bad package info: " ++ show xs)
+ die ("Bad package info for unversioned HTML /package/testpackage.html endpoint: " ++ show xs)
+
do info "Getting testpackage-1.0.0.0 info"
xs <- validate NoAuth "/package/testpackage-1.0.0.0"
unless (">testpackage: test package testpackage" `isInfixOf` xs) $
- die ("Bad package info: " ++ show xs)
+ die ("Bad package info for versioned HTML /package/testpackage-1.0.0.0 endpoint: " ++ show xs)
+
+ do info "Getting testpackage-1.0.0.0 info (JSON)"
+ xs <- validate NoAuth "/package/testpackage-1.0.0.0.json"
+ unless ("\"synopsis\":\"test package testpackage\"" `isInfixOf` xs) $
+ die ("Bad package info for versioned JSON endpoint, expected the synopsis field to contain \"test package testpackage\": " ++ show xs)
+
+ do info "Getting testpackage version info (JSON)"
+ xs <- validate NoAuth "/package/testpackage.json"
+ unless ("\"1.0.0.0\":\"normal\"" `isInfixOf` xs) $
+ die ("Bad package version info: " ++ show xs)
+
do info "Getting testpackage Cabal file"
cabalFile <- getUrl NoAuth "/package/testpackage-1.0.0.0/testpackage.cabal"
unless (cabalFile == testpackageCabalFile) $