TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

time-machine: Make target commit check cheaper. 

Commit 79ec651a28 introduced 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 in
79ec651a28 (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 2023-10-28 15:29:01 +02:00
parent 9f05fbb67d
commit ab13e2be69
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 58 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
guix/inferior.scm
View File

@ -872,14 +872,17 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
(authenticate? #t) (authenticate? #t)
(cache-directory (%inferior-cache-directory)) (cache-directory (%inferior-cache-directory))
(ttl (* 3600 24 30)) (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. "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 The directory is a subdirectory of CACHE-DIRECTORY, where entries can be
reclaimed after TTL seconds. This procedure opens a new connection to the reclaimed after TTL seconds. This procedure opens a new connection to the
build daemon. AUTHENTICATE? determines whether CHANNELS are authenticated. 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 VALIDATE-CHANNELS must be a four-argument procedure used to validate channel
exception in case of problems." 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 (define commits
;; Since computing the instances of CHANNELS is I/O-intensive, use a ;; Since computing the instances of CHANNELS is I/O-intensive, use a
;; cheaper way to get the commit list of CHANNELS. This limits overhead ;; 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) (if (file-exists? cached)
cached cached
(begin (run-with-store store
(when (procedure? validate-channels) (mlet* %store-monad ((instances
(validate-channels channels)) -> (latest-channel-instances store channels
(run-with-store store #:authenticate?
(mlet* %store-monad ((instances authenticate?
-> (latest-channel-instances store channels #:current-channels
#:authenticate? reference-channels
authenticate?)) #:validate-pull
(profile validate-channels))
(channel-instances->derivation instances))) (profile
(mbegin %store-monad (channel-instances->derivation instances)))
;; It's up to the caller to install a build handler to report (mbegin %store-monad
;; what's going to be built. ;; It's up to the caller to install a build handler to report
(built-derivations (list profile)) ;; what's going to be built.
(built-derivations (list profile))
;; Cache if and only if AUTHENTICATE? is true. ;; Cache if and only if AUTHENTICATE? is true.
(if authenticate? (if authenticate?
(mbegin %store-monad (mbegin %store-monad
(symlink* (derivation->output-path profile) cached) (symlink* (derivation->output-path profile) cached)
(add-indirect-root* cached) (add-indirect-root* cached)
(return cached)) (return cached))
(mbegin %store-monad (mbegin %store-monad
(add-temp-root* (derivation->output-path profile)) (add-temp-root* (derivation->output-path profile))
(return (derivation->output-path profile)))))))))) (return (derivation->output-path profile)))))))))
(define* (inferior-for-channels channels (define* (inferior-for-channels channels
#:key #:key

58
guix/scripts/time-machine.scm
View File

@ -46,12 +46,6 @@
#:use-module (srfi srfi-71) #:use-module (srfi srfi-71)
#:export (guix-time-machine)) #: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. ;;; Command-line options.
@ -144,6 +138,31 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
(("--") opts) (("--") opts)
(("--" command ...) (alist-cons 'exec command 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. ;;; Entry point.
@ -160,31 +179,6 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
(ref (assoc-ref opts 'ref)) (ref (assoc-ref opts 'ref))
(substitutes? (assoc-ref opts 'substitutes?)) (substitutes? (assoc-ref opts 'substitutes?))
(authenticate? (assoc-ref opts 'authenticate-channels?))) (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 (when command-line
(let* ((directory (let* ((directory
(with-store store (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) (set-build-options-from-command-line store opts)
(cached-channel-instance store channels (cached-channel-instance store channels
#:authenticate? authenticate? #:authenticate? authenticate?
#:reference-channels
%reference-channels
#:validate-channels #:validate-channels
validate-guix-channel))))) validate-guix-channel)))))
(executable (string-append directory "/bin/guix"))) (executable (string-append directory "/bin/guix")))