cabal-install/src/Distribution/Client/CmdUpdate.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TupleSections #-}
   7 {-# LANGUAGE ViewPatterns #-}
   8
   9 -- | cabal-install CLI command: update
  10 module Distribution.Client.CmdUpdate
  11   ( updateCommand
  12   , updateAction
  13   ) where
  14
  15 import Control.Exception
  16 import Distribution.Client.Compat.Prelude
  17 import Prelude ()
  18
  19 import Distribution.Client.Compat.Directory
  20   ( setModificationTime
  21   )
  22 import Distribution.Client.FetchUtils
  23   ( downloadIndex
  24   )
  25 import Distribution.Client.HttpUtils
  26   ( DownloadResult (..)
  27   )
  28 import Distribution.Client.IndexUtils
  29   ( Index (..)
  30   , currentIndexTimestamp
  31   , indexBaseName
  32   , updatePackageIndexCacheFile
  33   , updateRepoIndexCache
  34   , writeIndexTimestamp
  35   )
  36 import Distribution.Client.IndexUtils.IndexState
  37 import Distribution.Client.JobControl
  38   ( collectJob
  39   , newParallelJobControl
  40   , spawnJob
  41   )
  42 import Distribution.Client.NixStyleOptions
  43   ( NixStyleFlags (..)
  44   , defaultNixStyleFlags
  45   , nixStyleOptions
  46   )
  47 import Distribution.Client.ProjectConfig
  48   ( ProjectConfig (..)
  49   , ProjectConfigShared (projectConfigConfigFile)
  50   , projectConfigWithSolverRepoContext
  51   , withGlobalConfig
  52   , withProjectOrGlobalConfig
  53   )
  54 import Distribution.Client.ProjectFlags
  55   ( ProjectFlags (..)
  56   )
  57 import Distribution.Client.ProjectOrchestration
  58 import Distribution.Client.Setup
  59   ( CommonSetupFlags (..)
  60   , ConfigFlags (..)
  61   , GlobalFlags
  62   , RepoContext (..)
  63   , UpdateFlags
  64   , defaultUpdateFlags
  65   )
  66 import Distribution.Client.Types
  67   ( RemoteRepo (..)
  68   , Repo (..)
  69   , RepoName (..)
  70   , repoName
  71   , unRepoName
  72   )
  73 import Distribution.Simple.Flag
  74   ( fromFlagOrDefault
  75   )
  76 import Distribution.Simple.Utils
  77   ( dieWithException
  78   , notice
  79   , noticeNoWrap
  80   , warn
  81   , wrapText
  82   , writeFileAtomic
  83   )
  84 import Distribution.Verbosity
  85   ( lessVerbose
  86   , normal
  87   )
  88
  89 import qualified Data.Maybe as Unsafe (fromJust)
  90 import qualified Distribution.Compat.CharParsing as P
  91 import qualified Text.PrettyPrint as Disp
  92
  93 import qualified Data.ByteString.Lazy as BS
  94 import Data.Time (getCurrentTime)
  95 import Distribution.Client.GZipUtils (maybeDecompress)
  96 import Distribution.Simple.Command
  97   ( CommandUI (..)
  98   , usageAlternatives
  99   )
 100 import System.FilePath (dropExtension, (<.>))
 101
 102 import Distribution.Client.Errors
 103 import Distribution.Client.IndexUtils.Timestamp (Timestamp (NoTimestamp))
 104 import qualified Hackage.Security.Client as Sec
 105
 106 updateCommand :: CommandUI (NixStyleFlags ())
 107 updateCommand =
 108   CommandUI
 109     { commandName = "v2-update"
 110     , commandSynopsis = "Updates list of known packages."
 111     , commandUsage = usageAlternatives "v2-update" ["[FLAGS] [REPOS]"]
 112     , commandDescription = Just $ \_ ->
 113         wrapText $
 114           "For all known remote repositories, download the package list."
 115     , commandNotes = Just $ \pname ->
 116         "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
 117           ++ "the same format and syntax that is supported by the --index-state flag.\n\n"
 118           ++ "Examples:\n"
 119           ++ "  "
 120           ++ pname
 121           ++ " v2-update\n"
 122           ++ "    Download the package list for all known remote repositories.\n\n"
 123           ++ "  "
 124           ++ pname
 125           ++ " v2-update hackage.haskell.org,@1474732068\n"
 126           ++ "  "
 127           ++ pname
 128           ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
 129           ++ "  "
 130           ++ pname
 131           ++ " v2-update hackage.haskell.org,HEAD\n"
 132           ++ "  "
 133           ++ pname
 134           ++ " v2-update hackage.haskell.org\n"
 135           ++ "    Download hackage.haskell.org at a specific index state.\n\n"
 136           ++ "  "
 137           ++ pname
 138           ++ " v2-update hackage.haskell.org head.hackage\n"
 139           ++ "    Download hackage.haskell.org and head.hackage\n"
 140           ++ "    head.hackage must be a known repo-id. E.g. from\n"
 141           ++ "    your cabal.project(.local) file.\n"
 142     , commandOptions = nixStyleOptions $ const []
 143     , commandDefaultFlags = defaultNixStyleFlags ()
 144     }
 145
 146 data UpdateRequest = UpdateRequest
 147   { _updateRequestRepoName :: RepoName
 148   , _updateRequestRepoState :: RepoIndexState
 149   }
 150   deriving (Show)
 151
 152 instance Pretty UpdateRequest where
 153   pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
 154
 155 instance Parsec UpdateRequest where
 156   parsec = do
 157     name <- parsec
 158     state <- P.char ',' *> parsec <|> pure IndexStateHead
 159     return (UpdateRequest name state)
 160
 161 updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 162 updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
 163   let ignoreProject = flagIgnoreProject projectFlags
 164
 165   projectConfig <-
 166     withProjectOrGlobalConfig
 167       ignoreProject
 168       (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
 169       (withGlobalConfig verbosity globalConfigFlag $ \globalConfig -> return $ globalConfig <> cliConfig)
 170
 171   projectConfigWithSolverRepoContext
 172     verbosity
 173     (projectConfigShared projectConfig)
 174     (projectConfigBuildOnly projectConfig)
 175     $ \repoCtxt -> do
 176       let repos :: [Repo]
 177           repos = repoContextRepos repoCtxt
 178
 179           parseArg :: String -> IO UpdateRequest
 180           parseArg s = case simpleParsec s of
 181             Just r -> return r
 182             Nothing ->
 183               dieWithException verbosity $ UnableToParseRepo s
 184
 185       updateRepoRequests <- traverse parseArg extraArgs
 186
 187       unless (null updateRepoRequests) $ do
 188         let remoteRepoNames = map repoName repos
 189             unknownRepos =
 190               [ r | (UpdateRequest r _) <- updateRepoRequests, not (r `elem` remoteRepoNames)
 191               ]
 192         unless (null unknownRepos) $
 193           dieWithException verbosity $
 194             NullUnknownrepos (map unRepoName unknownRepos) (map unRepoName remoteRepoNames)
 195
 196       let reposToUpdate :: [(Repo, RepoIndexState)]
 197           reposToUpdate = case updateRepoRequests of
 198             -- If we are not given any specific repository, update all
 199             -- repositories to HEAD.
 200             [] -> map (,IndexStateHead) repos
 201             updateRequests ->
 202               let repoMap = [(repoName r, r) | r <- repos]
 203                   lookup' k = Unsafe.fromJust (lookup k repoMap)
 204                in [ (lookup' name, state)
 205                   | (UpdateRequest name state) <- updateRequests
 206                   ]
 207
 208       case reposToUpdate of
 209         [] ->
 210           notice verbosity "No remote repositories configured"
 211         [(remoteRepo, _)] ->
 212           notice verbosity $
 213             "Downloading the latest package list from "
 214               ++ unRepoName (repoName remoteRepo)
 215         _ ->
 216           notice verbosity . unlines $
 217             "Downloading the latest package lists from: "
 218               : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
 219
 220       unless (null reposToUpdate) $ do
 221         jobCtrl <- newParallelJobControl (length reposToUpdate)
 222         traverse_
 223           (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
 224           reposToUpdate
 225         traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
 226   where
 227     verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
 228     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here
 229     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 230
 231 updateRepo
 232   :: Verbosity
 233   -> UpdateFlags
 234   -> RepoContext
 235   -> (Repo, RepoIndexState)
 236   -> IO ()
 237 updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
 238   transport <- repoContextGetTransport repoCtxt
 239   case repo of
 240     RepoLocalNoIndex{} -> do
 241       let index = RepoIndex repoCtxt repo
 242       updatePackageIndexCacheFile verbosity index
 243     RepoRemote{..} -> do
 244       downloadResult <-
 245         downloadIndex
 246           transport
 247           verbosity
 248           repoRemote
 249           repoLocalDir
 250       case downloadResult of
 251         FileAlreadyInCache ->
 252           setModificationTime (indexBaseName repo <.> "tar")
 253             =<< getCurrentTime
 254         FileDownloaded indexPath -> do
 255           writeFileAtomic (dropExtension indexPath) . maybeDecompress
 256             =<< BS.readFile indexPath
 257           updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
 258     RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
 259       let index = RepoIndex repoCtxt repo
 260       -- NB: This may be a NoTimestamp if we've never updated before
 261       current_ts <- currentIndexTimestamp (lessVerbose verbosity) index
 262       -- NB: always update the timestamp, even if we didn't actually
 263       -- download anything
 264       writeIndexTimestamp index indexState
 265
 266       updated <- do
 267         ce <-
 268           if repoContextIgnoreExpiry repoCtxt
 269             then Just <$> getCurrentTime
 270             else return Nothing
 271         Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce
 272
 273       let rname = remoteRepoName (repoRemote repo)
 274
 275       -- Update cabal's internal index as well so that it's not out of sync
 276       -- (If all access to the cache goes through hackage-security this can go)
 277       case updated of
 278         Sec.NoUpdates -> do
 279           now <- getCurrentTime
 280           setModificationTime (indexBaseName repo <.> "tar") now
 281             `catchIO` \e ->
 282               warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e
 283           noticeNoWrap verbosity $
 284             "Package list of " ++ prettyShow rname ++ " is up to date."
 285         Sec.HasUpdates -> do
 286           updateRepoIndexCache verbosity index
 287           noticeNoWrap verbosity $
 288             "Package list of " ++ prettyShow rname ++ " has been updated."
 289
 290       -- This resolves indexState (which could be HEAD) into a timestamp
 291       -- This could be null but should not be, since the above guarantees
 292       -- we have an updated index.
 293       new_ts <- currentIndexTimestamp (lessVerbose verbosity) index
 294
 295       noticeNoWrap verbosity $
 296         "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "."
 297
 298       -- TODO: This will print multiple times if there are multiple
 299       -- repositories: main problem is we don't have a way of updating
 300       -- a specific repo.  Once we implement that, update this.
 301
 302       -- In case current_ts is a valid timestamp different from new_ts, let
 303       -- the user know how to go back to current_ts
 304       when (current_ts /= NoTimestamp && new_ts /= current_ts) $
 305         noticeNoWrap verbosity $
 306           "To revert to previous state run:\n"
 307             ++ "    cabal v2-update '"
 308             ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts))
 309             ++ "'\n"