01/02: gnu: Add ld wrapper variant that supports quotes in response files.

[guix-commits]

mbakke pushed a commit to branch master
in repository guix.

commit 25590118ad1a9e93b9f438c668bf1de020fd36d2
Author: Marius Bakke <address@hidden>
AuthorDate: Mon Feb 24 22:46:03 2020 +0100

    gnu: Add ld wrapper variant that supports quotes in response files.
    
    * gnu/packages/ld-wrapper-next.in: New file.
    * gnu/local.mk (MISC_DISTRO_FILES): Adjust accordingly.
    * gnu/packages/chromium.scm (ld-wrapper-next): New variable.
---
 gnu/local.mk                    |   3 +-
 gnu/packages/chromium.scm       |  15 +-
 gnu/packages/ld-wrapper-next.in | 305 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 321 insertions(+), 2 deletions(-)

diff --git a/gnu/local.mk b/gnu/local.mk
index b85c289..857345c 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1515,4 +1515,5 @@ dist_patch_DATA =                                         
\
   %D%/packages/patches/xsane-tighten-default-umask.patch
 
 MISC_DISTRO_FILES =                            \
-  %D%/packages/ld-wrapper.in
+  %D%/packages/ld-wrapper.in                   \
+  %D%/packages/ld-wrapper-next.in
diff --git a/gnu/packages/chromium.scm b/gnu/packages/chromium.scm
index 49ad8de..06e259b 100644
--- a/gnu/packages/chromium.scm
+++ b/gnu/packages/chromium.scm
@@ -70,7 +70,8 @@
   #:use-module (gnu packages xml)
   #:use-module (gnu packages xdisorg)
   #:use-module (gnu packages xorg)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1))
 
 (define %preserved-third-party-files
   '("base/third_party/cityhash" ;Expat
@@ -423,6 +424,18 @@ from forcing GEXP-PROMISE."
         `(cons "--enable-custom-modes"
                ,flags))))))
 
+;; Add a custom ld wrapper that supports quoted strings in response files.
+;; To be merged with 'ld-wrapper' in a future rebuild cycle.
+(define-public ld-wrapper-next
+  (let ((orig (car (assoc-ref (%final-inputs) "ld-wrapper"))))
+    (package
+      (inherit orig)
+      (name "ld-wrapper-next")
+      (inputs
+       `(("wrapper" ,(search-path %load-path
+                                  "gnu/packages/ld-wrapper-next.in"))
+         ,@(alist-delete "wrapper" (package-inputs orig)))))))
+
 (define-public ungoogled-chromium
   (package
     (name "ungoogled-chromium")
diff --git a/gnu/packages/ld-wrapper-next.in b/gnu/packages/ld-wrapper-next.in
new file mode 100644
index 0000000..5d5756f
--- /dev/null
+++ b/gnu/packages/ld-wrapper-next.in
@@ -0,0 +1,305 @@
+#!@BASH@
+# -*- 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>).
+# Unset 'GUILE_LOAD_COMPILED_PATH' to make sure we do not stumble upon
+# incompatible .go files.  See
+# <https://lists.gnu.org/archive/html/guile-devel/2016-03/msg00000.html>.
+
+unset GUILE_LOAD_COMPILED_PATH
+main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
+exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr 
(command-line)))" "$@"
+!#
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2020 Marius Bakke <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU 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.
+;;;
+;;; GNU 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build-support ld-wrapper)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:autoload   (ice-9 rdelim) (read-delimited)
+  #: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") "/gnu/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.
+  ;; Allow them by default for convenience.
+  (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")))
+    (or (not value)
+        (let ((value (string-downcase value)))
+          (cond ((member value '("yes" "y" "t" "true" "1"))
+                 #t)
+                ((member value '("no" "n" "f" "false" "0"))
+                 #f)
+                (else
+                 (format (current-error-port)
+                         "ld-wrapper: ~s: invalid value for \
+'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%"
+                         value)))))))
+
+(define %debug?
+  ;; Whether to emit debugging output.
+  (getenv "GUIX_LD_WRAPPER_DEBUG"))
+
+(define %disable-rpath?
+  ;; Whether to disable automatic '-rpath' addition.
+  (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH"))
+
+(define (readlink* file)
+  ;; Call 'readlink' until the result is not a symlink.
+  (define %max-symlink-depth 50)
+
+  (let loop ((file  file)
+             (depth 0))
+    (define (absolute target)
+      (if (absolute-file-name? target)
+          target
+          (string-append (dirname file) "/" target)))
+
+    (if (>= depth %max-symlink-depth)
+        file
+        (call-with-values
+            (lambda ()
+              (catch 'system-error
+                (lambda ()
+                  (values #t (readlink file)))
+                (lambda args
+                  (let ((errno (system-error-errno args)))
+                    (if (or (= errno EINVAL) (= errno ENOENT))
+                        (values #f file)
+                        (apply throw args))))))
+          (lambda (success? target)
+            (if success?
+                (loop (absolute target) (+ depth 1))
+                file))))))
+
+(define (pure-file-name? file)
+  ;; Return #t when FILE is the name of a file either within the store
+  ;; (possibly via a symlink) or within the build directory.
+  (let ((file (readlink* file)))
+    (or (not (string-prefix? "/" file))
+        (string-prefix? %store-directory file)
+        (string-prefix? %temporary-directory file)
+        (and %build-directory
+             (string-prefix? %build-directory file)))))
+
+(define (store-file-name? file)
+  ;; Return #t when FILE is a store file, possibly indirectly.
+  (string-prefix? %store-directory (readlink* file)))
+
+(define (shared-library? file)
+  ;; Return #t when FILE denotes a shared library.
+  (or (string-suffix? ".so" file)
+      (let ((index (string-contains file ".so.")))
+        ;; Since we cannot use regexps during bootstrap, roll our own.
+        (and index
+             (string-every (char-set-union (char-set #\.) char-set:digit)
+                           (string-drop file (+ index 3)))))))
+
+(define (library-search-path args)
+  ;; Return the library search path as a list of directory names.  The GNU ld
+  ;; manual notes that "[a]ll `-L' options apply to all `-l' options,
+  ;; regardless of the order in which the options appear", so we must compute
+  ;; the search path independently of the -l options.
+  (let loop ((args args)
+             (path '()))
+    (match args
+      (()
+       (reverse path))
+      (("-L" directory . rest)
+       (loop rest (cons directory path)))
+      ((argument . rest)
+       (if (string-prefix? "-L" argument)         ;augment the search path
+           (loop rest
+                 (cons (string-drop argument 2) path))
+           (loop rest path))))))
+
+(define (library-files-linked args library-path)
+  ;; Return the absolute file names of shared libraries explicitly linked
+  ;; against via `-l' or with an absolute file name in ARGS, looking them up
+  ;; in LIBRARY-PATH.
+  (define files+args
+    (fold (lambda (argument result)
+            (match result
+              ((library-files ((and flag
+                                    (or "-dynamic-linker" "-plugin"))
+                               . rest))
+               ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when
+               ;; passed '-plugin liblto_plugin.so', ignore
+               ;; 'liblto_plugin.so'.  See <http://bugs.gnu.org/20102>.
+               (list library-files
+                     (cons* argument flag rest)))
+              ((library-files previous-args)
+               (cond ((string-prefix? "-l" argument) ;add library
+                      (let* ((lib  (string-append "lib"
+                                                  (string-drop argument 2)
+                                                  ".so"))
+                             (full (search-path library-path lib)))
+                        (list (if full
+                                  (cons full library-files)
+                                  library-files)
+                              (cons argument previous-args))))
+                     ((and (string-prefix? %store-directory argument)
+                           (shared-library? argument)) ;add library
+                      (list (cons argument library-files)
+                            (cons argument previous-args)))
+                     (else
+                      (list library-files
+                            (cons argument previous-args)))))))
+          (list '() '())
+          args))
+
+  (match files+args
+    ((files arguments)
+     (reverse files))))
+
+(define (rpath-arguments library-files)
+  ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
+  ;; absolute file names.
+  (fold-right (lambda (file args)
+                ;; Add '-rpath' if and only if FILE is in the store; we don't
+                ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
+                ;; %TEMPORARY-DIRECTORY because that could leak to installed
+                ;; files.
+                (cond ((and (not %disable-rpath?)
+                            (store-file-name? file))
+                       (cons* "-rpath" (dirname file) args))
+                      ((or %allow-impurities?
+                           (pure-file-name? file))
+                       args)
+                      (else
+                       (begin
+                         (format (current-error-port)
+                                 "ld-wrapper: error: attempt to use \
+library outside of ~a: ~s~%"
+                                 %store-directory file)
+                         (exit 1)))))
+              '()
+              library-files))
+
+(define (expand-arguments args)
+  ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
+  ;; expanded (info "(gcc) Overall Options").
+  (define (response-file-arguments file)
+    (define (tokenize port)
+      ;; Return a list of all strings found in PORT.  Quote characters are 
removed,
+      ;; but whitespaces within quoted strings are preserved.
+      (let loop ((words '()))
+        (let* ((word (read-delimited " '\"" port 'split))
+               (token (car word))
+               (delim (cdr word)))
+          (if (eof-object? delim)
+              (reverse words)
+              (case delim
+                ((#\") (loop (cons (read-delimited "\"" port) words)))
+                ((#\') (loop (cons (read-delimited "'" port) words)))
+                ((#\ ) (if (> 0 (string-length token))
+                           (loop (cons token words))
+                           (loop words)))
+                (else (loop words)))))))
+
+    (when %debug?
+      (format (current-error-port)
+              "ld-wrapper: attempting to read arguments from '~a'~%" file))
+
+    (call-with-input-file file tokenize))
+
+  (define result
+    (fold-right (lambda (arg result)
+                  (if (string-prefix? "@" arg)
+                      (let ((file (string-drop arg 1)))
+                        (append (catch 'system-error
+                                  (lambda ()
+                                    (response-file-arguments file))
+                                  (lambda args
+                                    ;; FILE doesn't exist or cannot be read so
+                                    ;; leave ARG as is.
+                                    (list arg)))
+                                result))
+                      (cons arg result)))
+                '()
+                args))
+
+  ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
+  ;; refer to nonexistent files), then recurse.
+  (if (equal? result args)
+      result
+      (expand-arguments result)))
+
+(define (ld-wrapper . args)
+  ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
+  (let* ((args (expand-arguments args))
+         (path (library-search-path args))
+         (libs (library-files-linked args path))
+         (args (append args (rpath-arguments libs))))
+    (when %debug?
+      (format (current-error-port)
+              "ld-wrapper: library search path: ~s~%" path)
+      (format (current-error-port)
+              "ld-wrapper: libraries linked: ~s~%" libs)
+      (format (current-error-port)
+              "ld-wrapper: invoking `~a' with ~s~%"
+              %real-ld args)
+      (force-output (current-error-port)))
+    (apply execl %real-ld (basename %real-ld) args)))
+
+;;; ld-wrapper.scm ends here