gnu/packages/ld-wrapper.in

   1 #!@BASH@
   2 # -*- mode: scheme; coding: utf-8; -*-
   3
   4 # XXX: We have to go through Bash because there's no command-line switch to
   5 # augment %load-compiled-path, and because of the silly 127-byte limit for
   6 # the shebang line in Linux.
   7 # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
   8 # .go file (see <http://bugs.gnu.org/12519>).
   9
  10 main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
  11 exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@"
  12 !#
  13 ;;; GNU Guix --- Functional package management for GNU
  14 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
  15 ;;;
  16 ;;; This file is part of GNU Guix.
  17 ;;;
  18 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  19 ;;; under the terms of the GNU General Public License as published by
  20 ;;; the Free Software Foundation; either version 3 of the License, or (at
  21 ;;; your option) any later version.
  22 ;;;
  23 ;;; GNU Guix is distributed in the hope that it will be useful, but
  24 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 ;;; GNU General Public License for more details.
  27 ;;;
  28 ;;; You should have received a copy of the GNU General Public License
  29 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  30
  31 (define-module (gnu build-support ld-wrapper)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (ice-9 match)
  34   #:export (ld-wrapper))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; This is a wrapper for the linker.  Its purpose is to inspect the -L and
  39 ;;; -l switches passed to the linker, add corresponding -rpath arguments, and
  40 ;;; invoke the actual linker with this new set of arguments.
  41 ;;;
  42 ;;; The alternatives to this hack would be:
  43 ;;;
  44 ;;;   1. Using $LD_RUN_PATH.  However, that would tend to include more than
  45 ;;;      needed in the RPATH; for instance, given a package with `libfoo' as
  46 ;;;      an input, all its binaries would have libfoo in their RPATH,
  47 ;;;      regardless of whether they actually NEED it.
  48 ;;;
  49 ;;;   2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
  50 ;;;      `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
  51 ;;;      However, this doesn't work when $LIBRARY_PATH is used, because the
  52 ;;;      additional `-L' switches are not matched by the above rule, because
  53 ;;;      the rule only matches explicit user-provided switches.  See
  54 ;;;      <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
  55 ;;;
  56 ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
  57 ;;; libraries outside the store.
  58 ;;;
  59 ;;; Code:
  60
  61 (define %real-ld
  62   ;; Name of the linker that we wrap.
  63   "@LD@")
  64
  65 (define %store-directory
  66   ;; File name of the store.
  67   (or (getenv "NIX_STORE") "/gnu/store"))
  68
  69 (define %temporary-directory
  70   ;; Temporary directory.
  71   (or (getenv "TMPDIR") "/tmp"))
  72
  73 (define %build-directory
  74   ;; Top build directory when run from a builder.
  75   (getenv "NIX_BUILD_TOP"))
  76
  77 (define %allow-impurities?
  78   ;; Whether to allow references to libraries outside the store.
  79   (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
  80
  81 (define %debug?
  82   ;; Whether to emit debugging output.
  83   (getenv "GUIX_LD_WRAPPER_DEBUG"))
  84
  85 (define %disable-rpath?
  86   ;; Whether to disable automatic '-rpath' addition.
  87   (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH"))
  88
  89 (define (readlink* file)
  90   ;; Call 'readlink' until the result is not a symlink.
  91   (define %max-symlink-depth 50)
  92
  93   (let loop ((file  file)
  94              (depth 0))
  95     (catch 'system-error
  96       (lambda ()
  97         (if (>= depth %max-symlink-depth)
  98             file
  99             (loop (readlink file) (+ depth 1))))
 100       (lambda args
 101         (if (= EINVAL (system-error-errno args))
 102             file
 103             (apply throw args))))))
 104
 105 (define (dereference-symlinks file)
 106   ;; Same as 'readlink*' but return FILE if the symlink target is invalid or
 107   ;; FILE does not exist.
 108   (catch 'system-error
 109     (lambda ()
 110       ;; When used from a user environment, FILE may refer to
 111       ;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
 112       ;; store.  Check whether this is the case.
 113       (readlink* file))
 114     (lambda args
 115       (if (= ENOENT (system-error-errno args))
 116           file
 117           (apply throw args)))))
 118
 119 (define (pure-file-name? file)
 120   ;; Return #t when FILE is the name of a file either within the store
 121   ;; (possibly via a symlink) or within the build directory.
 122   (let ((file (dereference-symlinks file)))
 123     (or (not (string-prefix? "/" file))
 124         (string-prefix? %store-directory file)
 125         (string-prefix? %temporary-directory file)
 126         (and %build-directory
 127              (string-prefix? %build-directory file)))))
 128
 129 (define (store-file-name? file)
 130   ;; Return #t when FILE is a store file, possibly indirectly.
 131   (string-prefix? %store-directory (dereference-symlinks file)))
 132
 133 (define (shared-library? file)
 134   ;; Return #t when FILE denotes a shared library.
 135   (or (string-suffix? ".so" file)
 136       (let ((index (string-contains file ".so.")))
 137         ;; Since we cannot use regexps during bootstrap, roll our own.
 138         (and index
 139              (string-every (char-set-union (char-set #\.) char-set:digit)
 140                            (string-drop file (+ index 3)))))))
 141
 142 (define (library-files-linked args)
 143   ;; Return the file names of shared libraries explicitly linked against via
 144   ;; `-l' or with an absolute file name in ARGS.
 145   (define path+files
 146     (fold (lambda (argument result)
 147             (match result
 148               ((library-path . library-files)
 149                (cond ((string-prefix? "-L" argument) ;augment the search path
 150                       (cons (append library-path
 151                                     (list (string-drop argument 2)))
 152                             library-files))
 153                      ((string-prefix? "-l" argument) ;add library
 154                       (let* ((lib  (string-append "lib"
 155                                                   (string-drop argument 2)
 156                                                   ".so"))
 157                              (full (search-path library-path lib)))
 158                         (if full
 159                             (cons library-path
 160                                   (cons full library-files))
 161                             result)))
 162                      ((and (string-prefix? %store-directory argument)
 163                            (shared-library? argument)) ;add library
 164                       (cons library-path
 165                             (cons argument library-files)))
 166                      (else
 167                       result)))))
 168           (cons '() '())
 169           args))
 170
 171   (match path+files
 172     ((path . files)
 173      (reverse files))))
 174
 175 (define (rpath-arguments library-files)
 176   ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
 177   ;; absolute file names.
 178   (fold-right (lambda (file args)
 179                 ;; Add '-rpath' if and only if FILE is in the store; we don't
 180                 ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
 181                 ;; %TEMPORARY-DIRECTORY because that could leak to installed
 182                 ;; files.
 183                 (cond ((and (not %disable-rpath?)
 184                             (store-file-name? file))
 185                        (cons* "-rpath" (dirname file) args))
 186                       ((or %allow-impurities?
 187                            (pure-file-name? file))
 188                        args)
 189                       (else
 190                        (begin
 191                          (format (current-error-port)
 192                                  "ld-wrapper: error: attempt to use \
 193 impure library ~s~%"
 194                                  file)
 195                          (exit 1)))))
 196               '()
 197               library-files))
 198
 199 (define (ld-wrapper . args)
 200   ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
 201   (let* ((libs (library-files-linked args))
 202          (args (append args (rpath-arguments libs))))
 203     (when %debug?
 204       (format (current-error-port)
 205               "ld-wrapper: invoking `~a' with ~s~%"
 206               %real-ld args))
 207     (apply execl %real-ld (basename %real-ld) args)))
 208
 209 ;;; ld-wrapper.scm ends here