diff options
| -rw-r--r-- | gnu/build/install.scm | 45 |
1 files changed, 33 insertions, 12 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm index e16896f8b8..7c4a7b7753 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -56,18 +56,38 @@ MOUNT-POINT." "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." (let loop ((directive directive)) - (match directive - (('directory name) - (mkdir-p (string-append target name))) - (('directory name uid gid) - (let ((dir (string-append target name))) - (mkdir-p dir) - (chown dir uid gid))) - (('directory name uid gid mode) - (loop `(directory ,name ,uid ,gid)) - (chmod (string-append target name) mode)) - ((new '-> old) - (symlink old (string-append target new)))))) + (catch 'system-error + (lambda () + (match directive + (('directory name) + (mkdir-p (string-append target name))) + (('directory name uid gid) + (let ((dir (string-append target name))) + (mkdir-p dir) + (chown dir uid gid))) + (('directory name uid gid mode) + (loop `(directory ,name ,uid ,gid)) + (chmod (string-append target name) mode)) + ((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)))))))) + (lambda args + ;; Usually we can only get here when installing to an existing root, + ;; as with 'guix system init foo.scm /'. + (format (current-error-port) + "error: failed to evaluate directive: ~s~%" + directive) + (apply throw args))))) (define (directives store) "Return a list of directives to populate the root file system that will host @@ -106,6 +126,7 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM." (directives (%store-directory))) ;; Add system generation 1. + (false-if-exception (delete-file "/var/guix/profiles/system-1-link")) (symlink system (string-append target "/var/guix/profiles/system-1-link"))) |