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, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  19 ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
  20 ;;;
  21 ;;; This file is part of GNU Guix.
  22 ;;;
  23 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  24 ;;; under the terms of the GNU General Public License as published by
  25 ;;; the Free Software Foundation; either version 3 of the License, or (at
  26 ;;; your option) any later version.
  27 ;;;
  28 ;;; GNU Guix is distributed in the hope that it will be useful, but
  29 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  30 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  31 ;;; GNU General Public License for more details.
  32 ;;;
  33 ;;; You should have received a copy of the GNU General Public License
  34 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  35
  36 (define-module (gnu build-support ld-wrapper)
  37   #:use-module (srfi srfi-1)
  38   #:use-module (ice-9 match)
  39   #:autoload   (ice-9 rdelim) (read-delimited)
  40   #:export (ld-wrapper))
  41
  42 ;;; Commentary:
  43 ;;;
  44 ;;; This is a wrapper for the linker.  Its purpose is to inspect the -L and
  45 ;;; -l switches passed to the linker, add corresponding -rpath arguments, and
  46 ;;; invoke the actual linker with this new set of arguments.
  47 ;;;
  48 ;;; The alternatives to this hack would be:
  49 ;;;
  50 ;;;   1. Using $LD_RUN_PATH.  However, that would tend to include more than
  51 ;;;      needed in the RPATH; for instance, given a package with `libfoo' as
  52 ;;;      an input, all its binaries would have libfoo in their RPATH,
  53 ;;;      regardless of whether they actually NEED it.
  54 ;;;
  55 ;;;   2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
  56 ;;;      `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
  57 ;;;      However, this doesn't work when $LIBRARY_PATH is used, because the
  58 ;;;      additional `-L' switches are not matched by the above rule, because
  59 ;;;      the rule only matches explicit user-provided switches.  See
  60 ;;;      <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
  61 ;;;
  62 ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
  63 ;;; libraries outside the store.
  64 ;;;
  65 ;;; Code:
  66
  67 (define %real-ld
  68   ;; Name of the linker that we wrap.
  69   "@LD@")
  70
  71 (define %store-directory
  72   ;; File name of the store.
  73   (or (getenv "NIX_STORE") "/gnu/store"))
  74
  75 (define %temporary-directory
  76   ;; Temporary directory.
  77   (or (getenv "TMPDIR") "/tmp"))
  78
  79 (define %build-directory
  80   ;; Top build directory when run from a builder.
  81   (getenv "NIX_BUILD_TOP"))
  82
  83 (define %allow-impurities?
  84   ;; Whether to allow references to libraries outside the store.
  85   ;; Allow them by default for convenience.
  86   (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")))
  87     (or (not value)
  88         (let ((value (string-downcase value)))
  89           (cond ((member value '("yes" "y" "t" "true" "1"))
  90                  #t)
  91                 ((member value '("no" "n" "f" "false" "0"))
  92                  #f)
  93                 (else
  94                  (format (current-error-port)
  95                          "ld-wrapper: ~s: invalid value for \
  96 'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%"
  97                          value)))))))
  98
  99 (define %debug?
 100   ;; Whether to emit debugging output.
 101   (getenv "GUIX_LD_WRAPPER_DEBUG"))
 102
 103 (define %disable-rpath?
 104   ;; Whether to disable automatic '-rpath' addition.
 105   (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH"))
 106
 107 (define (readlink* file)
 108   ;; Call 'readlink' until the result is not a symlink.
 109   (define %max-symlink-depth 50)
 110
 111   (let loop ((file  file)
 112              (depth 0))
 113     (define (absolute target)
 114       (if (absolute-file-name? target)
 115           target
 116           (string-append (dirname file) "/" target)))
 117
 118     (if (>= depth %max-symlink-depth)
 119         file
 120         (call-with-values
 121             (lambda ()
 122               (catch 'system-error
 123                 (lambda ()
 124                   (values #t (readlink file)))
 125                 (lambda args
 126                   (let ((errno (system-error-errno args)))
 127                     (if (or (= errno EINVAL) (= errno ENOENT))
 128                         (values #f file)
 129                         (apply throw args))))))
 130           (lambda (success? target)
 131             (if success?
 132                 (loop (absolute target) (+ depth 1))
 133                 file))))))
 134
 135 (define (pure-file-name? file)
 136   ;; Return #t when FILE is the name of a file either within the store
 137   ;; (possibly via a symlink) or within the build directory.
 138   (let ((file (readlink* file)))
 139     (or (not (string-prefix? "/" file))
 140         (string-prefix? %store-directory file)
 141         (string-prefix? %temporary-directory file)
 142         (and %build-directory
 143              (string-prefix? %build-directory file)))))
 144
 145 (define (store-file-name? file)
 146   ;; Return #t when FILE is a store file, possibly indirectly.
 147   (string-prefix? %store-directory (readlink* file)))
 148
 149 (define (shared-library? file)
 150   ;; Return #t when FILE denotes a shared library.
 151   (or (string-suffix? ".so" file)
 152       (let ((index (string-contains file ".so.")))
 153         ;; Since we cannot use regexps during bootstrap, roll our own.
 154         (and index
 155              (string-every (char-set-union (char-set #\.) char-set:digit)
 156                            (string-drop file (+ index 3)))))))
 157
 158 (define (library-search-path args)
 159   ;; Return the library search path as a list of directory names.  The GNU ld
 160   ;; manual notes that "[a]ll `-L' options apply to all `-l' options,
 161   ;; regardless of the order in which the options appear", so we must compute
 162   ;; the search path independently of the -l options.
 163   (let loop ((args args)
 164              (path '()))
 165     (match args
 166       (()
 167        (reverse path))
 168       (("-L" directory . rest)
 169        (loop rest (cons directory path)))
 170       ((argument . rest)
 171        (if (string-prefix? "-L" argument)         ;augment the search path
 172            (loop rest
 173                  (cons (string-drop argument 2) path))
 174            (loop rest path))))))
 175
 176 (define (library-files-linked args library-path)
 177   ;; Return the absolute file names of shared libraries explicitly linked
 178   ;; against via `-l' or with an absolute file name in ARGS, looking them up
 179   ;; in LIBRARY-PATH.
 180   (define files+args
 181     (fold (lambda (argument result)
 182             (match result
 183               ((library-files ((and flag
 184                                     (or "-dynamic-linker" "-plugin"))
 185                                . rest))
 186                ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when
 187                ;; passed '-plugin liblto_plugin.so', ignore
 188                ;; 'liblto_plugin.so'.  See <http://bugs.gnu.org/20102>.
 189                (list library-files
 190                      (cons* argument flag rest)))
 191               ((library-files previous-args)
 192                (cond ((string-prefix? "-l" argument) ;add library
 193                       (let* ((lib  (string-append "lib"
 194                                                   (string-drop argument 2)
 195                                                   ".so"))
 196                              (full (search-path library-path lib)))
 197                         (list (if full
 198                                   (cons full library-files)
 199                                   library-files)
 200                               (cons argument previous-args))))
 201                      ((and (string-prefix? %store-directory argument)
 202                            (shared-library? argument)) ;add library
 203                       (list (cons argument library-files)
 204                             (cons argument previous-args)))
 205                      (else
 206                       (list library-files
 207                             (cons argument previous-args)))))))
 208           (list '() '())
 209           args))
 210
 211   (match files+args
 212     ((files arguments)
 213      (reverse files))))
 214
 215 (define (rpath-arguments library-files)
 216   ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
 217   ;; absolute file names.
 218   (fold-right (lambda (file args)
 219                 ;; Add '-rpath' if and only if FILE is in the store; we don't
 220                 ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
 221                 ;; %TEMPORARY-DIRECTORY because that could leak to installed
 222                 ;; files.
 223                 (cond ((and (not %disable-rpath?)
 224                             (store-file-name? file))
 225                        (cons* "-rpath" (dirname file) args))
 226                       ((or %allow-impurities?
 227                            (pure-file-name? file))
 228                        args)
 229                       (else
 230                        (begin
 231                          (format (current-error-port)
 232                                  "ld-wrapper: error: attempt to use \
 233 library outside of ~a: ~s~%"
 234                                  %store-directory file)
 235                          (exit 1)))))
 236               '()
 237               library-files))
 238
 239 (define (expand-arguments args)
 240   ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
 241   ;; expanded (info "(gcc) Overall Options").
 242   (define (response-file-arguments file)
 243     (define (tokenize port)
 244       ;; Return a list of all strings found in PORT.  Quote characters are
 245       ;; removed, but whitespaces within quoted strings are preserved.
 246       (let loop ((tokens '()))
 247         (let* ((token+delimiter (read-delimited " '\"\n" port 'split))
 248                (token (car token+delimiter))
 249                (delim (cdr token+delimiter)))
 250           (if (eof-object? token)
 251               (reverse tokens)
 252               (case delim
 253                 ((#\") (loop (cons (read-delimited "\"" port) tokens)))
 254                 ((#\') (loop (cons (read-delimited "'" port) tokens)))
 255                 (else (if (> (string-length token) 0)
 256                           (loop (cons token tokens))
 257                           (loop tokens))))))))
 258
 259     (when %debug?
 260       (format (current-error-port)
 261               "ld-wrapper: attempting to read arguments from '~a'~%" file))
 262
 263     (call-with-input-file file tokenize))
 264
 265   (define result
 266     (fold-right (lambda (arg result)
 267                   (if (string-prefix? "@" arg)
 268                       (let ((file (string-drop arg 1)))
 269                         (append (catch 'system-error
 270                                   (lambda ()
 271                                     (response-file-arguments file))
 272                                   (lambda args
 273                                     ;; FILE doesn't exist or cannot be read so
 274                                     ;; leave ARG as is.
 275                                     (list arg)))
 276                                 result))
 277                       (cons arg result)))
 278                 '()
 279                 args))
 280
 281   ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
 282   ;; refer to nonexistent files), then recurse.
 283   (if (equal? result args)
 284       result
 285       (expand-arguments result)))
 286
 287 (define (ld-wrapper . args)
 288   ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
 289   (let* ((args (expand-arguments args))
 290          (path (library-search-path args))
 291          (libs (library-files-linked args path))
 292          (args (append args (rpath-arguments libs))))
 293     (when %debug?
 294       (format (current-error-port)
 295               "ld-wrapper: library search path: ~s~%" path)
 296       (format (current-error-port)
 297               "ld-wrapper: libraries linked: ~s~%" libs)
 298       (format (current-error-port)
 299               "ld-wrapper: invoking `~a' with ~s~%"
 300               %real-ld args)
 301       (force-output (current-error-port)))
 302     (apply execl %real-ld (basename %real-ld) args)))
 303
 304 ;;; ld-wrapper.scm ends here