summaryrefslogtreecommitdiff
path: root/guix/scripts/pack.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/pack.scm')
-rw-r--r--guix/scripts/pack.scm98
1 files changed, 88 insertions, 10 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index f3d1b41c6f..518bf6e7e3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -286,6 +286,7 @@ added to the pack."
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
(define (singularity-environment-file profile)
@@ -384,7 +385,7 @@ added to the pack."
;; Reset all UIDs and GIDs.
"-force-uid" "0" "-force-gid" "0")))
- (setenv "PATH" (string-append #$archiver "/bin"))
+ (setenv "PATH" #+(file-append archiver "/bin"))
;; We need an empty file in order to have a valid file argument when
;; we reparent the root file system. Read on for why that's
@@ -484,6 +485,7 @@ added to the pack."
(compressor-extension compressor)
".squashfs")
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
(define* (docker-image name profile
@@ -558,7 +560,7 @@ the image."
((_) str)
((names ... _) (loop names))))))) ;drop one entry
- (setenv "PATH" (string-append #$archiver "/bin"))
+ (setenv "PATH" #+(file-append archiver "/bin"))
(build-docker-image #$output
(map store-info-item
@@ -574,12 +576,13 @@ the image."
#~(list (string-append #$profile "/"
#$entry-point)))
#:extra-files directives
- #:compressor '#$(compressor-command compressor)
+ #:compressor '#+(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
build
+ #:target target
#:references-graphs `(("profile" ,profile))))
@@ -681,18 +684,50 @@ last resort for relocation."
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
+ (define audit-source
+ (local-file (search-auxiliary-file "pack-audit.c")))
+
(define (proot)
(specification->package "proot-static"))
+ (define (fakechroot-library)
+ (computed-file "libfakechroot.so"
+ #~(copy-file #$(file-append
+ (specification->package "fakechroot")
+ "/lib/fakechroot/libfakechroot.so")
+ #$output)))
+
+ (define (audit-module)
+ ;; Return an ld.so audit module for use by the 'fakechroot' execution
+ ;; engine that translates file names of all the files ld.so loads.
+ (computed-file "pack-audit.so"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (copy-file #$audit-source "audit.c")
+ (substitute* "audit.c"
+ (("@STORE_DIRECTORY@")
+ (%store-directory)))
+
+ (invoke #$compiler "-std=gnu99"
+ "-shared" "-fPIC" "-Os" "-g0"
+ "-Wall" "audit.c" "-o" #$output)))))
+
(define build
(with-imported-modules (source-module-closure
'((guix build utils)
- (guix build union)))
+ (guix build union)
+ (guix elf)))
#~(begin
(use-modules (guix build utils)
((guix build union) #:select (relative-file-name))
+ (guix elf)
+ (ice-9 binary-ports)
(ice-9 ftw)
- (ice-9 match))
+ (ice-9 match)
+ (srfi srfi-1)
+ (rnrs bytevectors))
(define input
;; The OUTPUT* output of PACKAGE.
@@ -711,6 +746,48 @@ last resort for relocation."
(#f base)
(index (string-drop base index)))))
+ (define (elf-interpreter elf)
+ ;; Return the interpreter of ELF as a string, or #f if ELF has no
+ ;; interpreter segment.
+ (match (find (lambda (segment)
+ (= (elf-segment-type segment) PT_INTERP))
+ (elf-segments elf))
+ (#f #f) ;maybe a .so
+ (segment
+ (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
+ (bytevector-copy! (elf-bytes elf)
+ (elf-segment-offset segment)
+ bv 0 (bytevector-length bv))
+ (utf8->string bv)))))
+
+ (define (elf-loader-compile-flags program)
+ ;; Return the cpp flags defining macros for the ld.so/fakechroot
+ ;; wrapper of PROGRAM.
+
+ ;; TODO: Handle scripts by wrapping their interpreter.
+ (if (elf-file? program)
+ (let* ((bv (call-with-input-file program
+ get-bytevector-all))
+ (elf (parse-elf bv))
+ (interp (elf-interpreter elf))
+ (gconv (and interp
+ (string-append (dirname interp)
+ "/gconv"))))
+ (if interp
+ (list (string-append "-DPROGRAM_INTERPRETER=\""
+ interp "\"")
+ (string-append "-DFAKECHROOT_LIBRARY=\""
+ #$(fakechroot-library) "\"")
+
+ (string-append "-DLOADER_AUDIT_MODULE=\""
+ #$(audit-module) "\"")
+ (if gconv
+ (string-append "-DGCONV_DIRECTORY=\""
+ gconv "\"")
+ "-UGCONV_DIRECTORY"))
+ '()))
+ '()))
+
(define (build-wrapper program)
;; Build a user-namespace wrapper for PROGRAM.
(format #t "building wrapper for '~a'...~%" program)
@@ -730,10 +807,11 @@ last resort for relocation."
(mkdir-p (dirname result))
(apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
"run.c" "-o" result
- (if proot
- (list (string-append "-DPROOT_PROGRAM=\""
- proot "\""))
- '()))
+ (append (if proot
+ (list (string-append "-DPROOT_PROGRAM=\""
+ proot "\""))
+ '())
+ (elf-loader-compile-flags program)))
(delete-file "run.c")))
(setvbuf (current-output-port) 'line)
@@ -1035,7 +1113,7 @@ Create a bundle of PACKAGE.\n"))
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.2))
+ (default-guile))
(assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?))))
(let* ((derivation? (assoc-ref opts 'derivation-only?))