pack: Add relocation via ld.so and fakechroot.

[jackhill/guix/guix.git] / guix / scripts / pack.scm

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 11d0653..518bf6e 100644 (file)
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -684,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.
@@ -714,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)
@@ -733,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)