From 0bb872b379a98e4523c8f8d946e581bad1c4c323 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Tue, 25 Oct 2022 23:17:09 -0400
Subject: 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.
---
 gnu/build/install.scm | 60 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 40 insertions(+), 20 deletions(-)

(limited to 'gnu/build')

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index f5c8407b89..33a9616c0d 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,19 +57,24 @@ (define (install-boot-config bootcfg bootcfg-location mount-point)
 (define* (evaluate-populate-directive directive target
                                       #:key
                                       (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
 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,
-'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))
     (catch 'system-error
       (lambda ()
         (match directive
           (('directory name)
-           (mkdir-p (string-append target name)))
+           (mkdir-p (string-append target* name)))
           (('directory name uid gid)
-           (let ((dir (string-append target name)))
+           (let ((dir (string-append target* name)))
              (mkdir-p dir)
              ;; If called from a context without "root" permissions, "chown"
              ;; to root will fail.  In that case, do not try to run "chown"
@@ -78,27 +84,38 @@ (define* (evaluate-populate-directive directive target
                  (chown dir uid gid))))
           (('directory name uid gid mode)
            (loop `(directory ,name ,uid ,gid))
-           (chmod (string-append target name) mode))
+           (chmod (string-append target* name) mode))
           (('file name)
-           (call-with-output-file (string-append target name)
+           (call-with-output-file (string-append target* name)
              (const #t)))
           (('file name (? string? content))
-           (call-with-output-file (string-append target name)
+           (call-with-output-file (string-append target* name)
              (lambda (port)
                (display content port))))
           ((new '-> old)
-           (let try ()
-             (catch 'system-error
-               (lambda ()
-                 (symlink old (string-append target 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 (string-append target new))
-                       (try))
-                     (apply throw args))))))))
+           (let ((new* (string-append target* new)))
+             (let try ()
+               (catch 'system-error
+                 (lambda ()
+                   (when error-on-dangling-symlink?
+                     ;; When the symbolic link points to a relative path,
+                     ;; checking if its target exists must be done relatively
+                     ;; to the link location.
+                     (unless (if (string-prefix? "/" old)
+                                 (file-exists? old)
+                                 (with-directory-excursion (dirname new*)
+                                   (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
         ;; Usually we can only get here when installing to an existing root,
         ;; as with 'guix system init foo.scm /'.
@@ -142,7 +159,10 @@ (define* (populate-root-file-system system target
 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
 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))
 
   ;; Add system generation 1.
-- 
cgit v1.2.3