GNU bug report logs - #77033
Deploy to machine with different architecture

Previous Next

Full log

View this message in rfc822 format

From: Sergey Trofimov <sarg <at> sarg.org.ru>
To: 77033 <at> debbugs.gnu.org
Cc: Sergey Trofimov <sarg <at> sarg.org.ru>, Christopher Baines <guix <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz>, Ludovic Courtès <ludo <at> gnu.org>, Mathieu Othacehe <othacehe <at> gnu.org>, Simon Tournier <zimon.toutoune <at> gmail.com>, Tobias Geerinckx-Rice <me <at> tobias.gr>
Subject: [bug#77033] [PATCH] deploy: Support --target and --system.
Date: Sat, 15 Mar 2025 12:59:59 +0100

* guix/scripts/deploy.scm: Support native and cross build options.
---
 guix/scripts/deploy.scm | 30 +++++++++++++++++++++---------
 1 file changed, 21 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index e2ef0006e0..94e0d69936 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -26,6 +26,7 @@ (define-module (guix scripts deploy)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (guix gexp)
   #:use-module (guix ui)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -54,6 +55,8 @@ (define (show-help)
   (display (G_ "Usage: guix deploy [OPTION] FILE...
 Perform the deployment specified by FILE.\n"))
   (show-build-options-help)
+  (show-cross-build-options-help)
+  (show-native-build-options-help)
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -93,21 +96,22 @@ (define %options
          (option '(#\x "execute") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'execute-command? #t result)))
-         (option '(#\s "system") #t #f
-                 (lambda (opt name arg result)
-                   (alist-cons 'system arg
-                               (alist-delete 'system result eq?))))
          (option '(#\v "verbosity") #t #f
                  (lambda (opt name arg result)
                    (let ((level (string->number* arg)))
                      (alist-cons 'verbosity level
                                  (alist-delete 'verbosity result)))))
 
-         %standard-build-options))
+         (append
+          %standard-build-options
+          %standard-native-build-options
+          %standard-cross-build-options)))
 
 (define %default-options
   ;; Alist of default option values.
   `((verbosity . 1)
+    (system . ,(%current-system))
+    (target . #f)
     (debug . 0)
     (graft? . #t)
     (substitutes? . #t)
@@ -186,9 +190,13 @@ (define (deploy-machine* store machine)
             (when (deploy-error-should-roll-back c)
               (info (G_ "rolling back ~a...~%")
                     (machine-display-name machine))
-              (run-with-store store (roll-back-machine machine)))
+              (run-with-store store (roll-back-machine machine)
+                              #:system (%current-system)
+                              #:target (%current-target-system)))
             (apply throw (deploy-error-captured-args c))))
-      (run-with-store store (deploy-machine machine))
+      (run-with-store store (deploy-machine machine)
+           #:system (%current-system)
+           #:target (%current-target-system))
 
     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
@@ -266,7 +274,9 @@ (define (invoke-command store machine command)
                (loop (cons line lines))))))))
 
   (match (run-with-store store
-           (machine-remote-eval machine invocation))
+           (machine-remote-eval machine invocation)
+           #:system (%current-system)
+           #:target (%current-target-system))
     ((code output)
      (match code
        ((? zero?)
@@ -325,7 +335,9 @@ (define-command (guix-deploy . args)
                                               #:verbosity
                                               (assoc-ref opts 'verbosity)
                                               #:dry-run? dry-run?)
-            (parameterize ((%graft? (assq-ref opts 'graft?)))
+            (parameterize ((%graft? (assq-ref opts 'graft?))
+                           (%current-target-system (assoc-ref opts 'target))
+                           (%current-system (assoc-ref opts 'system)))
               (if execute-command?
                   (match command
                     (("--" command ..1)

base-commit: 412f411d4f8780e6b60b448caae17f01c09be0eb
prerequisite-patch-id: f9cc903b8048c8c6fde576fbf38ab110263020e3
-- 
2.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.