From 7db83c5ef902537051a2836fe6754a689ad26bc0 Mon Sep 17 00:00:00 2001 From: Rutherther Date: Thu, 17 Jul 2025 18:13:27 +0800 Subject: [PATCH] feat: Replace original paths in extra files with the ones in environment This is for example usable for share/application desktop files, to point to the environment binary instead of the original binary. Then the program will be started with environment from the environment package. --- modules/ruther/build/environment.scm | 118 +++++++++++++++++++++++++++ modules/ruther/build/utils.scm | 11 +++ modules/ruther/environment.scm | 65 +++++++++------ 3 files changed, 167 insertions(+), 27 deletions(-) create mode 100644 modules/ruther/build/environment.scm create mode 100644 modules/ruther/build/utils.scm diff --git a/modules/ruther/build/environment.scm b/modules/ruther/build/environment.scm new file mode 100644 index 0000000000000000000000000000000000000000..65dea18a4519ff4a928f49538d5f0476701f78be --- /dev/null +++ b/modules/ruther/build/environment.scm @@ -0,0 +1,118 @@ +(define-module (ruther build environment) + #:use-module (srfi srfi-1) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (guix build utils) + #:use-module (guix build union) + #:use-module (ruther build utils) + + #:export (make-profile-wrapper-script + unsymlink + ensure-file-writable + file-has-binary-path? + file-replace-binary-paths + file-replace-binary-paths-maybe + patch-extra-files + copy-extra-files + copy-binary-files)) + +(define (make-profile-wrapper-script source-file input-file output-file) + "Make a wrapper script at output-file that will source the source-file +and exec input-file" + (call-with-output-file output-file + (lambda (port) + (format port "!#~a~%" + (search-path (search-path-as-string->list (getenv "TARGET")) + "bash")) + (format port "source ~a~%" source-file) + (format port "exec ~a \"$@\"~%" input-file))) + (chmod output-file #o555)) + +(define (unsymlink link) + "Make sure the file is writable by " + + (define (absolute? file) + (string-prefix? "/" file)) + + (let ((target (match (readlink link) + ((? absolute? target) + target) + ((? string? relative) + (string-append (dirname link) "/" relative))))) + (delete-file link) + (copy-file target link))) + +(define (ensure-file-writable file) + ;; TODO: add writable permission + (when (symbolic-link? file) + (unsymlink file))) + +;; Iterate all files in extra-paths... check if the file contains any of 'profile-binaries' +;; if yes, ensure file writable and substitute it +(define (file-has-binary-path? file binaries) + (call-with-input-file file + (lambda (port) + (let loop ((line (get-line port))) + ;; if there is a /gnu/store, then look if the binary paths are present + (if (eof-object? line) + #f + (if (string-contains line (%store-directory)) + (if (any (lambda (binary-path) + (string-contains line binary-path)) + (map car binaries)) + #t + (loop (get-line port))) + (loop (get-line port)))))))) + +(define (file-replace-binary-paths file binaries) + (format (current-output-port) "Replacing binary paths in ~a~%" file) + (ensure-file-writable file) + (for-each (lambda (binary) + (substitute* + file + (((car binary)) (car (cdr binary))))) + binaries)) + +(define (file-replace-binary-paths-maybe file binaries) + (when (file-has-binary-path? file binaries) + (file-replace-binary-paths file binaries))) + +(define (patch-extra-files output binaries) + (format (current-output-port) "Going to patch files in ~a~%" output) + (ftw + output + (lambda (file stat flag) + (match flag + ('regular + (when (file-is-text-file? file) + (file-replace-binary-paths-maybe file binaries))) + (_ #f)) + #t))) + +(define (copy-extra-files output profile-path extra-folders) + (for-each + (lambda (extra-path) + (when (string-contains extra-path "/") + (mkdir-p (string-append output "/" (dirname extra-path)))) + (union-build (string-append output "/" extra-path) + (list (string-append profile-path "/" extra-path)) + #:create-all-directories? #t)) + extra-folders)) + +(define* (copy-binary-files output + output-binary-folders + profile-path + binaries + #:key + (filter-function (const #t)) + (rename-function identity)) + (for-each mkdir-p output-binary-folders) + (for-each + (lambda (binary) + (make-profile-wrapper-script + (string-append profile-path "/etc/profile") + (string-append profile-path "/" binary) + (string-append output "/" (dirname binary) "/" (rename-function (basename binary))))) + (filter filter-function binaries))) diff --git a/modules/ruther/build/utils.scm b/modules/ruther/build/utils.scm new file mode 100644 index 0000000000000000000000000000000000000000..e0f327e81552437d7cdec687316f058d3714e18e --- /dev/null +++ b/modules/ruther/build/utils.scm @@ -0,0 +1,11 @@ +(define-module (ruther build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 textual-ports) + #:export (file-is-text-file?)) + +(define (file-is-text-file? file) + (let* ((port + (open-input-pipe (string-append "file -b0 --mime-encoding " (canonicalize-path file)))) + (output (get-string-all port))) + (close-pipe port) + (not (string-contains output "binary")))) diff --git a/modules/ruther/environment.scm b/modules/ruther/environment.scm index df6813944b4364aa824d7369e67b56c0afe5b8e0..199bf1b8e87eb55e07448e6f003f307e6ce20520 100644 --- a/modules/ruther/environment.scm +++ b/modules/ruther/environment.scm @@ -1,12 +1,15 @@ (define-module (ruther environment) + #:use-module (ruther modules) #:use-module (guix profiles) #:use-module (gnu packages) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix packages) #:use-module (guix build-system trivial) #:use-module (gnu packages bash) #:use-module (gnu packages python) #:use-module (gnu packages guile) + #:use-module (gnu packages file) #:export (make-environment make-interpreted-environment make-python-environment @@ -31,15 +34,21 @@ (version "0") (source #f) (build-system trivial-build-system) + (native-inputs + (list file)) (inputs (list bash)) (arguments (list - #:modules '((guix build utils)) + #:modules (source-module-closure + '((guix build utils) + (ruther build environment)) + #:select? ruther-module-name?) #:builder #~(begin (use-modules (guix build utils) - (ice-9 format) - (ice-9 ftw)) + (ruther build environment) + (ice-9 ftw) + (srfi srfi-1)) (mkdir-p #$output) ;; Iterate all binary-paths under profile and make scripts in output @@ -64,34 +73,36 @@ binary-folders))) (profile-binaries (map (lambda (binary) (string-append profile-path "/" binary)) - binaries))) + binaries)) + (output-binaries (map (lambda (binary) + (string-append #$output "/" binary)) + binaries)) + (profile-binaries-realpaths (map canonicalize-path profile-binaries)) + (extra-folders (list #$@extra-paths))) - (define (make-wrapper-script source-file input-file output-file) - (call-with-output-file output-file - (lambda (port) - (format port "!#~a/bin/bash~%" - #$(this-package-input "bash")) - (format port "source ~a~%" source-file) - (format port "exec ~a \"$@\"~%" input-file))) - (chmod output-file #o555)) + (set-path-environment-variable + "PATH" '("bin" "sbin") + (list + #$@(map (compose car cdr) + (package-native-inputs this-package)))) - (for-each mkdir-p output-binary-folders) - (for-each - (lambda (binary) - (make-wrapper-script - (string-append profile-path "/etc/profile") - (string-append profile-path "/" binary) - (string-append #$output "/" (dirname binary) "/" (#$rename-function (basename binary))))) - (filter #$filter-function binaries)) + (set-path-environment-variable + "TARGET" '("bin" "sbin") + (list + #$@(map (compose car cdr) + (package-inputs this-package)))) + + (copy-binary-files + #$output + output-binary-folders + profile-path + binaries + #:filter-function #$filter-function + #:rename-function #$rename-function) ;; Iterate all extra-paths and symlink them to output. - (for-each - (lambda (extra-path) - (when (string-contains extra-path "/") - (mkdir-p (string-append #$output "/" (dirname extra-path)))) - (symlink (string-append #$profile "/" extra-path) - (string-append #$output "/" extra-path))) - '#$extra-paths))))) + (copy-extra-files #$output profile-path extra-folders) + (patch-extra-files #$output (zip profile-binaries-realpaths output-binaries)))))) (synopsis #f) (description #f) (home-page #f)