diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/scripts/environment.scm | 43 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 39 |
2 files changed, 55 insertions, 27 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index de9bc8f98d..13c6f6cb5c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,8 +33,10 @@ #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix scripts pack) (symlink-spec-option-parser) #:use-module (guix transformations) #:autoload (ice-9 ftw) (scandir) + #:use-module (gnu build install) #:autoload (gnu build linux-container) (call-with-container %namespaces user-namespace-supported? unprivileged-user-namespace-supported? @@ -120,6 +122,9 @@ shell'." --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -S, --symlink=SPEC for containers, add symlinks to the profile according + to SPEC, e.g. \"/usr/bin/env=bin/env\".")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use bootstrap binaries to build the environment"))) @@ -157,6 +162,7 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (symlinks . ()) (offload? . #t) (graft? . #t) (print-build-trace? . #t) @@ -256,6 +262,7 @@ use '--preserve' instead~%")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -672,7 +679,7 @@ regexps in WHITE-LIST." (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? map-cwd? emulate-fhs? (setup-hook #f) - (white-list '())) + (symlinks '()) (white-list '())) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the store. When @@ -690,6 +697,9 @@ with the EMULATE-FHS? option. LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the environment profile. +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the container. + Preserve environment variables whose name matches the one of the regexps in WHILE-LIST." (define (optional-mapping->fs mapping) @@ -797,6 +807,15 @@ WHILE-LIST." (mkdir-p home-dir) (setenv "HOME" home-dir) + ;; Create symlinks. + (let ((symlink->directives + (match-lambda + ((source '-> target) + `((directory ,(dirname source)) + (,source -> ,(string-append profile "/" target))))))) + (for-each (cut evaluate-populate-directive <> ".") + (append-map symlink->directives symlinks))) + ;; Call an additional setup procedure, if provided. (when setup-hook (setup-hook profile)) @@ -970,6 +989,7 @@ command-line option processing with 'parse-command-line'." (let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) + (symlinks (assoc-ref opts 'symlinks)) (network? (assoc-ref opts 'network?)) (no-cwd? (assoc-ref opts 'no-cwd?)) (emulate-fhs? (assoc-ref opts 'emulate-fhs?)) @@ -1010,15 +1030,17 @@ command-line option processing with 'parse-command-line'." (when container? (assert-container-features)) - (when (and (not container?) link-prof?) - (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) - (when (and (not container?) user) - (leave (G_ "'--user' cannot be used without '--container'~%"))) - (when (and (not container?) no-cwd?) - (leave (G_ "--no-cwd cannot be used without '--container'~%"))) - (when (and (not container?) emulate-fhs?) - (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) - + (when (not container?) + (when link-prof? + (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) + (when user + (leave (G_ "'--user' cannot be used without '--container'~%"))) + (when no-cwd? + (leave (G_ "--no-cwd cannot be used without '--container'~%"))) + (when emulate-fhs? + (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) + (when (pair? symlinks) + (leave (G_ "'--symlink' cannot be used without '--container~%'")))) (with-store/maybe store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1099,6 +1121,7 @@ when using '--container'; doing nothing~%")) #:network? network? #:map-cwd? (not no-cwd?) #:emulate-fhs? emulate-fhs? + #:symlinks symlinks #:setup-hook (and emulate-fhs? setup-fhs)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 06849e4761..a611922db3 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -61,7 +61,9 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (self-contained-tarball + #:export (symlink-spec-option-parser + + self-contained-tarball debian-archive docker-image squashfs-image @@ -160,6 +162,21 @@ its source property." ((_) str) ((names ... _) (loop names)))))) +(define (symlink-spec-option-parser opt name arg result) + "A SRFI-37 option parser for the --symlink option." + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg (char-set #\=)) + ((source target) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (G_ "~a: invalid symlink specification~%") + arg)))) + ;;; ;;; Tarball format. @@ -226,8 +243,9 @@ its source property." `(,@(if (string=? parent "/") '() `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -1208,20 +1226,7 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) - (option '(#\S "symlink") #t #f - (lambda (opt name arg result) - ;; Note: Using 'string-split' allows us to handle empty - ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is - ;; a symlink to the profile) correctly. - (match (string-split arg (char-set #\=)) - ((source target) - (let ((symlinks (assoc-ref result 'symlinks))) - (alist-cons 'symlinks - `((,source -> ,target) ,@symlinks) - (alist-delete 'symlinks result eq?)))) - (x - (leave (G_ "~a: invalid symlink specification~%") - arg))))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) |