[bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[Ludovic Courtès]

Hello!

As discussed before, this patch set is a first stab at getting rid of
PatchELF (which has portability issues) in particular in the Meson build
system.  (The patches are for the next ‘core-updates’.)

The second patch adds ‘strip-runpath’.  It doesn’t add ‘augment-rpath’
though, because that’s a bit more involved (it needs to grow the string
table and the section it’s in), and so I wanted to make sure we really
need it first.  :-)

In the discussion of ‘meson-build-system’ in
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=28444>, we didn’t discuss
this specific part.  Peter & Marius: can you explain whether/why this is
needed?

Thanks,
Ludo’.

Ludovic Courtès (3):
  gremlin: Preserve offset info for dynamic entries.
  gremlin: Add 'strip-runpath'.
  build-system/meson: Use 'strip-runpath' instead of PatchELF.

 guix/build/gremlin.scm            | 130 +++++++++++++++++++++---------
 guix/build/meson-build-system.scm |   2 +-
 tests/gremlin.scm                 |  35 +++++++-
 3 files changed, 129 insertions(+), 38 deletions(-)

-- 
2.17.0

[bug#31208] [PATCH 1/3] gremlin: Preserve offset info for dynamic entries.

[Ludovic Courtès]

* guix/build/gremlin.scm (<dynamic-entry>): New record type.
(raw-dynamic-entries): Return a list of <dynamic-entry>.
(dynamic-entries): Adjust accordingly and return a list of <dynamic-entry>.
(elf-dynamic-info)[matching-entry]: New procedure.
Use it.
---
 guix/build/gremlin.scm | 84 ++++++++++++++++++++++++------------------
 1 file changed, 49 insertions(+), 35 deletions(-)

diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index bb019967e..78d133311 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -99,10 +99,16 @@ dynamic linking information."
 ;;     } d_un;
 ;; } Elf64_Dyn;
 
