summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2023-10-28 15:29:01 +0200
committerLudovic Courtès <ludo@gnu.org>2023-11-05 23:23:23 +0100
commitab13e2be6939340a9dd8ba815e3518be41b19747 (patch)
treee216f6f38a9dfd48a388d952813854e0d9a1c34f /guix
parent9f05fbb67d0de4d577c21a6fb6888cb6be67cd12 (diff)
time-machine: Make target commit check cheaper.
Commit 79ec651a286c71a3d4c72be33a1f80e76a560031 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 79ec651a286c71a3d4c72be33a1f80e76a560031 (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
Diffstat (limited to 'guix')
-rw-r--r--guix/inferior.scm60
-rw-r--r--guix/scripts/time-machine.scm58
2 files changed, 59 insertions, 59 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm
index fca6fb4b22..190ba01b3c 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -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))
-
- ;; 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))))))))))
+ (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)))))))))
(define* (inferior-for-channels channels
#:key
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index f31fae7435..bd64364fa2 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -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.
@@ -146,6 +140,31 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
;;;
+;;; 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")))