hackage-server-0.4: Distribution/Server/Features/Core.hs
{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec #-}
module Distribution.Server.Features.Core (
CoreFeature(..),
CoreResource(..),
initCoreFeature,
-- * Change events
PackageChange(..),
isPackageChangeAny,
isPackageAdd,
isPackageDelete,
isPackageIndexChange,
-- * Misc other utils
packageExists,
packageIdExists,
) where
import Distribution.Server.Framework
import Distribution.Server.Features.Core.State
import Distribution.Server.Features.Core.Backup
import Distribution.Server.Features.Users
import Distribution.Server.Packages.Types
import Distribution.Server.Users.Types (UserId)
import qualified Distribution.Server.Packages.Index as Packages.Index
import qualified Codec.Compression.GZip as GZip
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import Distribution.Server.Packages.PackageIndex (PackageIndex)
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import Data.Time.Clock (UTCTime)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.ByteString.Lazy (ByteString)
import Distribution.Text (display)
import Distribution.Package
import Distribution.Version (Version(..))
data CoreFeature = CoreFeature {
coreFeatureInterface :: HackageFeature,
coreResource :: CoreResource,
-- queries
queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo),
-- update transactions
updateAddPackage :: MonadIO m => PackageId ->
CabalFileText -> UploadInfo ->
Maybe PkgTarball -> m Bool,
updateDeletePackage :: MonadIO m => PackageId -> m Bool,
updateAddPackageRevision :: MonadIO m => PackageId ->
CabalFileText -> UploadInfo -> m (),
updateAddPackageTarball :: MonadIO m => PackageId ->
PkgTarball -> UploadInfo -> m Bool,
updateSetPackageUploader :: MonadIO m => PackageId -> UserId -> m Bool,
updateSetPackageUploadTime :: MonadIO m => PackageId -> UTCTime -> m Bool,
-- | Set an entry in the 00-index.tar file.
-- The 00-index.tar file contains all the package entries, but it is an
-- extensible format and we can add more stuff. E.g. version preferences
-- or crypto signatures.
updateArchiveIndexEntry :: MonadIO m => String -> (ByteString, UTCTime) -> m (),
-- | Notification of package or index changes
packageChangeHook :: Hook PackageChange (),
-- | Notification of downloads
packageDownloadHook :: Hook PackageId ()
}
instance IsHackageFeature CoreFeature where
getFeatureInterface = coreFeatureInterface
-- | This is designed so that you can pattern match on just the kinds of
-- events you are interested in.
data PackageChange = PackageChangeAdd PkgInfo
| PackageChangeDelete PkgInfo
| PackageChangeInfo PkgInfo PkgInfo
| PackageChangeIndexExtra String ByteString UTCTime
isPackageChangeAny :: PackageChange -> Maybe (PackageId, Maybe PkgInfo)
isPackageChangeAny (PackageChangeAdd pkginfo) = Just (packageId pkginfo, Just pkginfo)
isPackageChangeAny (PackageChangeDelete pkginfo) = Just (packageId pkginfo, Nothing)
isPackageChangeAny (PackageChangeInfo _ pkginfo) = Just (packageId pkginfo, Just pkginfo)
isPackageChangeAny PackageChangeIndexExtra {} = Nothing
isPackageAdd :: PackageChange -> Maybe PkgInfo
isPackageAdd (PackageChangeAdd pkginfo) = Just pkginfo
isPackageAdd _ = Nothing
isPackageDelete :: PackageChange -> Maybe PkgInfo
isPackageDelete (PackageChangeDelete pkginfo) = Just pkginfo
isPackageDelete _ = Nothing
isPackageIndexChange :: PackageChange -> Maybe ()
isPackageIndexChange _ = Just ()
{-
-- Other examples we may want later...
isPackageAddVersion :: Maybe PackageId,
isPackageDeleteVersion :: Maybe PackageId,
isPackageChangeCabalFile :: Maybe (PackageId, CabalFileText),
isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo),
isPackageChangeTarball :: Maybe (PackageId, PkgTarball),
isPackageIndexExtraChange :: Maybe (String, ByteString, UTCTime)
-}
data CoreResource = CoreResource {
corePackagesPage :: Resource,
corePackagePage :: Resource,
coreCabalFile :: Resource,
corePackageTarball :: Resource,
-- Render resources
indexPackageUri :: String -> String,
corePackageIdUri :: String -> PackageId -> String,
corePackageNameUri :: String -> PackageName -> String,
coreCabalUri :: PackageId -> String,
coreTarballUri :: PackageId -> String,
-- Find a PackageId or PackageName inside a path
packageInPath :: (MonadPlus m, FromReqURI a) => DynamicPath -> m a,
-- TODO: This is a rather ad-hoc function. Do we really need it?
packageTarballInPath :: MonadPlus m => DynamicPath -> m PackageId,
-- Check that a package exists (guard fails if version is empty)
guardValidPackageId :: PackageId -> ServerPartE (),
guardValidPackageName :: PackageName -> ServerPartE (),
-- Find a package in the package DB
lookupPackageName :: PackageName -> ServerPartE [PkgInfo],
lookupPackageId :: PackageId -> ServerPartE PkgInfo
}
initCoreFeature :: ServerEnv -> UserFeature -> IO CoreFeature
initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay,
serverVerbosity = verbosity} users = do
loginfo verbosity "Initialising core feature, start"
-- Canonical state
packagesState <- packagesStateComponent verbosity serverStateDir
-- Ephemeral state
-- Additional files to put in the index tarball like preferred-versions
extraMap <- newMemStateWHNF Map.empty
-- Hooks
packageChangeHook <- newHook
packageDownloadHook <- newHook
rec let (feature, getIndexTarball)
= coreFeature env users
packagesState extraMap indexTar
packageChangeHook packageDownloadHook
-- Caches
-- The index.tar.gz file
indexTar <- newAsyncCacheNF getIndexTarball
defaultAsyncCachePolicy {
asyncCacheName = "index tarball",
asyncCacheUpdateDelay = serverCacheDelay,
asyncCacheSyncInit = False,
asyncCacheLogVerbosity = verbosity
}
registerHookJust packageChangeHook isPackageIndexChange $ \_ ->
prodAsyncCache indexTar
loginfo verbosity "Initialising core feature, end"
return feature
packagesStateComponent :: Verbosity -> FilePath -> IO (StateComponent AcidState PackagesState)
packagesStateComponent verbosity stateDir = do
let stateFile = stateDir </> "db" </> "PackagesState"
st <- logTiming verbosity "Loaded PackagesState" $
openLocalStateFrom stateFile initialPackagesState
return StateComponent {
stateDesc = "Main package database"
, stateHandle = st
, getState = query st GetPackagesState
, putState = update st . ReplacePackagesState
, backupState = indexToAllVersions
, restoreState = packagesBackup
, resetState = packagesStateComponent verbosity
}
coreFeature :: ServerEnv
-> UserFeature
-> StateComponent AcidState PackagesState
-> MemState (Map String (ByteString, UTCTime))
-> AsyncCache ByteString
-> Hook PackageChange ()
-> Hook PackageId ()
-> ( CoreFeature
, IO ByteString )
coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
packagesState indexExtras cacheIndexTarball
packageChangeHook packageDownloadHook
= (CoreFeature{..}, getIndexTarball)
where
coreFeatureInterface = (emptyHackageFeature "core") {
featureDesc = "Core functionality"
, featureResources = [
coreIndexTarball
, corePackagesPage
, corePackagePage
, corePackageRedirect
, corePackageTarball
, coreCabalFile
]
, featureState = [abstractAcidStateComponent packagesState]
, featureCaches = [
CacheComponent {
cacheDesc = "main package index tarball",
getCacheMemSize = memSize <$> readAsyncCache cacheIndexTarball
}
, CacheComponent {
cacheDesc = "package index extra files",
getCacheMemSize = memSize <$> readMemState indexExtras
}
]
, featurePostInit = syncAsyncCache cacheIndexTarball
}
-- the rudimentary HTML resources are for when we don't want an additional HTML feature
coreResource = CoreResource {..}
coreIndexTarball = (resourceAt "/packages/index.tar.gz") {
resourceDesc = [(GET, "tarball of package descriptions")]
, resourceGet = [("tarball", servePackagesIndex)]
}
corePackagesPage = (resourceAt "/packages/.:format") {
resourceGet = [] -- have basic packages listing?
}
corePackagePage = resourceAt "/package/:package.:format"
corePackageRedirect = (resourceAt "/package/") {
resourceDesc = [(GET, "Redirect to /packages/")]
, resourceGet = [("", \_ -> seeOther "/packages/" $ toResponse ())]
}
corePackageTarball = (resourceAt "/package/:package/:tarball.tar.gz") {
resourceDesc = [(GET, "Get package tarball")]
, resourceGet = [("tarball", servePackageTarball)]
}
coreCabalFile = (resourceAt "/package/:package/:cabal.cabal") {
resourceDesc = [(GET, "Get package .cabal file")]
, resourceGet = [("cabal", serveCabalFile)]
}
indexPackageUri = \format ->
renderResource corePackagesPage [format]
corePackageIdUri = \format pkgid ->
renderResource corePackagePage [display pkgid, format]
corePackageNameUri = \format pkgname ->
renderResource corePackagePage [display pkgname, format]
coreCabalUri = \pkgid ->
renderResource coreCabalFile [display pkgid, display (packageName pkgid)]
coreTarballUri = \pkgid ->
renderResource corePackageTarball [display pkgid, display pkgid]
packageInPath dpath = maybe mzero return (lookup "package" dpath >>= fromReqURI)
packageTarballInPath dpath = do
PackageIdentifier name version <- packageInPath dpath
case lookup "tarball" dpath >>= fromReqURI of
Nothing -> mzero
Just pkgid@(PackageIdentifier name' version') -> do
-- rules:
-- * the package name and tarball name must be the same
-- * the tarball must specify a version
-- * the package must either have no version or the same version as the tarball
guard $ name == name' && version' /= Version [] [] && (version == version' || version == Version [] [])
return pkgid
guardValidPackageId pkgid = do
guard (pkgVersion pkgid /= Version [] [])
void $ lookupPackageId pkgid
guardValidPackageName pkgname =
void $ lookupPackageName pkgname
-- Queries
--
queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo)
queryGetPackageIndex = return . packageList =<< queryState packagesState GetPackagesState
-- Update transactions
--
updateAddPackage :: MonadIO m => PackageId
-> CabalFileText -> UploadInfo
-> Maybe PkgTarball -> m Bool
updateAddPackage pkgid cabalFile uploadinfo mtarball = do
mpkginfo <- updateState packagesState
(AddPackage pkgid cabalFile uploadinfo mtarball)
case mpkginfo of
Nothing -> return False
Just pkginfo -> do
runHook_ packageChangeHook (PackageChangeAdd pkginfo)
return True
updateDeletePackage :: MonadIO m => PackageId -> m Bool
updateDeletePackage pkgid = do
mpkginfo <- updateState packagesState (DeletePackage pkgid)
case mpkginfo of
Nothing -> return False
Just pkginfo -> do
runHook_ packageChangeHook (PackageChangeDelete pkginfo)
return True
updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m ()
updateAddPackageRevision pkgid cabalfile uploadinfo = do
(moldpkginfo, newpkginfo) <- updateState packagesState (AddPackageRevision pkgid cabalfile uploadinfo)
case moldpkginfo of
Nothing ->
runHook_ packageChangeHook (PackageChangeAdd newpkginfo)
Just oldpkginfo ->
runHook_ packageChangeHook (PackageChangeInfo oldpkginfo newpkginfo)
updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool
updateAddPackageTarball pkgid tarball uploadinfo = do
mpkginfo <- updateState packagesState (AddPackageTarball pkgid tarball uploadinfo)
case mpkginfo of
Nothing -> return False
Just (oldpkginfo, newpkginfo) -> do
runHook_ packageChangeHook (PackageChangeInfo oldpkginfo newpkginfo)
return True
updateSetPackageUploader pkgid userid = do
mpkginfo <- updateState packagesState (SetPackageUploader pkgid userid)
case mpkginfo of
Nothing -> return False
Just (oldpkginfo, newpkginfo) -> do
runHook_ packageChangeHook (PackageChangeInfo oldpkginfo newpkginfo)
return True
updateSetPackageUploadTime pkgid time = do
mpkginfo <- updateState packagesState (SetPackageUploadTime pkgid time)
case mpkginfo of
Nothing -> return False
Just (oldpkginfo, newpkginfo) -> do
runHook_ packageChangeHook (PackageChangeInfo oldpkginfo newpkginfo)
return True
updateArchiveIndexEntry :: MonadIO m => String -> (ByteString, UTCTime) -> m ()
updateArchiveIndexEntry entryName entryDetails@(entryData, entryTime) = do
modifyMemState indexExtras (Map.insert entryName entryDetails)
runHook_ packageChangeHook (PackageChangeIndexExtra entryName entryData entryTime)
-- Cache updates
--
getIndexTarball :: IO ByteString
getIndexTarball = do
users <- queryGetUserDb -- note, changes here don't automatically propagate
index <- queryGetPackageIndex
extras <- readMemState indexExtras
let indexTarball' = GZip.compress (Packages.Index.write users extras index)
return indexTarball'
------------------------------------------------------------------------------
packageError :: [MessageSpan] -> ServerPartE a
packageError = errNotFound "Package not found"
lookupPackageName :: PackageName -> ServerPartE [PkgInfo]
lookupPackageName pkgname = do
pkgsIndex <- queryGetPackageIndex
case PackageIndex.lookupPackageName pkgsIndex pkgname of
[] -> packageError [MText "No such package in package index"]
pkgs -> return pkgs
lookupPackageId :: PackageId -> ServerPartE PkgInfo
lookupPackageId (PackageIdentifier name (Version [] [])) = do
pkgs <- lookupPackageName name
-- pkgs is sorted by version number and non-empty
return (last pkgs)
lookupPackageId pkgid = do
pkgsIndex <- queryGetPackageIndex
case PackageIndex.lookupPackageId pkgsIndex pkgid of
Just pkg -> return pkg
_ -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)]
------------------------------------------------------------------------
servePackagesIndex :: DynamicPath -> ServerPartE Response
servePackagesIndex _ = do
indexTarball <- readAsyncCache cacheIndexTarball
return $ toResponse (Resource.IndexTarball indexTarball)
-- result: tarball or not-found error
servePackageTarball :: DynamicPath -> ServerPartE Response
servePackageTarball dpath = do
pkgid <- packageTarballInPath dpath
guard (pkgVersion pkgid /= Version [] [])
pkg <- lookupPackageId pkgid
case pkgTarball pkg of
[] -> errNotFound "Tarball not found" [MText "No tarball exists for this package version."]
((tb, _):_) -> do
let blobId = pkgTarballGz tb
file <- liftIO $ BlobStorage.fetch store blobId
runHook_ packageDownloadHook pkgid
return $ toResponse $ Resource.PackageTarball file blobId (pkgUploadTime pkg)
-- result: cabal file or not-found error
serveCabalFile :: DynamicPath -> ServerPartE Response
serveCabalFile dpath = do
pkg <- packageInPath dpath >>= lookupPackageId
-- check that the cabal name matches the package
case lookup "cabal" dpath == Just (display $ packageName pkg) of
True -> return $ toResponse (Resource.CabalFile (cabalFileByteString (pkgData pkg)))
False -> mzero
packageExists, packageIdExists :: (Package pkg, Package pkg') => PackageIndex pkg -> pkg' -> Bool
packageExists pkgs pkg = not . null $ PackageIndex.lookupPackageName pkgs (packageName pkg)
packageIdExists pkgs pkg = maybe False (const True) $ PackageIndex.lookupPackageId pkgs (packageId pkg)