From a4888e2e0fb010836930f09a3822580a04fd7e82 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 10 Sep 2014 21:39:47 +0200
Subject: install: Gracefully handle corner cases with 'guix system init foo
 /'.

* gnu/build/install.scm (evaluate-populate-directive): Wrap body in
  "catch 'system-error", and report clear errors.  In the symlink case,
  retry up EEXIST.
  (populate-root-file-system): Remove /var/guix/profiles/system-1-link
  before attempting to create it.
---
 gnu/build/install.scm | 45 +++++++++++++++++++++++++++++++++------------
 1 file changed, 33 insertions(+), 12 deletions(-)

(limited to 'gnu/build')

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 @@ (define (evaluate-populate-directive directive target)
   "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 @@ (define (populate-root-file-system system target)
             (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")))
 
-- 
cgit v1.2.3