A modules/ruther/build/environment.scm => modules/ruther/build/environment.scm +118 -0
@@ 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)))
A modules/ruther/build/utils.scm => modules/ruther/build/utils.scm +11 -0
@@ 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"))))
M modules/ruther/environment.scm => modules/ruther/environment.scm +38 -27
@@ 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)