mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
shell: Detect --symlink spec problems early.
* guix/scripts/pack.scm (symlink-spec-option-parser): Remove extraneous char-set. Raise an exception when the target is an absolute file name. (guix-pack): Move with-error-handler earlier. * guix/scripts/shell.scm (guix-shell): Likewise. * guix/scripts/environment.scm (guix-environment): Wrap the whole guix-environment* call with the with-error-handling handler. * tests/guix-environment-container.sh: Add tests. * tests/guix-pack.sh: Adjust symlink spec.
This commit is contained in:
Maxim Cournoyer
parent
b31ea797ed
commit
788602b37f
5 changed files with 258 additions and 237 deletions
|
|
@ -42,6 +42,7 @@
|
|||
#:use-module (guix profiles)
|
||||
#:use-module (guix describe)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix search-paths)
|
||||
#:use-module (guix build-system gnu)
|
||||
#:use-module (guix scripts build)
|
||||
|
|
@ -59,6 +60,7 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (symlink-spec-option-parser
|
||||
|
|
@ -163,12 +165,27 @@ its source property."
|
|||
((names ... _) (loop names))))))
|
||||
|
||||
(define (symlink-spec-option-parser opt name arg result)
|
||||
"A SRFI-37 option parser for the --symlink option."
|
||||
"A SRFI-37 option parser for the --symlink option. The symlink spec accepts
|
||||
the link file name as its left-hand side value and its target as its
|
||||
right-hand side value. The target must be a relative link."
|
||||
;; 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 #\=))
|
||||
(match (string-split arg #\=)
|
||||
((source target)
|
||||
(when (string-prefix? "/" target)
|
||||
(raise-exception
|
||||
(make-compound-condition
|
||||
(formatted-message (G_ "symlink target is absolute: '~a'~%") target)
|
||||
(condition
|
||||
(&fix-hint (hint (format #f (G_ "The target of the symlink must be
|
||||
relative rather than absolute, as it is relative to the profile created.
|
||||
Perhaps the source and target components of the symlink spec were inverted?
|
||||
Below is a valid example, where the @file{/usr/bin/env} symbolic link is to
|
||||
target the profile's @file{bin/env} file:
|
||||
@example
|
||||
--symlink=/usr/bin/env=bin/env
|
||||
@end example"))))))))
|
||||
(let ((symlinks (assoc-ref result 'symlinks)))
|
||||
(alist-cons 'symlinks
|
||||
`((,source -> ,target) ,@symlinks)
|
||||
|
|
@ -1326,74 +1343,74 @@ Create a bundle of PACKAGE.\n"))
|
|||
(category development)
|
||||
(synopsis "create application bundles")
|
||||
|
||||
(define opts
|
||||
(parse-command-line args %options (list %default-options)))
|
||||
|
||||
(define maybe-package-argument
|
||||
;; Given an option pair, return a package, a package/output tuple, or #f.
|
||||
(match-lambda
|
||||
(('argument . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(specification->package+output spec))
|
||||
list))
|
||||
(('expression . exp)
|
||||
(read/eval-package-expression exp))
|
||||
(x #f)))
|
||||
|
||||
(define (manifest-from-args store opts)
|
||||
(let* ((transform (options->transformation opts))
|
||||
(packages (map (match-lambda
|
||||
(((? package? package) output)
|
||||
(list (transform package) output))
|
||||
((? package? package)
|
||||
(list (transform package) "out")))
|
||||
(reverse
|
||||
(filter-map maybe-package-argument opts))))
|
||||
(manifests (filter-map (match-lambda
|
||||
(('manifest . file) file)
|
||||
(_ #f))
|
||||
opts)))
|
||||
(define with-provenance
|
||||
(if (assoc-ref opts 'save-provenance?)
|
||||
(lambda (manifest)
|
||||
(map-manifest-entries
|
||||
(lambda (entry)
|
||||
(let ((entry (manifest-entry-with-provenance entry)))
|
||||
(unless (assq 'provenance (manifest-entry-properties entry))
|
||||
(warning (G_ "could not determine provenance of package ~a~%")
|
||||
(manifest-entry-name entry)))
|
||||
entry))
|
||||
manifest))
|
||||
identity))
|
||||
|
||||
(with-provenance
|
||||
(cond
|
||||
((and (not (null? manifests)) (not (null? packages)))
|
||||
(leave (G_ "both a manifest and a package list were given~%")))
|
||||
((not (null? manifests))
|
||||
(concatenate-manifests
|
||||
(map (lambda (file)
|
||||
(let ((user-module (make-user-module
|
||||
'((guix profiles) (gnu)))))
|
||||
(load* file user-module)))
|
||||
manifests)))
|
||||
(else
|
||||
(packages->manifest packages))))))
|
||||
|
||||
(define (process-file-arg opts name)
|
||||
;; Validate that the file exists and return it as a <local-file> object,
|
||||
;; else #f.
|
||||
(let ((value (assoc-ref opts name)))
|
||||
(match value
|
||||
((and (? string?) (not (? file-exists?)))
|
||||
(leave (G_ "file provided with option ~a does not exist: ~a~%")
|
||||
(string-append "--" (symbol->string name)) value))
|
||||
((? string?)
|
||||
(local-file value))
|
||||
(#f #f))))
|
||||
|
||||
(with-error-handling
|
||||
(define opts
|
||||
(parse-command-line args %options (list %default-options)))
|
||||
|
||||
(define maybe-package-argument
|
||||
;; Given an option pair, return a package, a package/output tuple, or #f.
|
||||
(match-lambda
|
||||
(('argument . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(specification->package+output spec))
|
||||
list))
|
||||
(('expression . exp)
|
||||
(read/eval-package-expression exp))
|
||||
(x #f)))
|
||||
|
||||
(define (manifest-from-args store opts)
|
||||
(let* ((transform (options->transformation opts))
|
||||
(packages (map (match-lambda
|
||||
(((? package? package) output)
|
||||
(list (transform package) output))
|
||||
((? package? package)
|
||||
(list (transform package) "out")))
|
||||
(reverse
|
||||
(filter-map maybe-package-argument opts))))
|
||||
(manifests (filter-map (match-lambda
|
||||
(('manifest . file) file)
|
||||
(_ #f))
|
||||
opts)))
|
||||
(define with-provenance
|
||||
(if (assoc-ref opts 'save-provenance?)
|
||||
(lambda (manifest)
|
||||
(map-manifest-entries
|
||||
(lambda (entry)
|
||||
(let ((entry (manifest-entry-with-provenance entry)))
|
||||
(unless (assq 'provenance (manifest-entry-properties entry))
|
||||
(warning (G_ "could not determine provenance of package ~a~%")
|
||||
(manifest-entry-name entry)))
|
||||
entry))
|
||||
manifest))
|
||||
identity))
|
||||
|
||||
(with-provenance
|
||||
(cond
|
||||
((and (not (null? manifests)) (not (null? packages)))
|
||||
(leave (G_ "both a manifest and a package list were given~%")))
|
||||
((not (null? manifests))
|
||||
(concatenate-manifests
|
||||
(map (lambda (file)
|
||||
(let ((user-module (make-user-module
|
||||
'((guix profiles) (gnu)))))
|
||||
(load* file user-module)))
|
||||
manifests)))
|
||||
(else
|
||||
(packages->manifest packages))))))
|
||||
|
||||
(define (process-file-arg opts name)
|
||||
;; Validate that the file exists and return it as a <local-file> object,
|
||||
;; else #f.
|
||||
(let ((value (assoc-ref opts name)))
|
||||
(match value
|
||||
((and (? string?) (not (? file-exists?)))
|
||||
(leave (G_ "file provided with option ~a does not exist: ~a~%")
|
||||
(string-append "--" (symbol->string name)) value))
|
||||
((? string?)
|
||||
(local-file value))
|
||||
(#f #f))))
|
||||
|
||||
(with-store store
|
||||
(with-status-verbosity (assoc-ref opts 'verbosity)
|
||||
;; Set the build options before we do anything else.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue