distro: Add an `ld' wrapper, to pass missing `-rpath' flags.

* distro/ld-wrapper.scm: New file.
* Makefile.am (MODULES): Add it.

* distro/base.scm (ld-wrapper-boot3): New variable.
  (%boot3-inputs): Add LD-WRAPPER-BOOT3.
  (bash-final, guile-final, ld-wrapper): New final.
  (%final-inputs): Use BASH-FINAL; add LD-WRAPPER.
  (gcc-4.7): Remove the `-rpath' trick from the `lib' spec string.

2 files changed, 213 insertions, 13 deletions

diff --git a/distro/base.scm b/distro/base.scm
index d6cb8b3170..37443c1f55 100644
--- a/distro/base.scm
+++ b/distro/base.scm
@@ -765,17 +765,6 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.")
 
                ;; Tell where to find libstdc++, libc, and `?crt*.o', except
                ;; `crt{begin,end}.o', which come with GCC.
-               ;;
-               ;; The `%{L*:-rpath %*}' rule adds a `-rpath LIBDIR' argument
-               ;; for each occurrence of `-L LIBDIR'.  We could avoid
-               ;; `-rpath' altogether and instead use the `LD_RUN_PATH'
-               ;; environment variable, but that would tend to include more
-               ;; than needed in the RPATH; for instance, given a package
-               ;; with `libfoo' as an input, all its binaries would have
-               ;; libfoo in their RPATH, regardless of whether they actually
-               ;; NEED it.  See
-               ;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for
-               ;; details.
 
                ;; XXX: For crt*.o, use `STANDARD_STARTFILE_PREFIX' instead?  See
                ;; <http://www.linuxfromscratch.org/lfs/view/stable/chapter05/gcc-pass1.html>.
@@ -784,7 +773,7 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.")
                              "gcc/config/i386/gnu-user64.h")
                  (("#define LIB_SPEC (.*)$" _ suffix)
                   (format #f "#define LIB_SPEC \"-L~a/lib -rpath=~a/lib \
--rpath=~a/lib64 -rpath=~a/lib %{L*:-rpath %*}\" ~a~%"
+-rpath=~a/lib64 -rpath=~a/lib \" ~a~%"
                           libc libc out out suffix))
                  (("([^ ]*)crt([^\\.])\\.o" _ prefix suffix)
                   (string-append libc "/lib/" prefix "crt" suffix ".o"))))
@@ -1678,11 +1667,74 @@ exec ~a/bin/~a-gcc -B~a/lib -Wl,-dynamic-linker -Wl,~a/lib/~a \"$@\"~%"
               ("binutils" ,binutils-final)
               ,@%boot2-inputs))))
 
+(define ld-wrapper-boot3
+  ;; A linker wrapper that uses the bootstrap Guile.
+  (package
+    (name "ld-wrapper-boot3")
+    (version "0")
+    (source #f)
+    (build-system trivial-build-system)
+    (inputs `(("binutils" ,binutils-final)
+              ("guile"   ,(nixpkgs-derivation* "guile"))
+              ("wrapper" ,(search-path %load-path "distro/ld-wrapper.scm"))))
+    (arguments
+     `(#:modules ((guix build utils))
+       #:builder (begin
+                   (use-modules (guix build utils)
+                                (system base compile))
+
+                   (let* ((out (assoc-ref %outputs "out"))
+                          (bin (string-append out "/bin"))
+                          (ld  (string-append bin "/ld"))
+                          (go  (string-append bin "/ld.go")))
+
+                     (setvbuf (current-output-port) _IOLBF)
+                     (format #t "building ~s/bin/ld wrapper in ~s~%"
+                             (assoc-ref %build-inputs "binutils")
+                             out)
+
+                     (mkdir out) (mkdir bin)
+                     (copy-file (assoc-ref %build-inputs "wrapper") ld)
+                     (substitute* ld
+                       (("@GUILE@")
+                        (string-append (assoc-ref %build-inputs "guile")
+                                       "/bin/guile"))
+                       (("@LD@")
+                        (string-append (assoc-ref %build-inputs "binutils")
+                                       "/bin/ld")))
+                     (chmod ld #o555)
+                     (compile-file ld #:output-file go)))))
+    (description "The linker wrapper")
+    (long-description
+     "The linker wrapper (or `ld-wrapper') wraps the linker to add any
+missing `-rpath' flags, and to detect any misuse of libraries outside of the
+store.")
+    (home-page #f)
+    (license "GPLv3+")))
+
 (define %boot3-inputs
   ;; 4th stage inputs.
   `(("gcc" ,gcc-final)
+    ("ld-wrapper" ,ld-wrapper-boot3)
     ,@(alist-delete "gcc" %boot2-inputs)))
 
+(define-public bash-final
+  (package-with-explicit-inputs bash %boot3-inputs
+                                (current-source-location)))
+
+(define-public guile-final
+  (package-with-explicit-inputs guile-2.0
+                                `(("bash" ,bash-final)
+                                  ,@(alist-delete "bash" %boot3-inputs))
+                                (current-source-location)))
+
+(define-public ld-wrapper
+  ;; The final `ld' wrapper, which uses the final Guile.
+  (package (inherit ld-wrapper-boot3)
+    (name "ld-wrapper")
+    (inputs `(("guile" ,guile-final)
+              ,@(alist-delete "guile" (package-inputs ld-wrapper-boot3))))))
+
 (define-public %final-inputs
   ;; Final derivations used as implicit inputs by `gnu-build-system'.
   ;; FIXME: Build bash before the others, otherwise patch-shebangs uses it in
@@ -1701,10 +1753,11 @@ exec ~a/bin/~a-gcc -B~a/lib -Wl,-dynamic-linker -Wl,~a/lib/~a \"$@\"~%"
                ("coreutils" ,coreutils)
                ("sed" ,sed)
                ("grep" ,grep)
-               ("bash" ,bash)
                ("findutils" ,findutils)
                ("gawk" ,gawk)
                ("make" ,gnu-make)))
+      ("bash" ,bash-final)
+      ("ld-wrapper" ,ld-wrapper)
       ("binutils" ,binutils-final)
       ("gcc" ,gcc-final)
       ("libc" ,glibc-final))))
diff --git a/distro/ld-wrapper.scm b/distro/ld-wrapper.scm
new file mode 100644
index 0000000000..9d3e8008b3
--- /dev/null
+++ b/distro/ld-wrapper.scm
@@ -0,0 +1,147 @@
+#!/bin/sh
+# -*- mode: scheme; coding: utf-8; -*-
+
+# XXX: We have to go through Bash because there's no command-line switch to
+# augment %load-compiled-path, and because of the silly 127-byte limit for
+# the shebang line in Linux.
+# Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
+# .go file (see <http://bugs.gnu.org/12519>).
+
+main="(@ (distro ld-wrapper) ld-wrapper)"
+exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@"
+!#
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (distro ld-wrapper)
+  #:use-module (srfi srfi-1)
+  #:export (ld-wrapper))
+
+;;; Commentary:
+;;;
+;;; This is a wrapper for the linker.  Its purpose is to inspect the -L and
+;;; -l switches passed to the linker, add corresponding -rpath arguments, and
+;;; invoke the actual linker with this new set of arguments.
+;;;
+;;; The alternatives to this hack would be:
+;;;
+;;;   1. Using $LD_RUN_PATH.  However, that would tend to include more than
+;;;      needed in the RPATH; for instance, given a package with `libfoo' as
+;;;      an input, all its binaries would have libfoo in their RPATH,
+;;;      regardless of whether they actually NEED it.
+;;;
+;;;   2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
+;;;      `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
+;;;      However, this doesn't work when $LIBRARY_PATH is used, because the
+;;;      additional `-L' switches are not matched by the above rule, because
+;;;      the rule only matches explicit user-provided switches.  See
+;;;      <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
+;;;
+;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
+;;; libraries outside the store.
+;;;
+;;; Code:
+
+(define %real-ld
+  ;; Name of the linker that we wrap.
+  "@LD@")
+
+(define %store-directory
+  ;; File name of the store.
+  (or (getenv "NIX_STORE") "/nix/store"))
+
+(define %temporary-directory
+  ;; Temporary directory.
+  (or (getenv "TMPDIR") "/tmp"))
+
+(define %build-directory
+  ;; Top build directory when run from a builder.
+  (getenv "NIX_BUILD_TOP"))
+
+(define %allow-impurities?
+  ;; Whether to allow references to libraries outside the store.
+  (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
+
+(define %debug?
+  ;; Whether to emit debugging output.
+  (getenv "GUIX_LD_WRAPPER_DEBUG"))
+
+(define (pure-file-name? file)
+  ;; Return #t when FILE is the name of a file either within the store or
+  ;; within the build directory.
+  (or (not (string-prefix? "/" file))
+      (string-prefix? %store-directory file)
+      (string-prefix? %temporary-directory file)
+      (and %build-directory
+           (string-prefix? %build-directory file))))
+
+(define (switch-arguments switch args)
+  ;; Return the arguments passed for the occurrences of SWITCH--e.g.,
+  ;; "-L"--in ARGS.
+  (let ((prefix-len (string-length switch)))
+    (fold-right (lambda (arg path)
+                  (if (string-prefix? switch arg)
+                      (cons (substring arg prefix-len) path)
+                      path))
+                '()
+                args)))
+
+(define (library-path args)
+  ;; Return the library search path extracted from `-L' switches in ARGS.
+  ;; Note: allow references to out-of-store directories.  When this leads to
+  ;; actual impurities, this is caught later.
+  (switch-arguments "-L" args))
+
+(define (library-files-linked args)
+  ;; Return the file names of shared libraries explicitly linked against via
+  ;; `-l' in ARGS.
+  (map (lambda (lib)
+         (string-append "lib" lib ".so"))
+       (switch-arguments "-l" args)))
+
+(define (rpath-arguments lib-path library-files)
+  ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in
+  ;; LIB-PATH.
+  (fold-right (lambda (file args)
+                (let ((absolute (search-path lib-path file)))
+                  (if absolute
+                      (if (or %allow-impurities?
+                              (pure-file-name? absolute))
+                          (cons* "-rpath" (dirname absolute)
+                                 args)
+                          (begin
+                            (format (current-error-port)
+                                    "ld-wrapper: error: attempt to use impure library ~s~%"
+                                    absolute)
+                            (exit 1)))
+                      args)))
+              '()
+              library-files))
+
+(define (ld-wrapper . args)
+  ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
+  (let* ((lib-path (library-path args))
+         (libs     (library-files-linked args))
+         (args     (append args (rpath-arguments lib-path libs))))
+    (if %debug?
+        (format (current-error-port)
+                "ld-wrapper: invoking `~a' with ~s~%"
+                %real-ld args))
+    (apply execl %real-ld (basename %real-ld) args)))
+
+;;; ld-wrapper.scm ends here