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