2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 {-# LANGUAGE ViewPatterns #-}
9 -- | cabal-install CLI command: update
11 module Distribution
.Client
.CmdUpdate
(
17 import Control
.Exception
18 import Distribution
.Client
.Compat
.Prelude
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
27 , ProjectConfigShared
(projectConfigConfigFile
)
28 , projectConfigWithSolverRepoContext
29 , withProjectOrGlobalConfig
)
30 import Distribution
.Client
.ProjectFlags
32 import Distribution
.Client
.Types
33 ( Repo
(..), RepoName
(..), unRepoName
, RemoteRepo
(..), repoName
)
34 import Distribution
.Client
.HttpUtils
35 ( DownloadResult
(..) )
36 import Distribution
.Client
.FetchUtils
38 import Distribution
.Client
.JobControl
39 ( newParallelJobControl
, spawnJob
, collectJob
)
40 import Distribution
.Client
.Setup
41 ( GlobalFlags
, ConfigFlags
(..)
42 , UpdateFlags
, defaultUpdateFlags
44 import Distribution
.Simple
.Flag
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
)
55 import qualified Data
.Maybe as Unsafe
(fromJust)
56 import qualified Distribution
.Compat
.CharParsing
as P
57 import qualified Text
.PrettyPrint
as Disp
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
)
66 import qualified Hackage
.Security
.Client
as Sec
67 import Distribution
.Client
.IndexUtils
.Timestamp
(nullTimestamp
)
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."
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"
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"
93 , commandOptions
= nixStyleOptions
$ const []
94 , commandDefaultFlags
= defaultNixStyleFlags
()
97 data UpdateRequest
= UpdateRequest
98 { _updateRequestRepoName
:: RepoName
99 , _updateRequestRepoState
:: RepoIndexState
102 instance Pretty UpdateRequest
where
103 pretty
(UpdateRequest n s
) = pretty n
<<>> Disp
.comma
<<>> pretty s
105 instance Parsec UpdateRequest
where
108 state
<- P
.char
',' *> parsec
<|
> pure IndexStateHead
109 return (UpdateRequest name state
)
111 updateAction
:: NixStyleFlags
() -> [String] -> GlobalFlags
-> IO ()
112 updateAction flags
@NixStyleFlags
{..} extraArgs globalFlags
= do
113 let ignoreProject
= flagIgnoreProject projectFlags
115 projectConfig
<- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag
116 (projectConfig
<$> establishProjectBaseContext verbosity cliConfig OtherCommand
)
117 (\globalConfig
-> return $ globalConfig
<> cliConfig
)
119 projectConfigWithSolverRepoContext verbosity
120 (projectConfigShared projectConfig
) (projectConfigBuildOnly projectConfig
)
124 repos
= repoContextRepos repoCtxt
126 parseArg
:: String -> IO UpdateRequest
127 parseArg s
= case simpleParsec s
of
129 Nothing
-> die
' verbosity
$
130 "'v2-update' unable to parse repo: \"" ++ s
++ "\""
132 updateRepoRequests
<- traverse parseArg extraArgs
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
)
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
]
154 case reposToUpdate
of
156 notice verbosity
"No remote repositories configured"
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
164 unless (null reposToUpdate
) $ do
165 jobCtrl
<- newParallelJobControl
(length reposToUpdate
)
166 traverse_
(spawnJob jobCtrl
. updateRepo verbosity defaultUpdateFlags repoCtxt
)
168 traverse_
(\_
-> collectJob jobCtrl
) reposToUpdate
171 verbosity
= fromFlagOrDefault normal
(configVerbosity configFlags
)
172 cliConfig
= commandLineFlagsToProjectConfig globalFlags flags mempty
-- ClientInstallFlags, not needed here
173 globalConfigFlag
= projectConfigConfigFile
(projectConfigShared cliConfig
)
175 updateRepo
:: Verbosity
-> UpdateFlags
-> RepoContext
-> (Repo
, RepoIndexState
)
177 updateRepo verbosity _updateFlags repoCtxt
(repo
, indexState
) = do
178 transport
<- repoContextGetTransport repoCtxt
180 RepoLocalNoIndex
{} -> do
181 let index = RepoIndex repoCtxt repo
182 updatePackageIndexCacheFile verbosity
index
185 downloadResult
<- downloadIndex transport verbosity
186 repoRemote repoLocalDir
187 case downloadResult
of
188 FileAlreadyInCache
->
189 setModificationTime
(indexBaseName repo
<.> "tar")
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
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
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
)
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)
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."
223 updateRepoIndexCache verbosity
index
224 noticeNoWrap verbosity
$
225 "Package list of " ++ prettyShow rname
++ " has been updated."
227 noticeNoWrap verbosity
$
228 "The index-state is set to " ++ prettyShow
(IndexStateTime new_ts
) ++ "."
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.
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"