08/08: build-system/gnu: Add 'validate-runpath' phase.

[Ludovic Courtès]

civodul pushed a commit to branch core-updates
in repository guix.

commit 112da5887550ab929112dbe4ce9df535fc0a7006
Author: Ludovic Courtès <address@hidden>
Date:   Wed Apr 1 16:47:49 2015 +0200

    build-system/gnu: Add 'validate-runpath' phase.
    
    * guix/build/gnu-build-system.scm (every*, validate-runpath): New
      procedures.
      (%standard-phases): Add 'validate-runpath'.
    * guix/build-system/gnu.scm (%gnu-build-system-modules): Add (guix build
      gremlin) and (guix elf).
      (gnu-build): Add #:validate-runpath?.
      [builder]: Pass it.
      (gnu-cross-build): Likewise.
    * gnu/packages/base.scm (glibc)[arguments]: Add #:validate-runpath? #f.
---
 gnu/packages/base.scm           |    6 ++++
 guix/build-system/gnu.scm       |    8 ++++-
 guix/build/gnu-build-system.scm |   62 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 75 insertions(+), 1 deletions(-)

diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index 3ed853a..3ff3172 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -393,6 +393,12 @@ included.")
       ;; <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00709.html>.
       #:parallel-build? #f
 
+      ;; The libraries have an empty RUNPATH, but some, such as the versioned
+      ;; libraries (libdl-2.21.so, etc.) have ld.so marked as NEEDED.  Since
+      ;; these libraries are always going to be found anyway, just skip
+      ;; RUNPATH checks.
+      #:validate-runpath? #f
+
       #:configure-flags
       (list "--enable-add-ons"
             "--sysconfdir=/etc"
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index e4cbd29..3ccdef1 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -45,7 +45,9 @@
 (define %gnu-build-system-modules
   ;; Build-side modules imported and used by default.
   '((guix build gnu-build-system)
-    (guix build utils)))
+    (guix build utils)
+    (guix build gremlin)
+    (guix elf)))
 
 (define %default-modules
   ;; Modules in scope in the build-side environment.
@@ -283,6 +285,7 @@ standard packages used as implicit inputs of the GNU build 
system."
                     (strip-flags ''("--strip-debug"))
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
+                    (validate-runpath? #t)
                     (phases '%standard-phases)
                     (locale "en_US.UTF-8")
                     (system (%current-system))
@@ -345,6 +348,7 @@ are allowed to refer to."
                   #:parallel-tests? ,parallel-tests?
                   #:patch-shebangs? ,patch-shebangs?
                   #:strip-binaries? ,strip-binaries?
+                  #:validate-runpath? ,validate-runpath?
                   #:strip-flags ,strip-flags
                   #:strip-directories ,strip-directories)))
 
@@ -417,6 +421,7 @@ is one of `host' or `target'."
                           (strip-flags ''("--strip-debug"))
                           (strip-directories ''("lib" "lib64" "libexec"
                                                 "bin" "sbin"))
+                          (validate-runpath? #t)
                           (phases '%standard-phases)
                           (locale "en_US.UTF-8")
                           (system (%current-system))
@@ -490,6 +495,7 @@ platform."
                     #:parallel-tests? ,parallel-tests?
                     #:patch-shebangs? ,patch-shebangs?
                     #:strip-binaries? ,strip-binaries?
+                    #:validate-runpath? ,validate-runpath?
                     #:strip-flags ,strip-flags
                     #:strip-directories ,strip-directories))))
 
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 5ae5371..5220bda 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -18,12 +18,15 @@
 
 (define-module (guix build gnu-build-system)
   #:use-module (guix build utils)
+  #:use-module (guix build gremlin)
+  #:use-module (guix elf)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
   #:export (%standard-phases
             gnu-build))
 
@@ -398,6 +401,64 @@ makefiles."
                                        strip-directories)))
                          outputs))))
 
+(define (every* pred lst)
+  "This is like 'every', but process all the elements of LST instead of
+stopping as soon as PRED returns false.  This is useful when PRED has side
+effects, such as displaying warnings or error messages."
+  (let loop ((lst    lst)
+             (result #t))
+    (match lst
+      (()
+       result)
+      ((head . tail)
+       (loop tail (and (pred head) result))))))
+
+(define* (validate-runpath #:key
+                           validate-runpath?
+                           (elf-directories '("lib" "lib64" "libexec"
+                                              "bin" "sbin"))
+                           outputs #:allow-other-keys)
+  "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
+ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
+
+Since the ELF parser needs to have a copy of files in memory, better run this
+phase after stripping."
+  (define (sub-directory parent)
+    (lambda (directory)
+      (let ((directory (string-append parent "/" directory)))
+        (and (directory-exists? directory) directory))))
+
+  (define (validate directory)
+    (define (file=? file1 file2)
+      (let ((st1 (stat file1))
+            (st2 (stat file2)))
+        (= (stat:ino st1) (stat:ino st2))))
+
+    ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
+    ;; duplicates.
+    (let ((files (delete-duplicates (find-files directory (lambda (file stat)
+                                                            (elf-file? file)))
+                                    file=?)))
+      (format (current-error-port)
+              "validating RUNPATH of ~a binaries in ~s...~%"
+              (length files) directory)
+      (every* validate-needed-in-runpath files)))
+
+  (if validate-runpath?
+      (let ((dirs (append-map (match-lambda
+                                (("debug" . _)
+                                 ;; The "debug" output is full of ELF files
+                                 ;; that are not worth checking.
+                                 '())
+                                ((name . output)
+                                 (filter-map (sub-directory output)
+                                             elf-directories)))
+                              outputs)))
+        (every* validate dirs))
+      (begin
+        (format (current-error-port) "skipping RUNPATH validation~%")
+        #t)))
+
 (define* (validate-documentation-location #:key outputs
                                           #:allow-other-keys)
   "Documentation should go to 'share/info' and 'share/man', not just 'info/'
@@ -486,6 +547,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
             patch-source-shebangs configure patch-generated-file-shebangs
             build check install
             patch-shebangs strip
+            validate-runpath
             validate-documentation-location
             compress-documentation)))