summaryrefslogtreecommitdiff
path: root/guix/scripts/pack.scm
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-03-23 23:16:55 +0100
committerMarius Bakke <mbakke@fastmail.com>2019-03-23 23:16:55 +0100
commit8c14f7f8a7ab0722bf4c9f92fd28ae85514d564f (patch)
treeadc5d29e9c2dcda5befa0ca81f1af8df23294947 /guix/scripts/pack.scm
parent2f33a7321e5e37d37f57c229c8079cb4ffd10834 (diff)
parent3374e9207f5244c20402a3c5513fe562140fef47 (diff)
Merge branch 'staging' into core-updates
Diffstat (limited to 'guix/scripts/pack.scm')
-rw-r--r--guix/scripts/pack.scm76
1 files changed, 61 insertions, 15 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fbef079910..d237ae6e94 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -28,6 +28,7 @@
#:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts)
+ #:autoload (guix inferior) (inferior-package?)
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix packages)
@@ -305,11 +306,13 @@ added to the pack."
(with-imported-modules (source-module-closure
'((guix build utils)
(guix build store-copy)
+ (guix build union)
(gnu build install))
#:select? not-config?)
#~(begin
(use-modules (guix build utils)
(guix build store-copy)
+ ((guix build union) #:select (relative-file-name))
(gnu build install)
(srfi srfi-1)
(srfi srfi-26)
@@ -358,18 +361,25 @@ added to the pack."
,@(append-map
(match-lambda
((source '-> target)
- (list "-p"
- (string-join
- ;; name s mode uid gid symlink
- (list source
- "s" "777" "0" "0"
- (string-append #$profile "/" target))))))
+ ;; Create relative symlinks to work around a bug in
+ ;; Singularity 2.x:
+ ;; https://bugs.gnu.org/34913
+ ;; https://github.com/sylabs/singularity/issues/1487
+ (let ((target (string-append #$profile "/" target)))
+ (list "-p"
+ (string-join
+ ;; name s mode uid gid symlink
+ (list source
+ "s" "777" "0" "0"
+ (relative-file-name (dirname source)
+ target)))))))
'#$symlinks)
;; Create empty mount points.
"-p" "/proc d 555 0 0"
"-p" "/sys d 555 0 0"
- "-p" "/dev d 555 0 0"))
+ "-p" "/dev d 555 0 0"
+ "-p" "/home d 555 0 0"))
(when database
;; Initialize /var/guix.
@@ -517,10 +527,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 +564,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)
@@ -573,7 +596,15 @@ please email '~a'~%")
(find-files #$(file-append package "/sbin"))
(find-files #$(file-append package "/libexec")))))))
- (computed-file (string-append (package-full-name package "-") "R")
+ (computed-file (string-append
+ (cond ((package? package)
+ (package-full-name package "-"))
+ ((inferior-package? package)
+ (string-append (inferior-package-name package)
+ "-"
+ (inferior-package-version package)))
+ (else "wrapper"))
+ "R")
build))
(define (map-manifest-entries proc manifest)
@@ -646,7 +677,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 +857,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)
@@ -851,7 +890,14 @@ Create a bundle of PACKAGE.\n"))
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
- #:relative-symlinks? relocatable?
+
+ ;; Always produce relative
+ ;; symlinks for Singularity (see
+ ;; <https://bugs.gnu.org/34913>).
+ #:relative-symlinks?
+ (or relocatable?
+ (eq? 'squashfs pack-format))
+
#:hooks (if bootstrap?
'()
%default-profile-hooks)