bug#56441: Time travel doesn't resist profile format changes

[Ricardo Wurmus]

Attached is a patch that attempts to build the manifest in an inferior.
This fails because manifest->gexp returns a gexp that we can’t get out
of the inferior to pass to build-profile.

So even more of the surrounding code would have to be evaluated in the
inferior.

@Ludo: your patch looks good to me.  It’s a pragmatic, minimally
invasive fix, so thumbs up emoji from me!  Thank you!

-- 
Ricardo


>From da3eaeea0d0082138284720dce60f6bdfc796f2b Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Fri, 8 Jul 2022 08:40:27 +0200
Subject: [PATCH] channel stuff

---
 guix/channels.scm | 17 ++++++++--
 guix/profiles.scm | 81 +++++++++++++++++++++++++++++++++++------------
 2 files changed, 75 insertions(+), 23 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index ce1a60436f..45fba89685 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -896,6 +896,7 @@ (define (instance->entry instance drv)
 (define (package-cache-file manifest)
   "Build a package cache file for the instance in MANIFEST.  This is meant to
 be used as a profile hook."
+  (pk 'package-cache-file manifest)
   (let ((profile (profile (content manifest) (hooks '()))))
     (define build
       #~(begin
@@ -918,7 +919,12 @@ (define build
               (mkdir #$output))))
 
     (gexp->derivation-in-inferior "guix-package-cache" build
-                                  profile
+                                  (pk 'guixx (manifest-entry-item
+                                              (manifest-lookup
+                                               manifest
+                                               (manifest-pattern
+                                                 (name "guix")))))
+                                  ;profile
 
                                   ;; If the Guix in PROFILE is too old and
                                   ;; lacks 'guix repl', don't build the cache
@@ -936,8 +942,15 @@ (define %channel-profile-hooks
 (define (channel-instances->derivation instances)
   "Return the derivation of the profile containing INSTANCES, a list of
 channel instances."
-  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
+  (mlet* %store-monad ((manifest (channel-instances->manifest instances))
+                       (drv -> (manifest-entry-item
+                                (manifest-lookup
+                                 manifest
+                                 (manifest-pattern
+                                   (name "guix")))))
+                       (built (built-derivations (list drv))))
     (profile-derivation manifest
+                        #:inferior-guix (derivation->output-path drv)
                         #:hooks %channel-profile-hooks)))
 
 (define latest-channel-instances*
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 701852ae98..2d482cf91a 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -38,6 +38,10 @@ (define-module (guix profiles)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:autoload   (guix inferior) (gexp->derivation-in-inferior
+                                open-inferior
+                                close-inferior
+                                inferior-eval)
   #:use-module (guix search-paths)
   #:use-module (guix gexp)
   #:use-module (guix modules)
@@ -1946,6 +1950,7 @@ (define* (profile-derivation manifest
                              (allow-unsupported-packages? #f)
                              (allow-collisions? #f)
                              (relative-symlinks? #f)
+                             (inferior-guix #f)
                              system target)
   "Return a derivation that builds a profile (aka. 'user environment') with
 the given MANIFEST.  The profile includes additional derivations returned by
@@ -2013,6 +2018,33 @@ (define set-utf8-locale
                                   (package-version glibc-utf8-locales))))
           (setlocale LC_ALL "en_US.utf8")))
 
+    (define (manifest-gexp)
+      (pk 'man-gexp
+          (if inferior-guix
+              (let* ((inferior (open-inferior inferior-guix))
+                     (result
+                      ;; TODO: this doesn't work because we can't lift the
+                      ;; gexp out of the inferior.
+                      (inferior-eval `(begin
+                                        (use-modules (guix profiles)
+                                                     (guix derivations))
+                                        ((@@ (guix profiles) manifest->gexp)
+                                         (manifest
+                                          (list
+                                           ,@(map (lambda (entry)
+                                                    `(manifest-entry
+                                                       (name 
,(manifest-entry-name entry))
+                                                       (version 
,(manifest-entry-version entry))
+                                                       (output 
,(manifest-entry-output entry))
+                                                       (item 
(read-derivation-from-file
+                                                              
,(derivation-file-name
+                                                                
(manifest-entry-item entry))))))
+                                                  (manifest-entries 
manifest))))))
+                                     inferior)))
+                (close-inferior inferior)
+                result)
+              (manifest->gexp manifest))))
+
     (define builder
       (with-imported-modules '((guix build profiles)
                                (guix build union)
@@ -2031,32 +2063,39 @@ (define builder
 
             #+(if locales? set-utf8-locale #t)
 
-            (build-profile #$output '#$(manifest->gexp manifest)
+            (build-profile #$output '#$(manifest-gexp)
                            #:extra-inputs '#$extra-inputs
                            #:symlink #$(if relative-symlinks?
                                            #~symlink-relative
                                            #~symlink)))))
 
-    (gexp->derivation name builder
-                      #:system system
-                      #:target target
-
-                      ;; Don't complain about _IO* on Guile 2.2.
-                      #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
-
-                      ;; Not worth offloading.
-                      #:local-build? #t
-
-                      ;; Disable substitution because it would trigger a
-                      ;; connection to the substitute server, which is likely
-                      ;; to have no substitute to offer.
-                      #:substitutable? #f
-
-                      #:properties `((type . profile)
-                                     (profile
-                                      (count
-                                       . ,(length
-                                           (manifest-entries manifest))))))))
+    (let ((proc (if inferior-guix
+                    (lambda args
+                      (apply gexp->derivation-in-inferior
+                             name builder (pk 'inf inferior-guix)
+                             args))
+                    (lambda args
+                      (apply gexp->derivation
+                             name builder args)))))
+      (proc #:system system
+            #:target target
+
+            ;; Don't complain about _IO* on Guile 2.2.
+            #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
+
+            ;; Not worth offloading.
+            #:local-build? #t
+
+            ;; Disable substitution because it would trigger a
+            ;; connection to the substitute server, which is likely
+            ;; to have no substitute to offer.
+            #:substitutable? #f
+
+            #:properties `((type . profile)
+                           (profile
+                            (count
+                             . ,(length
+                                 (manifest-entries manifest)))))))))
 
 ;; Declarative profile.
 (define-record-type* <profile> profile make-profile
-- 
2.36.1