+(define-record-type <dynamic-entry>
+  (dynamic-entry type value offset)
+  dynamic-entry?
+  (type   dynamic-entry-type)                     ;DT_*
+  (value  dynamic-entry-value)                    ;string | number | ...
+  (offset dynamic-entry-offset))                  ;integer
+
 (define (raw-dynamic-entries elf segment)
-  "Return as a list of type/value pairs all the dynamic entries found in
-SEGMENT, the 'PT_DYNAMIC' segment of ELF.  In the result, each car is a DT_
-value, and the interpretation of the cdr depends on the type."
+  "Return as a list of <dynamic-entry> for the dynamic entries found in
+SEGMENT, the 'PT_DYNAMIC' segment of ELF."
   (define start
     (elf-segment-offset segment))
   (define bytes
@@ -123,7 +129,9 @@ value, and the interpretation of the cdr depends on the type."
           (if (= type DT_NULL)                    ;finished?
               (reverse result)
               (loop (+ offset (* 2 word-size))
-                    (alist-cons type value result)))))))
+                    (cons (dynamic-entry type value
+                                         (+ start offset word-size))
+                          result)))))))
 
 (define (vma->offset elf vma)
   "Convert VMA, a virtual memory address, to an offset within ELF.
@@ -148,35 +156,33 @@ offset."
 
 (define (dynamic-entries elf segment)
   "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
-of ELF, as a list of type/value pairs.  The type is a DT_ value, and the value
-may be a string or an integer depending on the entry type (for instance, the
-value of DT_NEEDED entries is a string.)"
+of ELF, as a list of <dynamic-entry>.  The value of each entry may be a string
+or an integer depending on the entry type (for instance, the value of
+DT_NEEDED entries is a string.)  Likewise the offset is the offset within the
+string table if the type is a string."
   (define entries
     (raw-dynamic-entries elf segment))
 
   (define string-table-offset
-    (any (match-lambda
-            ((type . value)
-             (and (= type DT_STRTAB) value))
-            (_ #f))
+    (any (lambda (entry)
+           (and (= (dynamic-entry-type entry) DT_STRTAB)
+                (dynamic-entry-value entry)))
          entries))
 
-  (define (interpret-dynamic-entry type value)
-    (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
-           (if string-table-offset
-               (pointer->string
-                (bytevector->pointer (elf-bytes elf)
-                                     (vma->offset
-                                      elf
-                                      (+ string-table-offset value))))
-               value))
-          (else
-           value)))
+  (define (interpret-dynamic-entry entry)
+    (let ((type  (dynamic-entry-type entry))
+          (value (dynamic-entry-value entry)))
+      (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
+             (if string-table-offset
+                 (let* ((offset (vma->offset elf (+ string-table-offset value)))
+                        (value  (pointer->string
+                                 (bytevector->pointer (elf-bytes elf) offset))))
+                   (dynamic-entry type value offset))
+                 (dynamic-entry type value (dynamic-entry-offset entry))))
+            (else
+             (dynamic-entry type value (dynamic-entry-offset entry))))))
 
-  (map (match-lambda
-         ((type . value)
-          (cons type (interpret-dynamic-entry type value))))
-       entries))
+  (map interpret-dynamic-entry entries))
 
 \f
 ;;;
@@ -200,21 +206,29 @@ value of DT_NEEDED entries is a string.)"
 (define (elf-dynamic-info elf)
   "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
 #f if ELF lacks dynamic-link information."
+  (define (matching-entry type)
+    (lambda (entry)
+      (= type (dynamic-entry-type entry))))
+
   (match (dynamic-link-segment elf)
     (#f #f)
     ((? elf-segment? dynamic)
      (let ((entries (dynamic-entries elf dynamic)))
-       (%elf-dynamic-info (assv-ref entries DT_SONAME)
-                          (filter-map (match-lambda
-                                        ((type . value)
-                                         (and (= type DT_NEEDED) value))
-                                        (_ #f))
+       (%elf-dynamic-info (find (matching-entry DT_SONAME) entries)
+                          (filter-map (lambda (entry)
+                                        (and (= (dynamic-entry-type entry)
+                                                DT_NEEDED)
+                                             (dynamic-entry-value entry)))
                                       entries)
-                          (or (and=> (assv-ref entries DT_RPATH)
-                                     search-path->list)
+                          (or (and=> (find (matching-entry DT_RPATH)
+                                           entries)
+                                     (compose search-path->list
+                                              dynamic-entry-value))
                               '())
-                          (or (and=> (assv-ref entries DT_RUNPATH)
-                                     search-path->list)
+                          (or (and=> (find (matching-entry DT_RUNPATH)
+                                           entries)
+                                     (compose search-path->list
+                                              dynamic-entry-value))
                               '()))))))
 
 (define %libc-libraries
-- 
2.17.0

[bug#31208] [PATCH 2/3] gremlin: Add 'strip-runpath'.

[Ludovic Courtès]

* guix/build/gremlin.scm (strip-runpath): New procedure.
* tests/gremlin.scm (c-compiler): New variable.
("strip-runpath"): New test.
---
 guix/build/gremlin.scm | 46 +++++++++++++++++++++++++++++++++++++++++-
 tests/gremlin.scm      | 35 +++++++++++++++++++++++++++++++-
 2 files changed, 79 insertions(+), 2 deletions(-)

diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index 78d133311..e8ea66dfb 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -41,7 +41,8 @@
             elf-dynamic-info-runpath
             expand-origin
 
-            validate-needed-in-runpath))
+            validate-needed-in-runpath
+            strip-runpath))
 
 ;;; Commentary:
 ;;;
@@ -320,4 +321,47 @@ be found in RUNPATH ~s~%"
           ;;   (format (current-error-port) "~a is OK~%" file))
           (null? not-found))))))
 
+(define (strip-runpath file)
+  "Remove from the DT_RUNPATH of FILE any entries that are not necessary
+according to DT_NEEDED."
+  (define (minimal-runpath needed runpath)
+    (filter (lambda (directory)
+              (and (string-prefix? "/" directory)
+                   (any (lambda (lib)
+                          (file-exists? (string-append directory "/" lib)))
+                        needed)))
+            runpath))
+
+  (define port
+    (open-file file "r+b"))
+
+  (catch #t
+    (lambda ()
+      (let* ((elf      (parse-elf (get-bytevector-all port)))
+             (entries  (dynamic-entries elf (dynamic-link-segment elf)))
+             (needed   (filter-map (lambda (entry)
+                                     (and (= (dynamic-entry-type entry)
+                                             DT_NEEDED)
+                                          (dynamic-entry-value entry)))
+                                   entries))
+             (runpath  (find (lambda (entry)
+                               (= DT_RUNPATH (dynamic-entry-type entry)))
+                             entries))
+             (old      (search-path->list
+                        (dynamic-entry-value runpath)))
+             (new      (minimal-runpath needed old)))
+        (unless (equal? old new)
+          (format (current-error-port)
+                  "~a: stripping RUNPATH to ~s (removed ~s)~%"
+                  file new
+                  (lset-difference string=? old new))
+          (seek port (dynamic-entry-offset runpath) SEEK_SET)
+          (put-bytevector port (string->utf8 (string-join new ":")))
+          (put-u8 port 0))
+        (close-port port)
+        new))
+    (lambda (key . args)
+      (false-if-exception (close-port port))
+      (apply throw key args))))
+
 ;;; gremlin.scm ends here
diff --git a/tests/gremlin.scm b/tests/gremlin.scm
index 288555496..1b47d5c38 100644
--- a/tests/gremlin.scm
+++ b/tests/gremlin.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,12 +18,14 @@
 
 (define-module (test-gremlin)
   #:use-module (guix elf)
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (guix build utils)
   #:use-module (guix build gremlin)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
+  #:use-module (ice-9 popen)
   #:use-module (ice-9 match))
 
 (define %guile-executable
@@ -37,6 +39,9 @@
 (define read-elf
   (compose parse-elf get-bytevector-all))
 
+(define c-compiler
+  (or (which "gcc") (which "cc") (which "g++")))
+
 \f
 (test-begin "gremlin")
 
@@ -63,4 +68,32 @@
          "../${ORIGIN}/bar/$ORIGIN/baz"
          "ORIGIN/foo")))
 
+(unless c-compiler
+  (test-skip 1))
+(test-equal "strip-runpath"
+  "hello\n"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (with-directory-excursion directory
+       (call-with-output-file "t.c"
+         (lambda (port)
+           (display "int main () { puts(\"hello\"); }" port)))
+       (invoke c-compiler "t.c"
+               "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
+       (let* ((dyninfo (elf-dynamic-info
+                        (parse-elf (call-with-input-file "a.out"
+                                     get-bytevector-all))))
+              (old     (elf-dynamic-info-runpath dyninfo))
+              (new     (strip-runpath "a.out"))
+              (new*    (strip-runpath "a.out")))
+         (validate-needed-in-runpath "a.out")
+         (and (member "/foo" old) (member "/bar" old)
+              (not (member "/foo" new))
+              (not (member "/bar" new))
+              (equal? new* new)
+              (let* ((pipe (open-input-pipe "./a.out"))
+                     (str  (get-string-all pipe)))
+                (close-pipe pipe)
+                str)))))))
+
 (test-end "gremlin")
-- 
2.17.0

[bug#31208] [PATCH 3/3] build-system/meson: Use 'strip-runpath' instead of PatchELF.

[Ludovic Courtès]

* guix/build/meson-build-system.scm (fix-runpath): Call 'strip-runpath'
instead of invoking 'patchelf'.
---
 guix/build/meson-build-system.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index e8cb5440e..793cc32e7 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -134,7 +134,7 @@ for example libraries only needed for the tests."
                                             (find-files dir elf-pred))
                                           existing-elf-dirs))))
          (for-each (lambda (elf-file)
-                     (system* "patchelf" "--shrink-rpath" elf-file)
+                     (strip-runpath elf-file)
                      (handle-file elf-file elf-list))
                    elf-list)))))
   (for-each handle-output outputs)
