Commit b3af0bab authored by Moritz Angermann's avatar Moritz Angermann

Adds `new-update`

new-update uses the new-style logic to update the repositories.  As such it
respects `repository` fields in the `cabal.project(.local)` file and updates
them as well.  This is essential when working with hackage overlays, where
the overlay repositories are specified as `repository` fields in the
`cabal.project(.local)` file.
parent 4e85e44b
{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-}
-- | cabal-install CLI command: update
--
module Distribution.Client.CmdUpdate (
updateCommand,
updateAction,
) where
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectConfig
( ProjectConfig(..)
, projectConfigWithSolverRepoContext )
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), maybeRepoRemote )
import Distribution.Client.HttpUtils
( DownloadResult(..) )
import Distribution.Client.FetchUtils
( downloadIndex )
import Distribution.Client.JobControl
( newParallelJobControl, spawnJob, collectJob )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags, UpdateFlags (updateIndexState)
, applyFlagDefaults, defaultUpdateFlags, RepoContext(..) )
import Distribution.Simple.Setup
( HaddockFlags, fromFlagOrDefault, fromFlag )
import Distribution.Simple.Utils
( die', notice, wrapText, writeFileAtomic, noticeNoWrap )
import Distribution.Verbosity
( Verbosity, normal, lessVerbose )
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.IndexUtils
( updateRepoIndexCache, Index(..), writeIndexTimestamp
, currentIndexTimestamp )
import Distribution.Text
( display )
import Data.Maybe (mapMaybe)
import Control.Monad (unless, when)
import qualified Data.ByteString.Lazy as BS
import Distribution.Client.GZipUtils (maybeDecompress)
import System.FilePath (dropExtension)
import Data.Time (getCurrentTime)
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import qualified Distribution.Client.Setup as Client
import qualified Hackage.Security.Client as Sec
updateCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
updateCommand = Client.installCommand {
commandName = "new-update",
commandSynopsis = "Updates list of known packages.",
commandUsage = usageAlternatives "new-update" [ "[FLAGS]" ],
commandDescription = Just $ \_ -> wrapText $
"For all known remote repositories, download the package list.",
commandNotes = Just $ \pname ->
"Examples:\n"
++ " " ++ pname ++ " new-update\n"
++ " Download the package list for all known remote repositories.\n\n"
++ "Note: this command is part of the new project-based system (aka "
++ "nix-style\nlocal builds). These features are currently in beta. "
++ "Please see\n"
++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html "
++ "for\ndetails and advice on what you can expect to work. If you "
++ "encounter problems\nplease file issues at "
++ "https://github.com/haskell/cabal/issues and if you\nhave any time "
++ "to get involved and help with testing, fixing bugs etc then\nthat "
++ "is very much appreciated.\n"
}
updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
updateAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags))
extraArgs globalFlags = do
unless (null extraArgs) $
die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
ProjectBaseContext {
projectConfig
} <- establishProjectBaseContext verbosity cliConfig
projectConfigWithSolverRepoContext verbosity (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)
$ \repoCtxt -> do
let repos = repoContextRepos repoCtxt
remoteRepos = mapMaybe maybeRepoRemote repos
case remoteRepos of
[] -> return ()
[remoteRepo] ->
notice verbosity $ "Downloading the latest package list from "
++ remoteRepoName remoteRepo
_ -> notice verbosity . unlines
$ "Downloading the latest package lists from: "
: map (("- " ++) . remoteRepoName) remoteRepos
jobCtrl <- newParallelJobControl (length repos)
mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) repos
mapM_ (\_ -> collectJob jobCtrl) repos
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()
updateRepo verbosity updateFlags repoCtxt repo = do
transport <- repoContextGetTransport repoCtxt
case repo of
RepoLocal{..} -> return ()
RepoRemote{..} -> do
downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir
case downloadResult of
FileAlreadyInCache -> return ()
FileDownloaded indexPath -> do
writeFileAtomic (dropExtension indexPath) . maybeDecompress
=<< BS.readFile indexPath
updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
let index = RepoIndex repoCtxt repo
-- NB: This may be a nullTimestamp if we've never updated before
current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
-- NB: always update the timestamp, even if we didn't actually
-- download anything
writeIndexTimestamp index (fromFlag (updateIndexState updateFlags))
ce <- if repoContextIgnoreExpiry repoCtxt
then Just `fmap` getCurrentTime
else return Nothing
updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce
-- Update cabal's internal index as well so that it's not out of sync
-- (If all access to the cache goes through hackage-security this can go)
case updated of
Sec.NoUpdates ->
return ()
Sec.HasUpdates ->
updateRepoIndexCache verbosity index
-- TODO: This will print multiple times if there are multiple
-- repositories: main problem is we don't have a way of updating
-- a specific repo. Once we implement that, update this.
when (current_ts /= nullTimestamp) $
noticeNoWrap verbosity $
"To revert to previous state run:\n" ++
" cabal update --index-state='" ++ display current_ts ++ "'\n"
......@@ -26,7 +26,7 @@ module Distribution.Client.Setup
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, defaultSolver, defaultMaxBackjumps
, listCommand, ListFlags(..)
, updateCommand, UpdateFlags(..)
, updateCommand, UpdateFlags(..), defaultUpdateFlags
, upgradeCommand
, uninstallCommand
, infoCommand, InfoFlags(..)
......
......@@ -154,6 +154,7 @@ library
Distribution.Client.CmdBench
Distribution.Client.CmdBuild
Distribution.Client.CmdConfigure
Distribution.Client.CmdUpdate
Distribution.Client.CmdErrorMessages
Distribution.Client.CmdExec
Distribution.Client.CmdFreeze
......@@ -415,6 +416,7 @@ executable cabal
Distribution.Client.CmdBench
Distribution.Client.CmdBuild
Distribution.Client.CmdConfigure
Distribution.Client.CmdUpdate
Distribution.Client.CmdErrorMessages
Distribution.Client.CmdExec
Distribution.Client.CmdFreeze
......
......@@ -75,7 +75,9 @@ import Distribution.Client.Targets
import qualified Distribution.Client.List as List
( list, info )
import qualified Distribution.Client.CmdConfigure as CmdConfigure
import qualified Distribution.Client.CmdUpdate as CmdUpdate
import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdRepl as CmdRepl
import qualified Distribution.Client.CmdFreeze as CmdFreeze
......@@ -311,6 +313,7 @@ mainWorker args = topHandler $
, hiddenCmd manpageCommand (manpageAction commandSpecs)
, regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction
, regularCmd CmdUpdate.updateCommand CmdUpdate.updateAction
, regularCmd CmdBuild.buildCommand CmdBuild.buildAction
, regularCmd CmdRepl.replCommand CmdRepl.replAction
, regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment