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   , withProjectOrGlobalConfig
  52   )
  53 import Distribution.Client.ProjectFlags
  54   ( ProjectFlags (..)
  55   )
  56 import Distribution.Client.ProjectOrchestration
  57 import Distribution.Client.Setup
  58   ( ConfigFlags (..)
  59   , GlobalFlags
  60   , RepoContext (..)
  61   , UpdateFlags
  62   , defaultUpdateFlags
  63   )
  64 import Distribution.Client.Types
  65   ( RemoteRepo (..)
  66   , Repo (..)
  67   , RepoName (..)
  68   , repoName
  69   , unRepoName
  70   )
  71 import Distribution.Simple.Flag
  72   ( fromFlagOrDefault
  73   )
  74 import Distribution.Simple.Utils
  75   ( dieWithException
  76   , notice
  77   , noticeNoWrap
  78   , warn
  79   , wrapText
  80   , writeFileAtomic
  81   )
  82 import Distribution.Verbosity
  83   ( lessVerbose
  84   , normal
  85   )
  86
  87 import qualified Data.Maybe as Unsafe (fromJust)
  88 import qualified Distribution.Compat.CharParsing as P
  89 import qualified Text.PrettyPrint as Disp
  90
  91 import qualified Data.ByteString.Lazy as BS
  92 import Data.Time (getCurrentTime)
  93 import Distribution.Client.GZipUtils (maybeDecompress)
  94 import Distribution.Simple.Command
  95   ( CommandUI (..)
  96   , usageAlternatives
  97   )
  98 import System.FilePath (dropExtension, (<.>))
  99
 100 import Distribution.Client.Errors
 101 import Distribution.Client.IndexUtils.Timestamp (Timestamp (NoTimestamp))
 102 import qualified Hackage.Security.Client as Sec
 103
 104 updateCommand :: CommandUI (NixStyleFlags ())
 105 updateCommand =
 106   CommandUI
 107     { commandName = "v2-update"
 108     , commandSynopsis = "Updates list of known packages."
 109     , commandUsage = usageAlternatives "v2-update" ["[FLAGS] [REPOS]"]
 110     , commandDescription = Just $ \_ ->
 111         wrapText $
 112           "For all known remote repositories, download the package list."
 113     , commandNotes = Just $ \pname ->
 114         "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
 115           ++ "the same format and syntax that is supported by the --index-state flag.\n\n"
 116           ++ "Examples:\n"
 117           ++ "  "
 118           ++ pname
 119           ++ " v2-update\n"
 120           ++ "    Download the package list for all known remote repositories.\n\n"
 121           ++ "  "
 122           ++ pname
 123           ++ " v2-update hackage.haskell.org,@1474732068\n"
 124           ++ "  "
 125           ++ pname
 126           ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
 127           ++ "  "
 128           ++ pname
 129           ++ " v2-update hackage.haskell.org,HEAD\n"
 130           ++ "  "
 131           ++ pname
 132           ++ " v2-update hackage.haskell.org\n"
 133           ++ "    Download hackage.haskell.org at a specific index state.\n\n"
 134           ++ "  "
 135           ++ pname
 136           ++ " v2-update hackage.haskell.org head.hackage\n"
 137           ++ "    Download hackage.haskell.org and head.hackage\n"
 138           ++ "    head.hackage must be a known repo-id. E.g. from\n"
 139           ++ "    your cabal.project(.local) file.\n"
 140     , commandOptions = nixStyleOptions $ const []
 141     , commandDefaultFlags = defaultNixStyleFlags ()
 142     }
 143
 144 data UpdateRequest = UpdateRequest
 145   { _updateRequestRepoName :: RepoName
 146   , _updateRequestRepoState :: RepoIndexState
 147   }
 148   deriving (Show)
 149
 150 instance Pretty UpdateRequest where
 151   pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
 152
 153 instance Parsec UpdateRequest where
 154   parsec = do
 155     name <- parsec
 156     state <- P.char ',' *> parsec <|> pure IndexStateHead
 157     return (UpdateRequest name state)
 158
 159 updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 160 updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
 161   let ignoreProject = flagIgnoreProject projectFlags
 162
 163   projectConfig <-
 164     withProjectOrGlobalConfig
 165       verbosity
 166       ignoreProject
 167       globalConfigFlag
 168       (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
 169       (\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 (configVerbosity 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"