time-machine: Make target commit check cheaper.
Commit79ec651a28introduced a check to error out when attempting to use ‘time-machine’ to travel to a commit before ‘v1.0.0’. This commit fixes a performance issue with the strategy used in79ec651a28(the repository was opened, updated, and traversed a second time by ‘validate-guix-channel’) as well as a user interface issue (“Updating channel” messages would be printed too late). This patch reimplements the check in terms of the existing #:validate-pull mechanism, which is designed to avoid extra repository operations. Fixes <https://issues.guix.gnu.org/65788>. * guix/inferior.scm (cached-channel-instance): Change default value of #:validate-channels. Remove call to VALIDATE-CHANNELS; pass it as #:validate-pull to ‘latest-channel-instances’. * guix/scripts/time-machine.scm (%reference-channels): New variable. (validate-guix-channel): New procedure, written as a simplification of… (guix-time-machine)[validate-guix-channel]: … this. Remove. Pass #:reference-channels to ‘cached-channel-instance’. Reported-by: Simon Tournier <zimon.toutoune@gmail.com> Change-Id: I9b0ec61fba7354fe08b04a91f4bd32b72a35460c
This commit is contained in:
Ludovic Courtès
parent
9f05fbb67d
commit
ab13e2be69
|
|
@ -872,14 +872,17 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
|
|||
(authenticate? #t)
|
||||
(cache-directory (%inferior-cache-directory))
|
||||
(ttl (* 3600 24 30))
|
||||
validate-channels)
|
||||
(reference-channels '())
|
||||
(validate-channels (const #t)))
|
||||
"Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
|
||||
The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
|
||||
reclaimed after TTL seconds. This procedure opens a new connection to the
|
||||
build daemon. AUTHENTICATE? determines whether CHANNELS are authenticated.
|
||||
VALIDATE-CHANNELS, if specified, must be a one argument procedure accepting a
|
||||
list of channels that can be used to validate the channels; it should raise an
|
||||
exception in case of problems."
|
||||
|
||||
VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
|
||||
instances against REFERENCE-CHANNELS; it is passed as #:validate-pull to
|
||||
'latest-channel-instances' and should raise an exception in case a target
|
||||
channel commit is deemed \"invalid\"."
|
||||
(define commits
|
||||
;; Since computing the instances of CHANNELS is I/O-intensive, use a
|
||||
;; cheaper way to get the commit list of CHANNELS. This limits overhead
|
||||
|
|
@ -927,30 +930,31 @@ exception in case of problems."
|
|||
|
||||
(if (file-exists? cached)
|
||||
cached
|
||||
(begin
|
||||
(when (procedure? validate-channels)
|
||||
(validate-channels channels))
|
||||
(run-with-store store
|
||||
(mlet* %store-monad ((instances
|
||||
-> (latest-channel-instances store channels
|
||||
#:authenticate?
|
||||
authenticate?))
|
||||
(profile
|
||||
(channel-instances->derivation instances)))
|
||||
(mbegin %store-monad
|
||||
;; It's up to the caller to install a build handler to report
|
||||
;; what's going to be built.
|
||||
(built-derivations (list profile))
|
||||
(run-with-store store
|
||||
(mlet* %store-monad ((instances
|
||||
-> (latest-channel-instances store channels
|
||||
#:authenticate?
|
||||
authenticate?
|
||||
#:current-channels
|
||||
reference-channels
|
||||
#:validate-pull
|
||||
validate-channels))
|
||||
(profile
|
||||
(channel-instances->derivation instances)))
|
||||
(mbegin %store-monad
|
||||
;; It's up to the caller to install a build handler to report
|
||||
;; what's going to be built.
|
||||
(built-derivations (list profile))
|
||||
|
||||
;; Cache if and only if AUTHENTICATE? is true.
|
||||
(if authenticate?
|
||||
(mbegin %store-monad
|
||||
(symlink* (derivation->output-path profile) cached)
|
||||
(add-indirect-root* cached)
|
||||
(return cached))
|
||||
(mbegin %store-monad
|
||||
(add-temp-root* (derivation->output-path profile))
|
||||
(return (derivation->output-path profile))))))))))
|
||||
;; Cache if and only if AUTHENTICATE? is true.
|
||||
(if authenticate?
|
||||
(mbegin %store-monad
|
||||
(symlink* (derivation->output-path profile) cached)
|
||||
(add-indirect-root* cached)
|
||||
(return cached))
|
||||
(mbegin %store-monad
|
||||
(add-temp-root* (derivation->output-path profile))
|
||||
(return (derivation->output-path profile)))))))))
|
||||
|
||||
(define* (inferior-for-channels channels
|
||||
#:key
|
||||
|
|
|
|||
|
|
@ -46,12 +46,6 @@
|
|||
#:use-module (srfi srfi-71)
|
||||
#:export (guix-time-machine))
|
||||
|
||||
;;; The required inferiors mechanism relied on by 'guix time-machine' was
|
||||
;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled
|
||||
;;; to.
|
||||
(define %oldest-possible-commit
|
||||
"6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0
|
||||
|
||||
|
||||
;;;
|
||||
;;; Command-line options.
|
||||
|
|
@ -144,6 +138,31 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
|
|||
(("--") opts)
|
||||
(("--" command ...) (alist-cons 'exec command opts))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Avoiding traveling too far back.
|
||||
;;;
|
||||
|
||||
;;; The required inferiors mechanism relied on by 'guix time-machine' was
|
||||
;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled
|
||||
;;; to.
|
||||
(define %oldest-possible-commit
|
||||
"6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0
|
||||
|
||||
(define %reference-channels
|
||||
(list (channel (inherit %default-guix-channel)
|
||||
(commit %oldest-possible-commit))))
|
||||
|
||||
(define (validate-guix-channel channel start commit relation)
|
||||
"Raise an error if CHANNEL is the 'guix' channel and the RELATION of COMMIT
|
||||
to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor."
|
||||
(unless (or (not (guix-channel? channel))
|
||||
(memq relation '(ancestor self)))
|
||||
(raise (formatted-message
|
||||
(G_ "cannot travel past commit `~a' from May 1st, 2019")
|
||||
(string-take %oldest-possible-commit 12)))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Entry point.
|
||||
|
|
@ -160,31 +179,6 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
|
|||
(ref (assoc-ref opts 'ref))
|
||||
(substitutes? (assoc-ref opts 'substitutes?))
|
||||
(authenticate? (assoc-ref opts 'authenticate-channels?)))
|
||||
|
||||
(define (validate-guix-channel channels)
|
||||
"Finds the Guix channel among CHANNELS, and validates that REF as
|
||||
captured from the closure, a git reference specification such as a commit hash
|
||||
or tag associated to the channel, is valid and new enough to satisfy the 'guix
|
||||
time-machine' requirements. If the captured REF variable is #f, the reference
|
||||
validate is the one of the Guix channel found in CHANNELS. A
|
||||
`formatted-message' condition is raised otherwise."
|
||||
(let* ((guix-channel (find guix-channel? channels))
|
||||
(guix-channel-commit (channel-commit guix-channel))
|
||||
(guix-channel-branch (channel-branch guix-channel))
|
||||
(guix-channel-ref (if guix-channel-commit
|
||||
`(tag-or-commit . ,guix-channel-commit)
|
||||
`(branch . ,guix-channel-branch)))
|
||||
(reference (or ref guix-channel-ref))
|
||||
(checkout commit relation (update-cached-checkout
|
||||
(channel-url guix-channel)
|
||||
#:ref reference
|
||||
#:starting-commit
|
||||
%oldest-possible-commit)))
|
||||
(unless (memq relation '(ancestor self))
|
||||
(raise (formatted-message
|
||||
(G_ "cannot travel past commit `~a' from May 1st, 2019")
|
||||
(string-take %oldest-possible-commit 12))))))
|
||||
|
||||
(when command-line
|
||||
(let* ((directory
|
||||
(with-store store
|
||||
|
|
@ -197,6 +191,8 @@ validate is the one of the Guix channel found in CHANNELS. A
|
|||
(set-build-options-from-command-line store opts)
|
||||
(cached-channel-instance store channels
|
||||
#:authenticate? authenticate?
|
||||
#:reference-channels
|
||||
%reference-channels
|
||||
#:validate-channels
|
||||
validate-guix-channel)))))
|
||||
(executable (string-append directory "/bin/guix")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue