guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

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>
This commit is contained in:
Philip McGrath 2021-03-18 22:34:51 -04:00 committed by Ludovic Courtès
parent eb8da54170
commit 834aa48504
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 176 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gnu/local.mk
View File

@ -40,6 +40,7 @@
# Copyright © 2020 Malte Frank Gerdes <mate.f.gerdes@gmail.com>
# Copyright © 2020 Vinicius Monego <monego@posteo.net>
# Copyright © 2021 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
# Copyright © 2021 Philip McGrath <philip@philipmcgrath.com>
#
# This file is part of GNU Guix.
#
@ -1639,6 +1640,7 @@ dist_patch_DATA = \
%D%/packages/patches/ripperx-missing-file.patch \
%D%/packages/patches/rpcbind-CVE-2017-8779.patch \
%D%/packages/patches/rtags-separate-rct.patch \
%D%/packages/patches/racket-sh-via-rktio.patch \
%D%/packages/patches/racket-store-checksum-override.patch \
%D%/packages/patches/remake-impure-dirs.patch \
%D%/packages/patches/retroarch-LIBRETRO_DIRECTORY.patch \

87
gnu/packages/patches/racket-sh-via-rktio.patch Normal file
View File

@ -0,0 +1,87 @@
From 3574b567c486d264d680a37586436c3b5a8cb978 Mon Sep 17 00:00:00 2001
From: Philip McGrath <philip@philipmcgrath.com>
Date: Thu, 4 Mar 2021 04:11:50 -0500
Subject: [PATCH] patch rktio_process for "/bin/sh" on Guix
Racket provides the functions `system` and `process`,
which execute shell commands using `sh` (or `cmd` on Windows).
Racket assumes that `sh` can be found at "/bin/sh",
which is not necessarily true on Guix.
This patch adds a special case for "/bin/sh" to `rktio_process`,
the C function that implements the core of `system`, `process`,
and related Racket functions.
Guix should enable the special case by defining the C preprocessor
macro `GUIX_RKTIO_PATCH_BIN_SH` with the path to `sh` in the store.
If:
1. The `GUIX_RKTIO_PATCH_BIN_SH` macro is defined; and
2. `rktio_process` is called with the exact path "/bin/sh"; and
3. The path specified by `GUIX_RKTIO_PATCH_BIN_SH` does exists;
then `rktio_process` will execute the file specified
by `GUIX_RKTIO_PATCH_BIN_SH` instead of "/bin/sh".
Compared to previous attempts to patch the Racket sources,
making this change at the C level is both:
- More comprehensive: it catches all attempts to execute "/bin/sh",
without having to track down the source of every occurance; and
- Less intrusive: by guarding the special case with a C preprocessor
conditional and a runtime check that the file in the store exists,
we make it much less likely that it will "leak" out of Guix.
---
src/rktio/rktio_process.c | 21 ++++++++++++++++++++-
1 file changed, 20 insertions(+), 1 deletion(-)
diff --git a/src/rktio/rktio_process.c b/src/rktio/rktio_process.c
index 89202436c0..465ebdd5c5 100644
--- a/src/rktio/rktio_process.c
+++ b/src/rktio/rktio_process.c
@@ -1224,12 +1224,14 @@ int rktio_process_allowed_flags(rktio_t *rktio)
/*========================================================================*/
rktio_process_result_t *rktio_process(rktio_t *rktio,
- const char *command, int argc, rktio_const_string_t *argv,
+ /* PATCHED for Guix (next line) */
+ const char *_guix_orig_command, int argc, rktio_const_string_t *argv,
rktio_fd_t *stdout_fd, rktio_fd_t *stdin_fd, rktio_fd_t *stderr_fd,
rktio_process_t *group_proc,
const char *current_directory, rktio_envvars_t *envvars,
int flags)
{
+ const char *command; /* PATCHED for Guix */
rktio_process_result_t *result;
intptr_t to_subprocess[2], from_subprocess[2], err_subprocess[2];
int pid;
@@ -1255,6 +1257,23 @@ rktio_process_result_t *rktio_process(rktio_t *rktio,
int i;
#endif
+/* BEGIN PATCH for Guix */
+#if defined(GUIX_RKTIO_PATCH_BIN_SH)
+# define GUIX_AS_a_STR_HELPER(x) #x
+# define GUIX_AS_a_STR(x) GUIX_AS_a_STR_HELPER(x)
+ /* A level of indirection makes `#` work as needed: */
+ command =
+ ((0 == strcmp(_guix_orig_command, "/bin/sh"))
+ && rktio_file_exists(rktio, GUIX_AS_a_STR(GUIX_RKTIO_PATCH_BIN_SH)))
+ ? GUIX_AS_a_STR(GUIX_RKTIO_PATCH_BIN_SH)
+ : _guix_orig_command;
+# undef GUIX_AS_a_STR
+# undef GUIX_AS_a_STR_HELPER
+#else
+ command = _guix_orig_command;
+#endif
+/* END PATCH for Guix */
+
/* avoid compiler warnings: */
to_subprocess[0] = -1;
to_subprocess[1] = -1;
--
2.21.1 (Apple Git-122.3)

191
gnu/packages/scheme.scm
View File

@ -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)