gnu: racket: Don't inject store paths into Racket files.

Apparently, during grafting, Guix can somehow mangle compiled
Racket CS files (.zo) such that Racket will refuse to load them.
(Maybe it has something to do with compression?)
So, we stop patching Racket sources with absolute paths to store
files (i.e. for foreign libraries to dlopen).
Instead, we put them in a data file that doesn't get compiled or,
in one case, embed it in C.

Fixes https://issues.guix.gnu.org/47064

* gnu/packages/patches/racket-sh-via-rktio.patch: New file.
Adds a special case at the C level, controlled by a preprocessor macro,
to handle attempts to execute "/bin/sh".
* gnu/local.mk (dist_patch_DATA): Add it.
* gnu/packages/scheme.scm (racket)[source](patches): Apply it.
(racket)[arguments](#:configure-flags): Add the CPP flag to enable it.
(racket)[arguments](#:modules): Use srfi-1.
(racket)[arguments](#:phases): Remove 'patch-/bin/sh and 'pre-configure.
Change 'pre-configure-minimal to just change directory.
Add 'patch-config.rktd-lib-search-dirs after 'build and before 'install
to configure Racket's "lib-search-dirs".
(racket, racket-minimal)[inputs]: Add bash-minimal as an explicit input.
(racket-minimal)[source]: Adjust to inherit patches from racket.
(racket-minimal)[arguments]: Inherit from racket: changes no longer needed.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 87 insertions, 104 deletions

diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 10be0aa28a..b5d526bfc3 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -14,6 +14,7 @@
 ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz>
 ;;; Copyright © 2020 Brett Gilio <brettg@gnu.org>
 ;;; Copyright © 2020 Edouard Klein <edk@beaver-labs.com>
+;;; Copyright © 2021 Philip McGrath <philip@philipmcgrath.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,6 +44,7 @@
   #:use-module (guix build-system trivial)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages bdw-gc)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages databases)
   #:use-module (gnu packages libevent)
@@ -411,94 +413,26 @@ implementation techniques and as an expository tool.")
                (base32
                 "047wpjblfzmf1msz7snrp2c2h0zxyzlmbsqr9bwsyvz3frcg0888"))
               (patches (search-patches
+                        "racket-sh-via-rktio.patch"
+                        ;; TODO: If we're no longer patching Racket source
+                        ;; files with store paths, we may also fix the
+                        ;; issue that necessitated the following patch:
                         "racket-store-checksum-override.patch"))))
     (build-system gnu-build-system)
     (arguments
-     '(#:configure-flags
-       '("--enable-libz"
+     `(#:configure-flags
+       `(,(string-append "CPPFLAGS=-DGUIX_RKTIO_PATCH_BIN_SH="
+                         (assoc-ref %build-inputs "sh")
+                         "/bin/sh")
+         "--enable-libz"
          "--enable-liblz4")
+       #:modules
+       ((guix build gnu-build-system)
+        (guix build utils)
+        (srfi srfi-1))
        #:phases
        (modify-phases %standard-phases
-         (add-before 'configure 'pre-configure-minimal
-           (lambda* (#:key inputs #:allow-other-keys)
-             ;; Patch dynamically loaded libraries with their absolute paths.
-             (let* ((library-path (search-path-as-string->list
-                                   (getenv "LIBRARY_PATH")))
-                    (find-so (lambda (soname)
-                               (search-path
-                                library-path
-                                (format #f "~a.so" soname)))))
-               (substitute* "collects/db/private/sqlite3/ffi.rkt"
-                 (("ffi-lib sqlite-so")
-                  (format #f "ffi-lib \"~a\"" (find-so "libsqlite3"))))
-               (substitute* "collects/openssl/libssl.rkt"
-                 (("ffi-lib libssl-so")
-                  (format #f "ffi-lib \"~a\"" (find-so "libssl"))))
-               (substitute* "collects/openssl/libcrypto.rkt"
-                 (("ffi-lib libcrypto-so")
-                  (format #f "ffi-lib \"~a\"" (find-so "libcrypto")))))
-             (chdir "src")
-             #t))
-         (add-before 'pre-configure-minimal 'pre-configure
-           (lambda* (#:key inputs #:allow-other-keys)
-             ;; Patch dynamically loaded libraries with their absolute paths.
-             (let* ((library-path (search-path-as-string->list
-                                   (getenv "LIBRARY_PATH")))
-                    (find-so (lambda (soname)
-                               (search-path
-                                library-path
-                                (format #f "~a.so" soname))))
-                    (patch-ffi-libs (lambda (file libs)
-                                      (for-each
-                                       (lambda (lib)
-                                         (substitute* file
-                                           (((format #f "\"~a\"" lib))
-                                            (format #f "\"~a\"" (find-so lib)))))
-                                       libs))))
-               (substitute* "share/pkgs/math-lib/math/private/bigfloat/gmp.rkt"
-                 (("ffi-lib libgmp-so")
-                  (format #f "ffi-lib \"~a\"" (find-so "libgmp"))))
-               (substitute* "share/pkgs/math-lib/math/private/bigfloat/mpfr.rkt"
-                 (("ffi-lib libmpfr-so")
-                  (format #f "ffi-lib \"~a\"" (find-so "libmpfr"))))
-               (substitute* "share/pkgs/readline-lib/readline/rktrl.rkt"
-                 (("\\(getenv \"PLT_READLINE_LIB\"\\)")
-                  (format #f "\"~a\"" (find-so "libedit"))))
-               (for-each
-                (lambda (x) (apply patch-ffi-libs x))
-                '(("share/pkgs/draw-lib/racket/draw/unsafe/cairo-lib.rkt"
-                   ("libfontconfig" "libcairo"))
-                  ("share/pkgs/draw-lib/racket/draw/unsafe/glib.rkt"
-                   ("libglib-2.0" "libgmodule-2.0" "libgobject-2.0"))
-                  ("share/pkgs/draw-lib/racket/draw/unsafe/jpeg.rkt"
-                   ("libjpeg"))
-                  ("share/pkgs/draw-lib/racket/draw/unsafe/pango.rkt"
-                   ("libpango-1.0" "libpangocairo-1.0"))
-                  ("share/pkgs/draw-lib/racket/draw/unsafe/png.rkt"
-                   ("libpng"))
-                  ("share/pkgs/db-lib/db/private/odbc/ffi.rkt"
-                   ("libodbc"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/x11.rkt"
-                   ("libX11"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/gsettings.rkt"
-                   ("libgio-2.0"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/gtk3.rkt"
-                   ("libgdk-3" "libgtk-3"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/unique.rkt"
-                   ("libunique-1.0"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/utils.rkt"
-                   ("libgdk-x11-2.0" "libgdk_pixbuf-2.0" "libgtk-x11-2.0"))
-                  ("share/pkgs/gui-lib/mred/private/wx/gtk/gl-context.rkt"
-                   ("libGL"))
-                  ("share/pkgs/sgl/gl.rkt"
-                   ("libGL" "libGLU")))))
-             #t))
-         (add-after 'unpack 'patch-/bin/sh
-           (lambda _
-             (substitute* "collects/racket/system.rkt"
-               (("/bin/sh") (which "sh")))
-             #t))
-         (add-after 'patch-/bin/sh 'patch-chez-configure
+         (add-after 'unpack 'patch-chez-configure
            (lambda* (#:key inputs outputs #:allow-other-keys)
              (substitute* "src/cs/c/Makefile.in"
                (("/bin/sh") (which "sh")))
@@ -526,12 +460,69 @@ implementation techniques and as an expository tool.")
                  (("/bin/cp") (which "cp"))
                  (("/bin/echo") (which "echo")))
                (substitute* "makefiles/installsh"
-                 (("/bin/true") (which "true")))))))
+                 (("/bin/true") (which "true"))))
+             #t))
+         (add-before 'configure 'pre-configure-minimal
+           (lambda* (#:key inputs #:allow-other-keys)
+             (chdir "src")
+             #t))
+         (add-after 'build 'patch-config.rktd-lib-search-dirs
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             ;; We do this between the `build` and `install` phases
+             ;; so that we have racket to read and write the hash table,
+             ;; but it comes before `raco setup`, when foreign libraries
+             ;; are needed to build the documentation.
+             (define out (assoc-ref outputs "out"))
+             (apply invoke
+                    "./cs/c/racketcs"
+                    "-e"
+                    ,(format #f
+                             "~s"
+                             '(let* ((args
+                                      (vector->list
+                                       (current-command-line-arguments)))
+                                     (file (car args))
+                                     (extra-lib-search-dirs (cdr args)))
+                                (write-to-file
+                                 (hash-update
+                                  (file->value file)
+                                  'lib-search-dirs
+                                  (lambda (dirs)
+                                    (append dirs extra-lib-search-dirs))
+                                  null)
+                                 #:exists 'truncate/replace
+                                 file)))
+                    "--"
+                    "../etc/config.rktd"
+                    (filter-map (lambda (lib)
+                                  (cond
+                                   ((assoc-ref inputs lib)
+                                    => (lambda (pth)
+                                         (string-append pth "/lib")))
+                                   (else
+                                    #f)))
+                                '("cairo"
+                                  "fontconfig"
+                                  "glib"
+                                  "glu"
+                                  "gmp"
+                                  "gtk+"
+                                  "libjpeg"
+                                  "libpng"
+                                  "libx11"
+                                  "mesa"
+                                  "mpfr"
+                                  "openssl"
+                                  "pango"
+                                  "sqlite"
+                                  "unixodbc"
+                                  "libedit")))
+             #t)))
        ;; XXX: how to run them?
        #:tests? #f))
     (inputs
-     `(;; Hardcode dynamically loaded libraries for better functionality.
-       ;; sqlite and libraries for `racket/draw' are needed to build the doc.
+     `(;; sqlite and libraries for `racket/draw' are needed to build the doc.
+       ("sh" ,bash-minimal)
        ("zlib" ,zlib)
        ("zlib:static" ,zlib "static")
        ("lz4" ,lz4)
@@ -571,29 +562,21 @@ of languages such as Typed Racket, R5RS and R6RS Scheme, and Datalog.")
     (inherit racket)
     (name "racket-minimal")
     (version (package-version racket))
-    (source (origin
-              (method url-fetch)
-              (uri (list (string-append "https://mirror.racket-lang.org/installers/"
-                                        version "/racket-minimal-src.tgz")
-                         ;; this mirror seems to have broken HTTPS:
-                         (string-append
-                          "http://mirror.informatik.uni-tuebingen.de/mirror/racket/"
-                          version "/racket-minimal-src.tgz")))
-              (sha256
-               (base32
-                "0mwyffw4gcci8wmzxa3j28h03h0gsz55aard8qrk3lri8r2xyg21"))
-              (patches (search-patches
-                        "racket-store-checksum-override.patch"))))
+    (source
+     (origin
+       (inherit (package-source racket))
+       (uri (list (string-append "https://mirror.racket-lang.org/installers/"
+                                 version "/racket-minimal-src.tgz")
+                  ;; this mirror seems to have broken HTTPS:
+                  (string-append
+                   "http://mirror.informatik.uni-tuebingen.de/mirror/racket/"
+                   version "/racket-minimal-src.tgz")))
+       (sha256 "0mwyffw4gcci8wmzxa3j28h03h0gsz55aard8qrk3lri8r2xyg21")))
     (synopsis "Racket without bundled packages such as Dr. Racket")
-    (arguments
-     (substitute-keyword-arguments (package-arguments racket)
-       ((#:phases phases)
-        `(modify-phases ,phases
-           ;; Delete fix that applies to files not included in the minimal package.
-           (delete 'pre-configure)))))
     (inputs
      `(("openssl" ,openssl)
        ("sqlite" ,sqlite)
+       ("sh" ,bash-minimal)
        ("zlib" ,zlib)
        ("zlib:static" ,zlib "static")
        ("lz4" ,lz4)