summaryrefslogtreecommitdiff
path: root/guix/scripts/pack.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludovic.courtes@inria.fr>2019-03-14 17:02:53 +0100
committerLudovic Courtès <ludo@gnu.org>2019-03-15 23:27:59 +0100
commit99aec37a78e7be6a591d0e5b7439896d669a75d1 (patch)
tree0187d4cf990037f7f2782f6b5dca650a8bb7eaaa /guix/scripts/pack.scm
parentc9b3a72b6792c8195b0cdd8e5d7809db29419c7d (diff)
pack: "-RR" produces PRoot-enabled relocatable binaries.
* gnu/packages/aux-files/run-in-namespace.c (exec_with_proot): New function. (main): When 'clone' fails, call 'rm_rf'. [PROOT_PROGRAM]: When 'clone' fails, call 'exec_with_proot'. * guix/scripts/pack.scm (wrapped-package): Add #:proot?. [proot]: New procedure. [build]: Compile with -DPROOT_PROGRAM when PROOT? is true. * guix/scripts/pack.scm (%options): Set the 'relocatable?' value to 'proot when "-R" is passed several times. (guix-pack): Pass #:proot? to 'wrapped-package'. * tests/guix-pack-relocatable.sh: Use "-RR" on Intel systems that lack user namespace support. * doc/guix.texi (Invoking guix pack): Document -RR.
Diffstat (limited to 'guix/scripts/pack.scm')
-rw-r--r--guix/scripts/pack.scm33
1 files changed, 27 insertions, 6 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e2ecddfbfc..bfb8b85356 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -517,10 +517,14 @@ please email '~a'~%")
;;;
(define* (wrapped-package package
- #:optional (compiler (c-compiler)))
+ #:optional (compiler (c-compiler))
+ #:key proot?)
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
+ (define (proot)
+ (specification->package "proot-static"))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
@@ -550,10 +554,19 @@ please email '~a'~%")
(("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program))
- (result (string-append #$output "/" base)))
+ (result (string-append #$output "/" base))
+ (proot #$(and proot?
+ #~(string-drop
+ #$(file-append (proot) "/bin/proot")
+ (+ (string-length (%store-directory))
+ 1)))))
(mkdir-p (dirname result))
- (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
- "run.c" "-o" result)
+ (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+ "run.c" "-o" result
+ (if proot
+ (list (string-append "-DPROOT_PROGRAM=\""
+ proot "\""))
+ '()))
(delete-file "run.c")))
(setvbuf (current-output-port) 'line)
@@ -646,7 +659,12 @@ please email '~a'~%")
(exit 0)))
(option '(#\R "relocatable") #f #f
(lambda (opt name arg result)
- (alist-cons 'relocatable? #t result)))
+ (match (assq-ref result 'relocatable?)
+ (#f
+ (alist-cons 'relocatable? #t result))
+ (_
+ (alist-cons 'relocatable? 'proot
+ (alist-delete 'relocatable? result))))))
(option '(#\e "expression") #t #f
(lambda (opt name arg result)
(alist-cons 'expression arg result)))
@@ -821,11 +839,14 @@ Create a bundle of PACKAGE.\n"))
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
(relocatable? (assoc-ref opts 'relocatable?))
+ (proot? (eq? relocatable? 'proot))
(manifest (let ((manifest (manifest-from-args store opts)))
;; Note: We cannot honor '--bootstrap' here because
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
- (map-manifest-entries wrapped-package manifest)
+ (map-manifest-entries
+ (cut wrapped-package <> #:proot? proot?)
+ manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format)