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
  68 updateCommand :: CommandUI (NixStyleFlags ())
  69 updateCommand = CommandUI
  70   { commandName         = "v2-update"
  71   , commandSynopsis     = "Updates list of known packages."
  72   , commandUsage        = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]
  73   , commandDescription  = Just $ \_ -> wrapText $
  74           "For all known remote repositories, download the package list."
  75
  76   , commandNotes        = Just $ \pname ->
  77         "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
  78      ++ "the same format and syntax that is supported by the --index-state flag.\n\n"
  79      ++ "Examples:\n"
  80      ++ "  " ++ pname ++ " v2-update\n"
  81      ++ "    Download the package list for all known remote repositories.\n\n"
  82      ++ "  " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n"
  83      ++ "  " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
  84      ++ "  " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n"
  85      ++ "  " ++ pname ++ " v2-update hackage.haskell.org\n"
  86      ++ "    Download hackage.haskell.org at a specific index state.\n\n"
  87      ++ "  " ++ pname ++ " new update hackage.haskell.org head.hackage\n"
  88      ++ "    Download hackage.haskell.org and head.hackage\n"
  89      ++ "    head.hackage must be a known repo-id. E.g. from\n"
  90      ++ "    your cabal.project(.local) file.\n"
  91
  92   , commandOptions      = nixStyleOptions $ const []
  93   , commandDefaultFlags = defaultNixStyleFlags ()
  94   }
  95
  96 data UpdateRequest = UpdateRequest
  97   { _updateRequestRepoName  :: RepoName
  98   , _updateRequestRepoState :: RepoIndexState
  99   } deriving (Show)
 100
 101 instance Pretty UpdateRequest where
 102     pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
 103
 104 instance Parsec UpdateRequest where
 105   parsec = do
 106       name <- parsec
 107       state <- P.char ',' *> parsec <|> pure IndexStateHead
 108       return (UpdateRequest name state)
 109
 110 updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 111 updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do
 112   let ignoreProject = flagIgnoreProject projectFlags
 113
 114   projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag
 115     (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
 116     (\globalConfig -> return $ globalConfig <> cliConfig)
 117
 118   projectConfigWithSolverRepoContext verbosity
 119     (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)
 120     $ \repoCtxt -> do
 121
 122     let repos :: [Repo]
 123         repos = repoContextRepos repoCtxt
 124
 125         parseArg :: String -> IO UpdateRequest
 126         parseArg s = case simpleParsec s of
 127           Just r -> return r
 128           Nothing -> die' verbosity $
 129                      "'v2-update' unable to parse repo: \"" ++ s ++ "\""
 130
 131     updateRepoRequests <- traverse parseArg extraArgs
 132
 133     unless (null updateRepoRequests) $ do
 134       let remoteRepoNames = map repoName repos
 135           unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests
 136                             , not (r `elem` remoteRepoNames)]
 137       unless (null unknownRepos) $
 138         die' verbosity $ "'v2-update' repo(s): \""
 139                          ++ intercalate "\", \"" (map unRepoName unknownRepos)
 140                          ++ "\" can not be found in known remote repo(s): "
 141                          ++ intercalate ", " (map unRepoName remoteRepoNames)
 142
 143     let reposToUpdate :: [(Repo, RepoIndexState)]
 144         reposToUpdate = case updateRepoRequests of
 145           -- If we are not given any specific repository, update all
 146           -- repositories to HEAD.
 147           [] -> map (,IndexStateHead) repos
 148           updateRequests -> let repoMap = [(repoName r, r) | r <- repos]
 149                                 lookup' k = Unsafe.fromJust (lookup k repoMap)
 150                             in [ (lookup' name, state)
 151                                | (UpdateRequest name state) <- updateRequests ]
 152
 153     case reposToUpdate of
 154       [] ->
 155         notice verbosity "No remote repositories configured"
 156       [(remoteRepo, _)] ->
 157         notice verbosity $ "Downloading the latest package list from "
 158                         ++ unRepoName (repoName remoteRepo)
 159       _ -> notice verbosity . unlines
 160               $ "Downloading the latest package lists from: "
 161               : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
 162
 163     unless (null reposToUpdate) $ do
 164       jobCtrl <- newParallelJobControl (length reposToUpdate)
 165       traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
 166         reposToUpdate
 167       traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
 168
 169   where
 170     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 171     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here
 172     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 173
 174 updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)
 175            -> IO ()
 176 updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
 177   transport <- repoContextGetTransport repoCtxt
 178   case repo of
 179     RepoLocalNoIndex{} -> do
 180       let index = RepoIndex repoCtxt repo
 181       updatePackageIndexCacheFile verbosity index
 182
 183     RepoRemote{..} -> do
 184       downloadResult <- downloadIndex transport verbosity
 185                         repoRemote repoLocalDir
 186       case downloadResult of
 187         FileAlreadyInCache ->
 188           setModificationTime (indexBaseName repo <.> "tar")
 189           =<< getCurrentTime
 190         FileDownloaded indexPath -> do
 191           writeFileAtomic (dropExtension indexPath) . maybeDecompress
 192                                                   =<< BS.readFile indexPath
 193           updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
 194     RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
 195       let index = RepoIndex repoCtxt repo
 196       -- NB: This may be a nullTimestamp if we've never updated before
 197       current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
 198       -- NB: always update the timestamp, even if we didn't actually
 199       -- download anything
 200       writeIndexTimestamp index indexState
 201       ce <- if repoContextIgnoreExpiry repoCtxt
 202               then Just `fmap` getCurrentTime
 203               else return Nothing
 204       updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce
 205       -- this resolves indexState (which could be HEAD) into a timestamp
 206       new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
 207       let rname = remoteRepoName (repoRemote repo)
 208
 209       -- Update cabal's internal index as well so that it's not out of sync
 210       -- (If all access to the cache goes through hackage-security this can go)
 211       case updated of
 212         Sec.NoUpdates  -> do
 213           now <- getCurrentTime
 214           setModificationTime (indexBaseName repo <.> "tar") now `catchIO`
 215              (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e)
 216           noticeNoWrap verbosity $
 217             "Package list of " ++ prettyShow rname ++ " is up to date."
 218
 219         Sec.HasUpdates -> do
 220           updateRepoIndexCache verbosity index
 221           noticeNoWrap verbosity $
 222             "Package list of " ++ prettyShow rname ++ " has been updated."
 223
 224       noticeNoWrap verbosity $
 225         "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "."
 226
 227       -- TODO: This will print multiple times if there are multiple
 228       -- repositories: main problem is we don't have a way of updating
 229       -- a specific repo.  Once we implement that, update this.
 230       when (new_ts /= current_ts) $
 231         noticeNoWrap verbosity $
 232           "To revert to previous state run:\n" ++
 233           "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"