Skip to content

Commit

Permalink
Merge branch 'master' into central-server
Browse files Browse the repository at this point in the history
  • Loading branch information
@hvr
hvr committed Dec 31, 2017
2 parents 422dac0 + 46c3122 commit e465366
Show file tree
Hide file tree
Showing 12 changed files with 292 additions and 118 deletions.
99 changes: 58 additions & 41 deletions Distribution/Server/Features/Core.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,7 @@
{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, RecursiveDo #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
module Distribution.Server.Features.Core (
CoreFeature(..),
CoreResource(..),
Expand All @@ -18,38 +21,40 @@ module Distribution.Server.Features.Core (
) where

-- stdlib
import Data.Aeson (Value(..))
import Data.ByteString.Lazy (ByteString)
import Data.Maybe (isNothing)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Codec.Compression.GZip as GZip
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Data.Vector as Vec
import qualified Codec.Compression.GZip as GZip
import Data.Aeson (Value (..))
import Data.ByteString.Lazy (ByteString)
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Strict as HashMap
import Data.Either (isLeft)
import qualified Data.Text as Text
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import qualified Data.Vector as Vec

-- hackage
import Distribution.Server.Features.Core.Backup
import Distribution.Server.Features.Core.State
import Distribution.Server.Features.Security.Migration
import Distribution.Server.Features.Users
import Distribution.Server.Framework
import Distribution.Server.Packages.Index (TarIndexEntry(..))
import Distribution.Server.Packages.PackageIndex (PackageIndex)
import Distribution.Server.Packages.Types
import Distribution.Server.Users.Types (UserId, userName)
import Distribution.Server.Users.Users (userIdToName, lookupUserId)
import Distribution.Server.Features.Core.Backup
import Distribution.Server.Features.Core.State
import Distribution.Server.Features.Security.Migration
import Distribution.Server.Features.Users
import Distribution.Server.Framework
import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
import Distribution.Server.Packages.Index (TarIndexEntry (..))
import qualified Distribution.Server.Packages.Index as Packages.Index
import Distribution.Server.Packages.PackageIndex (PackageIndex)
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import Distribution.Server.Packages.Types
import Distribution.Server.Users.Types (UserId,
userName)
import Distribution.Server.Users.Users (lookupUserId,
userIdToName)

-- Cabal
import Distribution.Text (display)
import Distribution.Package
import Distribution.Version (nullVersion)
import Distribution.Package
import Distribution.Text (display)
import Distribution.Version (nullVersion)

-- | The core feature, responsible for the main package index and all access
-- and modifications of it.
Expand Down Expand Up @@ -278,7 +283,7 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay,
-- rather than BlobId; that is, we additionally record the length and
-- SHA256 hash for all blobs.
--
-- Additionally, we now need `targets.json` files for all versions of all
-- Additionally, we now need `package.json` files for all versions of all
-- packages. For new packages we add these when the package is uploaded,
-- but for previously uploaded packages we need to add them.
--
Expand All @@ -288,7 +293,7 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay,
-- we can use the check for the existence of the update log to see if we
-- need any other kind of migration.

migrateUpdateLog <- (isNothing . packageUpdateLog) <$>
migrateUpdateLog <- (isLeft . packageUpdateLog) <$>
queryState packagesState GetPackagesState
when migrateUpdateLog $ do
-- Migrate PackagesState (introduce package update log)
Expand Down Expand Up @@ -334,8 +339,16 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay,
}

registerHookJust packageChangeHook isPackageIndexChange $ \packageChange -> do
additionalEntries <- concat <$> runHook preIndexUpdateHook packageChange
forM_ additionalEntries $ updateState packagesState . AddOtherIndexEntry
-- NOTE: Adding a package adds the additional entries _atomically_ with a package
-- This makes sure we never get a successful upload with no attendant package.json file.
-- In all other cases, entries are allowed to be added nonatomically with the main index change.
-- We may wish to refactor in the future, but as of this comment, the preIndexUpdateHook is effectively a
-- no-op in all other significant cases.
case packageChange of
PackageChangeAdd _ -> return ()
_ -> do
additionalEntries <- concat <$> runHook preIndexUpdateHook packageChange
forM_ additionalEntries $ updateState packagesState . AddOtherIndexEntry
prodAsyncCache indexTar "package change"

return feature
Expand Down Expand Up @@ -487,19 +500,22 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
updateAddPackage pkgid cabalFile uploadinfo@(_, uid) mtarball = logTiming maxBound ("updateAddPackage " ++ display pkgid) $ do
usersdb <- queryGetUserDb
let Just userInfo = lookupUserId uid usersdb
mpkginfo <- updateState packagesState $
AddPackage2
pkgid
cabalFile

let pkginfo = mkPackageInfo pkgid cabalFile uploadinfo mtarball
additionalEntries <- concat `liftM` runHook preIndexUpdateHook (PackageChangeAdd pkginfo)

successFlag <- updateState packagesState $
AddPackage3
pkginfo
uploadinfo
(userName userInfo)
mtarball
loginfo maxBound ("updateState(AddPackage2," ++ display pkgid ++ ") -> " ++ maybe "Nothing" (const "Just _") mpkginfo)
case mpkginfo of
Nothing -> return False
Just pkginfo -> do
runHook_ packageChangeHook (PackageChangeAdd pkginfo)
return True
additionalEntries

loginfo maxBound ("updateState(AddPackage3," ++ display pkgid ++ ") -> " ++ show successFlag)
if successFlag
then runHook_ packageChangeHook (PackageChangeAdd pkginfo)
else return ()
return successFlag

updateDeletePackage :: MonadIO m => PackageId -> m Bool
updateDeletePackage pkgid = logTiming maxBound ("updateDeletePackage " ++ display pkgid) $ do
Expand Down Expand Up @@ -530,6 +546,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool
updateAddPackageTarball pkgid tarball uploadinfo = logTiming maxBound ("updateAddPackageTarball " ++ display pkgid) $ do
mpkginfo <- updateState packagesState (AddPackageTarball pkgid tarball uploadinfo)

case mpkginfo of
Nothing -> return False
Just (oldpkginfo, newpkginfo) -> do
Expand Down Expand Up @@ -564,7 +581,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
getIndexTarball = do
users <- queryGetUserDb -- note, changes here don't automatically propagate
time <- getCurrentTime
PackagesState index (Just updateSeq) <- queryState packagesState GetPackagesState
PackagesState index (Right updateSeq) <- queryState packagesState GetPackagesState
let updateLog = Foldable.toList updateSeq
legacyTarball = Packages.Index.writeLegacy
users
Expand Down
14 changes: 9 additions & 5 deletions Distribution/Server/Features/Core/Backup.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,8 @@ updatePackages accum@(PartialIndex packageMap updatelog) = RestoreBackup {
return (updatePackages accum')
, restoreFinalize = do
results <- mapM partialToFullPkg (Map.toList packageMap)
return $ PackagesState (PackageIndex.fromList results) updatelog
return $ PackagesState (PackageIndex.fromList results)
(maybe (Left mempty) Right updatelog)
}

data PartialIndex = PartialIndex !(Map PackageId PartialPkg)
Expand Down Expand Up @@ -295,7 +296,8 @@ forceLast = BS.fromChunks . forceLastBlock . BS.toChunks
indexToAllVersions :: PackagesState -> [BackupEntry]
indexToAllVersions st =
let pkgList = PackageIndex.allPackages . packageIndex $ st
in maybe id (\l x -> packageUpdateLogToExport l : x) (packageUpdateLog st) $
in maybe id (\l x -> packageUpdateLogToExport l : x)
(either (const Nothing) Just $ packageUpdateLog st) $
concatMap infoToAllEntries pkgList

---------- Converting PkgInfo to entries
Expand Down Expand Up @@ -392,11 +394,12 @@ packageUpdateLogToCSV updlog =
[showVersion versionCSVVer] : map entryToCSV (Foldable.toList updlog)
where
versionCSVVer = Version [0,1] []
entryToCSV (CabalFileEntry pkgid revno time username) =
entryToCSV (CabalFileEntry pkgid revno time uid username) =
[ "cabal"
, display pkgid
, show revno
, formatUTCTime time
, display uid
, display username
]
-- TODO: Currently ExtraEntry is used only for preferred-versions, so this
Expand All @@ -419,13 +422,14 @@ importTarIndexEntries :: CSV -> Restore (Seq TarIndexEntry)
importTarIndexEntries = fmap Seq.fromList . mapM fromRecord . drop 1
where
fromRecord :: Record -> Restore TarIndexEntry
fromRecord ["cabal", strPkgid, strRevno, strTime, username] = do
fromRecord ["cabal", strPkgid, strRevno, strTime, strUid, username] = do
pkgid <- parseText "pkgid" strPkgid
revno <- parseRead "revno" strRevno
utcTime <- parseUTCTime "time" strTime
uid <- parseText "uid" strUid
-- We don't use parseText for the username because this would throw
-- an error if the username is empty
return $ CabalFileEntry pkgid revno utcTime (UserName username)
return $ CabalFileEntry pkgid revno utcTime uid (UserName username)

fromRecord ["extra", extrapath, strTime, extracontent] = do
utcTime <- parseUTCTime "time" strTime
Expand Down
Loading

0 comments on commit e465366

Please sign in to comment.