me
/
guix
Archived
1
0
Fork 0
Code

install: Validate symlink target in evaluate-populate-directive. 

* gnu/build/install.scm (evaluate-populate-directive): By default, error when
the target of a symlink doesn't exist.  Always ensure TARGET ends with "/".
(populate-root-file-system): Call evaluate-populate-directive with
 #:error-on-dangling-symlink #t and add comment.
Maxim Cournoyer 2022-10-25 23:17:09 -04:00
parent 8934827014
commit 0bb872b379
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
1 changed files with 40 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
gnu/build/install.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -56,19 +57,24 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
(define* (evaluate-populate-directive directive target (define* (evaluate-populate-directive directive target
#:key #:key
(default-gid 0) (default-gid 0)
(default-uid 0)) (default-uid 0)
(error-on-dangling-symlink? #t))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller. If the directive matches those defaults then, the context of the caller. If the directive matches those defaults then,
'chown' won't be run." 'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
error when a dangling symlink would be created."
(define target* (if (string-suffix? "/" target)
target
(string-append target "/")))
(let loop ((directive directive)) (let loop ((directive directive))
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(match directive (match directive
(('directory name) (('directory name)
(mkdir-p (string-append target name))) (mkdir-p (string-append target* name)))
(('directory name uid gid) (('directory name uid gid)
(let ((dir (string-append target name))) (let ((dir (string-append target* name)))
(mkdir-p dir) (mkdir-p dir)
;; If called from a context without "root" permissions, "chown" ;; If called from a context without "root" permissions, "chown"
;; to root will fail. In that case, do not try to run "chown" ;; to root will fail. In that case, do not try to run "chown"
@ -78,27 +84,38 @@ the context of the caller. If the directive matches those defaults then,
(chown dir uid gid)))) (chown dir uid gid))))
(('directory name uid gid mode) (('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid)) (loop `(directory ,name ,uid ,gid))
(chmod (string-append target name) mode)) (chmod (string-append target* name) mode))
(('file name) (('file name)
(call-with-output-file (string-append target name) (call-with-output-file (string-append target* name)
(const #t))) (const #t)))
(('file name (? string? content)) (('file name (? string? content))
(call-with-output-file (string-append target name) (call-with-output-file (string-append target* name)
(lambda (port) (lambda (port)
(display content port)))) (display content port))))
((new '-> old) ((new '-> old)
(let try () (let ((new* (string-append target* new)))
(catch 'system-error (let try ()
(lambda () (catch 'system-error
(symlink old (string-append target new))) (lambda ()
(lambda args (when error-on-dangling-symlink?
;; When doing 'guix system init' on the current '/', some ;; When the symbolic link points to a relative path,
;; symlinks may already exists. Override them. ;; checking if its target exists must be done relatively
(if (= EEXIST (system-error-errno args)) ;; to the link location.
(begin (unless (if (string-prefix? "/" old)
(delete-file (string-append target new)) (file-exists? old)
(try)) (with-directory-excursion (dirname new*)
(apply throw args)))))))) (file-exists? old)))
(error (format #f "symlink `~a' points to nonexistent \
file `~a'" new* old))))
(symlink old new*))
(lambda args
;; When doing 'guix system init' on the current '/', some
;; symlinks may already exists. Override them.
(if (= EEXIST (system-error-errno args))
(begin
(delete-file new*)
(try))
(apply throw args)))))))))
(lambda args (lambda args
;; Usually we can only get here when installing to an existing root, ;; Usually we can only get here when installing to an existing root,
;; as with 'guix system init foo.scm /'. ;; as with 'guix system init foo.scm /'.
@ -142,7 +159,10 @@ STORE."
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM. includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate EXTRAS is a list of directives appended to the built-in directives to populate
TARGET." TARGET."
(for-each (cut evaluate-populate-directive <> target) ;; It's expected that some symbolic link targets do not exist yet, so do not
;; error on dangling links.
(for-each (cut evaluate-populate-directive <> target
#:error-on-dangling-symlink? #f)
(append (directives (%store-directory)) extras)) (append (directives (%store-directory)) extras))
;; Add system generation 1. ;; Add system generation 1.