hackage-server-0.4: Distribution/Server/Features/Mirror.hs
{-# LANGUAGE DoRec, RankNTypes, ScopedTypeVariables,
NamedFieldPuns, RecordWildCards #-}
module Distribution.Server.Features.Mirror (
MirrorFeature(..),
MirrorResource(..),
initMirrorFeature
) where
import Distribution.Server.Framework hiding (formatTime)
import Distribution.Server.Features.Core
import Distribution.Server.Features.Users
import Distribution.Server.Users.State
import Distribution.Server.Packages.Types
import Distribution.Server.Users.Backup
import Distribution.Server.Users.Types
import Distribution.Server.Users.Users hiding (lookupUserName)
import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription)
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Packages.Unpack as Upload
import Distribution.Server.Framework.BackupDump
import Distribution.Server.Util.Parse (unpackUTF8)
import Distribution.PackageDescription.Parse (parsePackageDescription)
import Distribution.ParseUtils (ParseResult(..), locatedErrorMsg, showPWarning)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime, parseTime)
import System.Locale (defaultTimeLocale)
import qualified Distribution.Server.Util.GZip as GZip
import Distribution.Package
import Distribution.Text
data MirrorFeature = MirrorFeature {
mirrorFeatureInterface :: HackageFeature,
mirrorResource :: MirrorResource,
mirrorGroup :: UserGroup
}
instance IsHackageFeature MirrorFeature where
getFeatureInterface = mirrorFeatureInterface
data MirrorResource = MirrorResource {
mirrorPackageTarball :: Resource,
mirrorPackageUploadTime :: Resource,
mirrorPackageUploader :: Resource,
mirrorCabalFile :: Resource,
mirrorGroupResource :: GroupResource
}
-------------------------------------------------------------------------
initMirrorFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO MirrorFeature
initMirrorFeature env@ServerEnv{serverStateDir, serverVerbosity = verbosity}
core user@UserFeature{..} = do
loginfo verbosity "Initialising mirror feature, start"
-- Canonical state
mirrorersState <- mirrorersStateComponent serverStateDir
-- Tie the knot with a do-rec
rec let (feature, mirrorersGroupDesc)
= mirrorFeature env core user
mirrorersState mirrorersG mirrorR
(mirrorersG, mirrorR) <- groupResourceAt "/packages/mirrorers" mirrorersGroupDesc
loginfo verbosity "Initialising mirror feature, end"
return feature
mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients)
mirrorersStateComponent stateDir = do
st <- openLocalStateFrom (stateDir </> "db" </> "MirrorClients") initialMirrorClients
return StateComponent {
stateDesc = "Mirror clients"
, stateHandle = st
, getState = query st GetMirrorClients
, putState = update st . ReplaceMirrorClients . mirrorClients
, backupState = \(MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients]
, restoreState = MirrorClients <$> groupBackup ["clients.csv"]
, resetState = mirrorersStateComponent
}
mirrorFeature :: ServerEnv
-> CoreFeature
-> UserFeature
-> StateComponent AcidState MirrorClients
-> UserGroup
-> GroupResource
-> (MirrorFeature, UserGroup)
mirrorFeature ServerEnv{serverBlobStore = store}
CoreFeature{ coreResource = coreResource@CoreResource{
packageInPath
, packageTarballInPath
, lookupPackageId
}
, updateAddPackageRevision
, updateAddPackageTarball
, updateSetPackageUploadTime
, updateSetPackageUploader
}
UserFeature{..}
mirrorersState mirrorGroup mirrorGroupResource
= (MirrorFeature{..}, mirrorersGroupDesc)
where
mirrorFeatureInterface = (emptyHackageFeature "mirror") {
featureDesc = "Support direct (PUT) tarball uploads and overrides"
, featureResources =
map ($mirrorResource) [
mirrorPackageTarball
, mirrorPackageUploadTime
, mirrorPackageUploader
, mirrorCabalFile
] ++
[ groupResource mirrorGroupResource
, groupUserResource mirrorGroupResource
]
, featureState = [abstractAcidStateComponent mirrorersState]
}
mirrorResource = MirrorResource {
mirrorPackageTarball = (extendResource $ corePackageTarball coreResource) {
resourceDesc = [ (PUT, "Upload or replace a package tarball") ]
, resourcePut = [ ("", tarballPut) ]
}
, mirrorPackageUploadTime = (extendResourcePath "/upload-time" $ corePackagePage coreResource) {
resourceDesc = [ (GET, "Get a package upload time")
, (PUT, "Replace package upload time")
]
, resourceGet = [ ("", uploadTimeGet) ]
, resourcePut = [ ("", uploadTimePut) ]
}
, mirrorPackageUploader = (extendResourcePath "/uploader" $ corePackagePage coreResource) {
resourceDesc = [ (GET, "Get a package uploader (username)")
, (PUT, "Replace a package uploader")
]
, resourceGet = [ ("", uploaderGet) ]
, resourcePut = [ ("", uploaderPut) ]
}
, mirrorCabalFile = (extendResource $ coreCabalFile coreResource) {
resourceDesc = [ (PUT, "Replace a package description" ) ]
, resourcePut = [ ("", cabalPut) ]
}
, mirrorGroupResource
}
mirrorersGroupDesc = UserGroup {
groupDesc = nullDescription { groupTitle = "Mirror clients" },
queryUserList = queryState mirrorersState GetMirrorClientsList,
addUserList = updateState mirrorersState . AddMirrorClient,
removeUserList = updateState mirrorersState . RemoveMirrorClient,
canRemoveGroup = [adminGroup],
canAddGroup = [adminGroup]
}
-- result: error from unpacking, bad request error, or warning lines
--
-- curl -u admin:admin \
-- -X PUT \
-- -H "Content-Type: application/x-gzip" \
-- --data-binary @$1 \
-- http://localhost:8080/package/$PACKAGENAME/$PACKAGEID.tar.gz
tarballPut :: DynamicPath -> ServerPartE Response
tarballPut dpath = do
uid <- guardAuthorised [InGroup mirrorGroup]
pkgid <- packageTarballInPath dpath
fileContent <- expectCompressedTarball
time <- liftIO getCurrentTime
let uploadinfo = (time, uid)
res <- liftIO $ BlobStorage.addWith store fileContent $ \fileContent' ->
let filename = display pkgid <.> "tar.gz"
in case Upload.unpackPackageRaw filename fileContent' of
Left err -> return $ Left err
Right x ->
do let decompressedContent = GZip.decompressNamed filename fileContent'
blobIdDecompressed <- BlobStorage.add store decompressedContent
return $ Right (x, blobIdDecompressed)
case res of
Left err -> badRequest (toResponse err)
Right ((((pkg, _pkgStr), warnings), blobIdDecompressed), blobId) -> do
let tarball = PkgTarball { pkgTarballGz = blobId,
pkgTarballNoGz = blobIdDecompressed }
existed <- updateAddPackageTarball (packageId pkg) tarball uploadinfo
if existed
then return . toResponse $ unlines warnings
else errNotFound "Package not found" []
uploaderGet dpath = do
pkg <- packageInPath dpath >>= lookupPackageId
userdb <- queryGetUserDb
return $ toResponse $ display (userIdToName userdb (pkgUploadUser pkg))
uploaderPut :: DynamicPath -> ServerPartE Response
uploaderPut dpath = do
guardAuthorised_ [InGroup mirrorGroup]
pkgid <- packageInPath dpath
nameContent <- expectTextPlain
let uname = UserName (unpackUTF8 nameContent)
uid <- lookupUserName uname
existed <- updateSetPackageUploader pkgid uid
if existed
then return $ toResponse "Updated uploader OK"
else errNotFound "Package not found" []
uploadTimeGet :: DynamicPath -> ServerPartE Response
uploadTimeGet dpath = do
pkg <- packageInPath dpath >>= lookupPackageId
return $ toResponse $ formatTime defaultTimeLocale "%c" (pkgUploadTime pkg)
-- curl -H 'Content-Type: text/plain' -u admin:admin -X PUT -d "Tue Oct 18 20:54:28 UTC 2010" http://localhost:8080/package/edit-distance-0.2.1/upload-time
uploadTimePut :: DynamicPath -> ServerPartE Response
uploadTimePut dpath = do
guardAuthorised_ [InGroup mirrorGroup]
pkgid <- packageInPath dpath
timeContent <- expectTextPlain
case parseTime defaultTimeLocale "%c" (unpackUTF8 timeContent) of
Nothing -> errBadRequest "Could not parse upload time" []
Just t -> do
existed <- updateSetPackageUploadTime pkgid t
if existed
then return $ toResponse "Updated upload time OK"
else errNotFound "Package not found" []
-- return: error from parsing, bad request error, or warning lines
cabalPut :: DynamicPath -> ServerPartE Response
cabalPut dpath = do
uid <- guardAuthorised [InGroup mirrorGroup]
pkgid :: PackageId <- packageInPath dpath
fileContent <- expectTextPlain
time <- liftIO getCurrentTime
let uploadData = (time, uid)
case parsePackageDescription . unpackUTF8 $ fileContent of
ParseFailed err -> badRequest (toResponse $ show (locatedErrorMsg err))
ParseOk _ pkg | pkgid /= packageId pkg ->
errBadRequest "Wrong package Id"
[MText $ "Expected " ++ display pkgid
++ " but found " ++ display (packageId pkg)]
ParseOk warnings pkg -> do
updateAddPackageRevision (packageId pkg)
(CabalFileText fileContent) uploadData
let filename = display pkgid <.> "cabal"
return . toResponse $ unlines $ map (showPWarning filename) warnings