From 65bad4d03684a32598e0c6fb3449e481e37acfde Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Mon, 19 Jul 2021 02:31:42 -0400 Subject: gnu: racket: Unbundle racket-minimal. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change takes advantage of improved support for layered and tethered installations in Racket 8.2. * gnu/packages/racket.scm (extend-layer): New private variable. This is a script for configuring a new config-tethered layer chaining to an existing Racket installation. * gnu/packages/racket.scm (racket)[source](snippet): Unbundle `racket-minimal`. [inputs]: Remove inputs that properly belong to `racket-minimal`. [native-inputs]: Add `racket-minimal` and `extend-layer`. [arguments]: Stop inheriting from `racket-minimal`. Add phase 'unpack-packages to move the sources and links file into place. Replace 'configure phase using `extend-layer`. Replace 'build phase using `raco setup`. Delete 'install phase. * gnu/packages/patches/racket-sh-via-rktio.patch: Rename to ... * gnu/packages/patches/racket-minimal-sh-via-rktio.patch: ... this file to placate `guix lint`. * gnu/local.mk (dist_patch_DATA): Update accordingly. * gnu/packages/racket.scm (racket-minimal)[source]: Likewise. Signed-off-by: Ludovic Courtès --- gnu/local.mk | 2 +- .../patches/racket-minimal-sh-via-rktio.patch | 87 ++++++++++ gnu/packages/patches/racket-sh-via-rktio.patch | 87 ---------- gnu/packages/racket.scm | 193 ++++++++++++++++++++- 4 files changed, 275 insertions(+), 94 deletions(-) create mode 100644 gnu/packages/patches/racket-minimal-sh-via-rktio.patch delete mode 100644 gnu/packages/patches/racket-sh-via-rktio.patch (limited to 'gnu') diff --git a/gnu/local.mk b/gnu/local.mk index 450d9574b0..c530507b1a 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -1685,7 +1685,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-minimal-sh-via-rktio.patch \ %D%/packages/patches/remake-impure-dirs.patch \ %D%/packages/patches/retroarch-LIBRETRO_DIRECTORY.patch \ %D%/packages/patches/rnp-add-version.cmake.patch \ diff --git a/gnu/packages/patches/racket-minimal-sh-via-rktio.patch b/gnu/packages/patches/racket-minimal-sh-via-rktio.patch new file mode 100644 index 0000000000..b4fefd1514 --- /dev/null +++ b/gnu/packages/patches/racket-minimal-sh-via-rktio.patch @@ -0,0 +1,87 @@ +From 3574b567c486d264d680a37586436c3b5a8cb978 Mon Sep 17 00:00:00 2001 +From: Philip McGrath +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) + diff --git a/gnu/packages/patches/racket-sh-via-rktio.patch b/gnu/packages/patches/racket-sh-via-rktio.patch deleted file mode 100644 index b4fefd1514..0000000000 --- a/gnu/packages/patches/racket-sh-via-rktio.patch +++ /dev/null @@ -1,87 +0,0 @@ -From 3574b567c486d264d680a37586436c3b5a8cb978 Mon Sep 17 00:00:00 2001 -From: Philip McGrath -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) - diff --git a/gnu/packages/racket.scm b/gnu/packages/racket.scm index 6b2a011d51..490619d517 100644 --- a/gnu/packages/racket.scm +++ b/gnu/packages/racket.scm @@ -73,7 +73,7 @@ %installer-mirrors)) (sha256 "13qfg56w554vdj5iwa8lpacy83s7bzhhyr44pjns68mkhj69ring") (patches (search-patches - "racket-sh-via-rktio.patch")))) + "racket-minimal-sh-via-rktio.patch")))) (home-page "https://racket-lang.org") (synopsis "Racket without bundled packages such as DrRacket") (inputs @@ -183,10 +183,52 @@ DrRacket IDE, are not included.") %installer-mirrors)) (sha256 (base32 - "10sgzsraxzxp1k2y2wvz8rcjwvhbcd6k72l9lyqr34yazlwfdz26")))) + "10sgzsraxzxp1k2y2wvz8rcjwvhbcd6k72l9lyqr34yazlwfdz26")) + (snippet + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 regex)) + ;; unbundle minimal Racket + (for-each delete-file-recursively + '("collects" + "doc" + "etc" + "README" + "src")) + ;; unbundle package sources included elsewhere + (define (substitute/delete file pattern) + (substitute + file + (list (cons pattern + (lambda (line matches) + ;; must match exactly once + (match matches + ((m) + (string-append (match:prefix m) + (match:suffix m))))))))) + (define (unbundle-pkg pkg) + (define quoted-pkg (regexp-quote pkg)) + (with-directory-excursion "share" + (substitute/delete + "links.rktd" + (string-append + "[(][^()]+[(]#\"pkgs\" #\"" + quoted-pkg + "\"[)][)]")) + (with-directory-excursion "pkgs" + (substitute/delete + "pkgs.rktd" + (string-append + "[(]\"" + quoted-pkg + "\" \\. #s[(]" + "(pkg-info|[(]sc-pkg-info pkg-info 3[)])" + " [(][^()]+[)] [^()]+[)][)]")) + (delete-file-recursively pkg)))) + (unbundle-pkg "racket-lib"))))) (inputs - `(;; sqlite and libraries for `racket/draw' are needed to build the doc. - ("cairo" ,cairo) + `(("cairo" ,cairo) ("fontconfig" ,fontconfig) ("glib" ,glib) ("glu" ,glu) @@ -199,8 +241,67 @@ DrRacket IDE, are not included.") ("mpfr" ,mpfr) ("pango" ,pango) ("unixodbc" ,unixodbc) - ("libedit" ,libedit) - ,@(package-inputs racket-minimal))) + ("libedit" ,libedit))) + (native-inputs + `(("racket" ,racket-minimal) + ("extend-layer" ,extend-layer))) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-before 'configure 'unpack-packages + (lambda* (#:key native-inputs inputs outputs #:allow-other-keys) + (let ((racket (assoc-ref (or native-inputs inputs) "racket")) + (prefix (assoc-ref outputs "out"))) + (mkdir-p (string-append prefix "/share/racket/pkgs")) + (copy-recursively + "share/links.rktd" + (string-append prefix "/share/racket/links.rktd")) + (copy-recursively + "share/pkgs" + (string-append prefix "/share/racket/pkgs")) + #t))) + (replace 'configure + (lambda* (#:key native-inputs inputs outputs #:allow-other-keys) + (let ((racket (assoc-ref (or native-inputs inputs) "racket")) + (prefix (assoc-ref outputs "out"))) + (apply invoke + (string-append racket "/bin/racket") + (assoc-ref inputs "extend-layer") + racket + prefix + (map + (lambda (lib) + (string-append (assoc-ref inputs lib) "/lib")) + '("cairo" + "fontconfig" + "glib" + "glu" + "gmp" + "gtk+" + "libjpeg" + "libpng" + "libx11" + "mesa" + "mpfr" + "pango" + "unixodbc" + "libedit"))) + #t))) + (replace 'build + (lambda* (#:key native-inputs inputs outputs #:allow-other-keys) + (invoke (string-append (assoc-ref (or native-inputs inputs) + "racket") + "/bin/racket") + "--config" + (string-append (assoc-ref outputs "out") + "/etc/racket") + "-l" + "raco" + "setup") + #t)) + (delete 'install)) + ;; we still don't have these: + #:tests? #f)) (synopsis "A programmable programming language in the Scheme family") (description "Racket is a general-purpose programming language in the Scheme family, @@ -211,3 +312,83 @@ languages to complete language implementations. The main Racket distribution comes with many bundled packages, including the DrRacket IDE, libraries for GUI and web programming, and implementations of languages such as Typed Racket, R5RS and R6RS Scheme, Algol 60, and Datalog."))) + + +(define extend-layer + (scheme-file + "extend-layer.rkt" + `(module + extend-layer racket/base + (require racket/cmdline + racket/match + racket/file + racket/list + racket/pretty) + (define config-file-pth + "etc/racket/config.rktd") + (define (build-path-string . args) + (path->string (apply build-path args))) + (define rx:racket + ;; Guile's reader doesn't support #rx"racket" + (regexp "racket")) + (command-line + #:args (parent-layer prefix . lib-dir*) + (let* ([config + (for/fold + ([config (file->value (build-path parent-layer + config-file-pth))]) + ([spec (in-list + '((lib-dir lib-search-dirs "lib/racket") + (share-dir share-search-dirs "share/racket") + (links-file + links-search-files + "share/racket/links.rktd") + (pkgs-dir pkgs-search-dirs "share/racket/pkgs") + (bin-dir bin-search-dirs "bin") + (man-dir man-search-dirs "share/man") + (doc-dir doc-search-dirs "share/doc/racket") + (include-dir + include-search-dirs + "include/racket")))]) + (match-define (list main-key search-key pth) spec) + (hash-set* + config + main-key + (build-path-string prefix pth) + search-key + (list* #f + (hash-ref config + main-key + (build-path-string parent-layer pth)) + (filter values (hash-ref config search-key null)))))] + [config + (hash-set config + 'apps-dir + (build-path-string prefix "share/applications"))] + [config + ;; place new foreign lib-search-dirs before old + ;; foreign dirs, but after Racket layers + (let-values + ([(rkt extra) + (partition (lambda (pth) + (or (not pth) + (regexp-match? rx:racket pth))) + (hash-ref config 'lib-search-dirs))]) + (hash-set config + 'lib-search-dirs + (append rkt + lib-dir* + extra)))] + [bin-dir + (hash-ref config 'bin-dir)] + [config + (hash-set* config + 'config-tethered-console-bin-dir bin-dir + 'config-tethered-gui-bin-dir bin-dir)] + [new-config-pth + (build-path prefix config-file-pth)]) + (make-parent-directory* new-config-pth) + (call-with-output-file* + new-config-pth + (lambda (out) + (pretty-write config out)))))))) -- cgit v1.2.3