-- 
2.17.0

[bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[Ludovic Courtès]

Ping!  :-)

Ludovic Courtès <ludo@gnu.org> skribis:

> Hello!
>
> As discussed before, this patch set is a first stab at getting rid of
> PatchELF (which has portability issues) in particular in the Meson build
> system.  (The patches are for the next ‘core-updates’.)
>
> The second patch adds ‘strip-runpath’.  It doesn’t add ‘augment-rpath’
> though, because that’s a bit more involved (it needs to grow the string
> table and the section it’s in), and so I wanted to make sure we really
> need it first.  :-)
>
> In the discussion of ‘meson-build-system’ in
> <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=28444>, we didn’t discuss
> this specific part.  Peter & Marius: can you explain whether/why this is
> needed?
>
> Thanks,
> Ludo’.
>
> Ludovic Courtès (3):
>   gremlin: Preserve offset info for dynamic entries.
>   gremlin: Add 'strip-runpath'.
>   build-system/meson: Use 'strip-runpath' instead of PatchELF.
>
>  guix/build/gremlin.scm            | 130 +++++++++++++++++++++---------
>  guix/build/meson-build-system.scm |   2 +-
>  tests/gremlin.scm                 |  35 +++++++-
>  3 files changed, 129 insertions(+), 38 deletions(-)

[bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[Ludovic Courtès]

Hello Peter,

(I’m re-adding Cc, hope you don’t mind.)

Peter Mikkelsen <petermikkelsen10@gmail.com> skribis:

> Since I am not really that much into meson, I am not sure my answer
> will be enough, but I will give it a go:
> The augment-rpath is needed because in some software projects such as
> nautilus, there is both a library and an executable.
> When building the software, the library is built first, and then the
> executable which depends on it, but then the runpath of the executable
> is 'fixed' so
> that libnautilus is no longer in the runpath of the nautilus binary.
> This is a problem since libnautilus is needed at runtime, so it is
> added using augment-rpath.

Oh, I see.

Back to this patch series, it means we still need ‘augment-rpath’.  :-/
I suppose we can still apply these patches to ‘core-updates-next’
though, it’s a step in the right direction.

> I think I remember something about the meson developers saying that it
> is no problem, since libnautilus will be installed in a standard
> location or something,
> but I really don't remember, sorry..

What Libtool does is that it “relinks” executables upon “make install”
so that they have the correct RUNPATH.

> Sorry for the not so good reply, but I hope it makes a little bit sense :)

It makes a lot of sense yes, thank you!

Ludo’.

bug#31208: [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[Ludovic Courtès]

ludo@gnu.org (Ludovic Courtès) skribis:

> Back to this patch series, it means we still need ‘augment-rpath’.  :-/
> I suppose we can still apply these patches to ‘core-updates-next’
> though, it’s a step in the right direction.

Done!

Ludo’.

[bug#31208] [PATCH 0/3] Add 'strip-runpath' in (guix build gremlin)

[Ludovic Courtès]

ludo@gnu.org (Ludovic Courtès) skribis:

> Peter Mikkelsen <petermikkelsen10@gmail.com> skribis:

[...]

>> I think I remember something about the meson developers saying that it
>> is no problem, since libnautilus will be installed in a standard
>> location or something,
>> but I really don't remember, sorry..
>
> What Libtool does is that it “relinks” executables upon “make install”
> so that they have the correct RUNPATH.

I found this issue, which mentions the problem:

  https://github.com/mesonbuild/meson/issues/2121#issuecomment-377971590

It’s a pity this isn’t properly solved.  :-/

Ludo’.