aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/install.scm45
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")))