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)) + (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 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. @@ -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")))