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