bug#41182: Profile hooks ignore system and target

["Ludovic Courtès" <ludo@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 984 bytes --]

Hi,

Ludovic Courtès <ludo@gnu.org> skribis:

> Actually all the profile hooks refer to the native derivation.

I’ve looked at it and this problem is surprisingly tricky to address.

I’ve tried to address it in an API-compatible way, which meant setting
the ‘%current-system’ and ‘%current-target-system’ parameters around the
hook calls, but that is ugly, hard to get right (dynamic binding and
monadic code really don’t go together well :-/), and actually raises
another issue (‘mapm/accumulate-builds’ appears to ignore the initial
dynamic bindings for these two parameters).  Hacky patch attached to
illustrate.

So I’m very much tempted to instead require each hook to take ‘system’
and ‘#:target’ arguments and pass them to ‘gexp->derivation’.  It’ll
break the API, in case someone out there has custom profile hooks
(unlikely given that it’s not really documented), but I’d say that’s OK.

Thoughts?

Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 3875 bytes --]

diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm
index 59ef5d078b..4f90e9e41d 100644
--- a/gnu/packages/commencement.scm
+++ b/gnu/packages/commencement.scm
@@ -3013,9 +3013,10 @@ memoized as a function of '%current-system'."
                                                '/memoized))))
          #'(begin
              (define memoized
-               (mlambda (system) exp))
+               (mlambda (system target) exp))
              (define-syntax identifier
-               (identifier-syntax (memoized (%current-system))))))))))
+               (identifier-syntax (memoized (%current-system)
+                                            (%current-target-system))))))))))
 
 (define/system-dependent linux-libre-headers-boot0
   ;; Note: this is wrapped in a thunk to nicely handle circular dependencies
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 25ff146bdf..58d7e0e450 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1580,6 +1580,18 @@ This is one of the things to do for the result to be relocatable.
 
 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
 are cross-built for TARGET."
+  (define (call-with-system+target system target thunk)
+    (mlet* %store-monad ((system0 (set-current-system system))
+                         (target0 (set-current-target (pk 'set-target target)))
+                         (result  (thunk)))
+      (mbegin %store-monad
+        (set-current-system system0)
+        (set-current-target target0)
+        (return result))))
+
+  (define-syntax-rule (with-system+target system target exp)
+    (call-with-system+target system target (lambda () exp)))
+
   (mlet* %store-monad ((system (if system
                                    (return system)
                                    (current-system)))
@@ -1592,9 +1604,12 @@ are cross-built for TARGET."
                                                          #:target target)))
                        (extras (if (null? (manifest-entries manifest))
                                    (return '())
-                                   (mapm/accumulate-builds (lambda (hook)
-                                                             (hook manifest))
-                                                           hooks))))
+                                   (with-system+target
+                                    system
+                                    target
+                                    (mapm/accumulate-builds (lambda (hook)
+                                                         (hook manifest))
+                                          hooks)))))
     (define inputs
       (append (filter-map (lambda (drv)
                             (and (derivation? drv)
@@ -1689,6 +1704,8 @@ are cross-built for TARGET."
   (match profile
     (($ <profile> name manifest hooks
                   locales? allow-collisions? relative-symlinks?)
+     (pk 'prof-c system target (%current-target-system))
+     ;; (display-backtrace (make-stack #t) (current-error-port) #f 80)
      (profile-derivation manifest
                          #:name name
                          #:hooks hooks
diff --git a/guix/store.scm b/guix/store.scm
index 6c7c07fd2d..92158bd658 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1899,7 +1899,10 @@ coalesce them into a single call."
     (values (map/accumulate-builds store
                                    (lambda (obj)
                                      (run-with-store store
-                                       (mproc obj)))
+                                       (mproc obj)
+                                       ;; #:system (%current-system)
+                                       ;; #:target (%current-target-system)
+                                       ))
                                    lst)
             store)))