Merge branch 'master' into staging

16 files changed, 136 insertions, 64 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 25726b885e..74cb675fcf 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -46,6 +46,14 @@
             MNT_DETACH
             MNT_EXPIRE
             UMOUNT_NOFOLLOW
+
+            AT_FDCWD
+            AT_SYMLINK_NOFOLLOW
+            AT_REMOVEDIR
+            AT_SYMLINK_FOLLOW
+            AT_NO_AUTOMOUNT
+            AT_EMPTY_PATH
+
             restart-on-EINTR
             mount-points
             swapon
@@ -667,6 +675,15 @@ mounted at FILE."
     (* (file-system-block-size fs)
        (file-system-blocks-available fs))))
 
+;; Flags for the *at command, notably the 'utime' procedure of libguile.
+;; From <fcntl.h>.
+(define AT_FDCWD             -100)
+(define AT_SYMLINK_NOFOLLOW #x100)
+(define AT_REMOVEDIR        #x200)
+(define AT_SYMLINK_FOLLOW   #x400)
+(define AT_NO_AUTOMOUNT     #x800)
+(define AT_EMPTY_PATH       #x1000)
+
 
 ;;;
 ;;; Containers.
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 65e0be45ab..c37afaf8e6 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -187,7 +187,9 @@ include VERSION."
              (url (package-source-url kind name ver repo)))
          (make-elpa-package name ver
                             (ensure-list reqs) synopsis kind
-                            (package-home-page (first rest))
+                            (package-home-page (match rest
+                                                 (() #f)
+                                                 ((one) one)))
                             (fetch-package-description kind name repo)
                             url)))
       (_ #f))))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ebd7da2a24..e6b77e8d38 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -703,6 +703,8 @@ MANIFEST."
     (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
   (define gzip                                    ;lazy reference
     (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
+  (define glibc-utf8-locales                      ;lazy reference
+    (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 
   (define build
     (with-imported-modules '((guix build utils))
@@ -720,11 +722,31 @@ MANIFEST."
               (map (cut string-append infodir "/" <>)
                    (or (scandir infodir info-file?) '()))))
 
+          (define (info-file-language file)
+            (let* ((base (if (string-suffix? ".gz" file)
+                             (basename file ".info.gz")
+                             (basename file ".info")))
+                   (dot  (string-rindex base #\.)))
+              (if dot
+                  (string-drop base (+ 1 dot))
+                  "en")))
+
           (define (install-info info)
-            (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
-            (zero?
-             (system* (string-append #+texinfo "/bin/install-info") "--silent"
-                      info (string-append #$output "/share/info/dir"))))
+            (let ((language (info-file-language info)))
+              ;; We need to choose a valid locale for $LANGUAGE to be honored.
+              (setenv "LC_ALL" "en_US.utf8")
+              (setenv "LANGUAGE" language)
+              (zero?
+               (system* #+(file-append texinfo "/bin/install-info")
+                        "--silent" info
+                        (apply string-append #$output "/share/info/dir"
+                               (if (string=? "en" language)
+                                   '("")
+                                   `("." ,language)))))))
+
+          (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
+          (setenv "GUIX_LOCPATH"
+                  #+(file-append glibc-utf8-locales "/lib/locale"))
 
           (mkdir-p (string-append #$output "/share/info"))
           (exit (every install-info
diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm
index 10aed2be75..8041d64b6b 100644
--- a/guix/scripts/container.scm
+++ b/guix/scripts/container.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,7 +55,7 @@ Build and manipulate Linux containers.\n"))
       ((or ("-h") ("--help"))
        (show-help)
        (exit 0))
-      (("--version")
+      ((or ("-V") ("--version"))
        (show-version-and-exit "guix container"))
       ((action args ...)
        (if (member action %actions)
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 67bc7a7553..f8cb85700d 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -104,7 +105,7 @@ Run IMPORTER with ARGS.\n"))
     ((or ("-h") ("--help"))
      (show-help)
      (exit 0))
-    (("--version")
+    ((or ("-V") ("--version"))
      (show-version-and-exit "guix import"))
     ((importer args ...)
      (if (member importer importers)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 7f087a3a3c..6d5d745bc8 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -722,6 +722,7 @@ Create a bundle of PACKAGE.\n"))
                                         (if (assoc-ref opts 'bootstrap?)
                                             %bootstrap-guile
                                             (canonical-package guile-2.2))
+                                        (assoc-ref opts 'system)
                                         #:graft? (assoc-ref opts 'graft?))))
         (let* ((dry-run?    (assoc-ref opts 'dry-run?))
                (relocatable? (assoc-ref opts 'relocatable?))
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index b7b53e43fb..344be40883 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -53,15 +53,6 @@
 (define substitutable-path-info*
   (store-lift substitutable-path-info))
 
-(define (query-path-info* item)
-  "Monadic version of 'query-path-info' that returns #f when ITEM is not in
-the store."
-  (lambda (store)
-    (guard (c ((nix-protocol-error? c)
-               ;; ITEM is not in the store; return #f.
-               (values #f store)))
-      (values (query-path-info store item) store))))
-
 (define (file-size item)
   "Return the size in bytes of ITEM, resorting to information from substitutes
 if ITEM is not in the store."
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index d0beacc8ea..7634bb37f6 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1108,7 +1109,7 @@ default value."
           (process-substitution store-path destination
                                 #:cache-urls (substitute-urls)
                                 #:acl (current-acl))))
-       (("--version")
+       ((or ("-V") ("--version"))
         (show-version-and-exit "guix substitute"))
        (("--help")
         (show-help))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 14aedceac1..69bd05b516 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -126,7 +126,11 @@ REFERENCES as its set of references."
     ;; Remove DEST if it exists to make sure that (1) we do not fail badly
     ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
     ;; (2) we end up with the right contents.
-    (when (file-exists? dest)
+    (when (false-if-exception (lstat dest))
+      (for-each make-file-writable
+                (find-files dest (lambda (file stat)
+                                   (eq? 'directory (stat:type stat)))
+                            #:directories? #t))
       (delete-file-recursively dest))
 
     (copy-recursively item dest
@@ -148,12 +152,18 @@ REFERENCES as its set of references."
   "Copy ITEM and all its dependencies to the store under root directory
 TARGET, and register them."
   (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
-                       (refs    (mapm %store-monad references* to-copy)))
+                       (refs    (mapm %store-monad references* to-copy))
+                       (info    (mapm %store-monad query-path-info*
+                                      (delete-duplicates
+                                       (append to-copy (concatenate refs)))))
+                       (size -> (reduce + 0 (map path-info-nar-size info))))
     (define progress-bar
       (progress-reporter/bar (length to-copy)
                              (format #f (G_ "copying to '~a'...")
                                      target)))
 
+    (check-available-space size target)
+
     (call-with-progress-reporter progress-bar
       (lambda (report)
         (let ((void (%make-void-port "w")))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index d7c2fbea10..98b7338fb9 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -269,7 +270,7 @@ Report the availability of substitutes.\n"))
                    (exit 0)))
          (option '(#\V "version") #f #f
                  (lambda args
-                   (show-version-and-exit "guix challenge")))
+                   (show-version-and-exit "guix weather")))
 
          (option '("substitute-urls") #t #f
                  (lambda (opt name arg result . rest)
diff --git a/guix/self.scm b/guix/self.scm
index 89c5428039..c9c7138e65 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -343,7 +343,7 @@ DOMAIN, a gettext domain."
 
 (define* (guix-command modules #:optional compiled-modules
                        #:key source (dependencies '())
-                       (guile-version (effective-version)))
+                       guile (guile-version (effective-version)))
   "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
 load path."
   (program-file "guix-command"
@@ -383,15 +383,17 @@ load path."
 
                       ;; XXX: It would be more convenient to change it to:
                       ;;   (exit (apply guix-main (command-line)))
-                      (apply guix-main (command-line))))))
+                      (apply guix-main (command-line))))
+                #:guile guile))
 
 (define* (whole-package name modules dependencies
                         #:key
                         (guile-version (effective-version))
                         compiled-modules
-                        info daemon
+                        info daemon guile
                         (command (guix-command modules
                                                #:dependencies dependencies
+                                               #:guile guile
                                                #:guile-version guile-version)))
   "Return the whole Guix package NAME that uses MODULES, a derivation of all
 the modules, and DEPENDENCIES, a list of packages depended on.  COMMAND is the
@@ -630,10 +632,12 @@ assumed to be part of MODULES."
                 (command  (guix-command modules compiled
                                         #:source source
                                         #:dependencies dependencies
+                                        #:guile guile-for-build
                                         #:guile-version guile-version)))
            (whole-package name modules dependencies
                           #:compiled-modules compiled
                           #:command command
+                          #:guile guile-for-build
 
                           ;; Include 'guix-daemon'.  XXX: Here we inject an
                           ;; older snapshot of guix-daemon, but that's a good
@@ -903,8 +907,10 @@ running Guile."
      (module-ref (resolve-interface '(gnu packages guile))
                  'guile-2.2.2))
     ("2.2"
+     ;; Use the latest version, which has fixes for
+     ;; <https://bugs.gnu.org/30602> and VM stack-marking issues.
      (canonical-package (module-ref (resolve-interface '(gnu packages guile))
-                                    'guile-2.2/fixed)))
+                                    'guile-2.2.4)))
     ("2.0"
      (module-ref (resolve-interface '(gnu packages guile))
                  'guile-2.0))))
diff --git a/guix/store.scm b/guix/store.scm
index 3bf56573bf..bac42f2738 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -107,6 +107,7 @@
             references
             references/substitutes
             references*
+            query-path-info*
             requisites
             referrers
             optimize-store
@@ -1398,6 +1399,15 @@ where FILE is the entry's absolute file name and STAT is the result of
 (define references*
   (store-lift references))
 
+(define (query-path-info* item)
+  "Monadic version of 'query-path-info' that returns #f when ITEM is not in
+the store."
+  (lambda (store)
+    (guard (c ((nix-protocol-error? c)
+               ;; ITEM is not in the store; return #f.
+               (values #f store)))
+      (values (query-path-info store item) store))))
+
 (define-inlinable (current-system)
   ;; Consult the %CURRENT-SYSTEM fluid at bind time.  This is equivalent to
   ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 05b2ba6c3f..8f35b63e37 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -209,9 +209,7 @@ it's a directory.  While at it, canonicalize file permissions."
                                 (type type))))))
                    (scandir* parent))))
       ((symlink)
-       ;; FIXME: Implement bindings for 'futime' to reset the timestamps on
-       ;; symlinks.
-       #f)
+       (utime file 0 0 0 0 AT_SYMLINK_NOFOLLOW))
       (else
        (chmod file (if (executable-file? file) #o555 #o444))
        (utime file 0 0 0 0)))))
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index d3139eb904..6ff4a50de5 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -88,28 +88,27 @@ LINK-PREFIX."
       (lambda args
         (if (= (system-error-errno args) EEXIST)
             (try (tempname-in link-prefix))
-            (throw 'system-error args))))))
+            (apply throw args))))))
 
 ;; There are 3 main kinds of errors we can get from hardlinking: "Too many
 ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
 ;; "can't fit more stuff in this directory" (ENOSPC).
 
-(define (replace-with-link target to-replace)
-  "Atomically replace the file TO-REPLACE with a link to TARGET.  Note: TARGET
-and TO-REPLACE must be on the same file system."
-  (let ((temp-link (get-temp-link target (dirname to-replace))))
-    (rename-file temp-link to-replace)))
+(define* (replace-with-link target to-replace
+                            #:key (swap-directory (dirname target)))
+  "Atomically replace the file TO-REPLACE with a link to TARGET.  Use
+SWAP-DIRECTORY as the directory to store temporary hard links.
 
-(define-syntax-rule (false-if-system-error (errors ...) exp ...)
-  "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and
-return #f if any of the system error codes in the given list are thrown."
-  (catch 'system-error
-    (lambda ()
-      exp ...)
-    (lambda args
-      (if (member (system-error-errno args) (list errors ...))
-          #f
-          (apply throw args)))))
+Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
+  (let ((temp-link (get-temp-link target swap-directory)))
+    (make-file-writable (dirname to-replace))
+    (catch 'system-error
+      (lambda ()
+        (rename-file temp-link to-replace))
+      (lambda args
+        (delete-file temp-link)
+        (unless (= EMLINK (system-error-errno args))
+          (apply throw args))))))
 
 (define* (deduplicate path hash #:key (store %store-directory))
   "Check if a store item with sha256 hash HASH already exists.  If so,
@@ -131,8 +130,8 @@ under STORE."
                                      #:store store))))
                   (scandir path))
         (if (file-exists? link-file)
-            (false-if-system-error (EMLINK)
-                                   (replace-with-link link-file path))
+            (replace-with-link link-file path
+                               #:swap-directory links-directory)
             (catch 'system-error
               (lambda ()
                 (link path link-file))
@@ -141,8 +140,8 @@ under STORE."
                   (cond ((= errno EEXIST)
                          ;; Someone else put an entry for PATH in
                          ;; LINKS-DIRECTORY before we could.  Let's use it.
-                         (false-if-system-error (EMLINK)
-                                                (replace-with-link path link-file)))
+                         (replace-with-link path link-file
+                                            #:swap-directory links-directory))
                         ((= errno ENOSPC)
                          ;; There's not enough room in the directory index for
                          ;; more entries in .links, but that's fine: we can
diff --git a/guix/ui.scm b/guix/ui.scm
index 6996b7f1c4..6a5feaa953 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
+;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -87,6 +88,7 @@
             leave-on-EPIPE
             read/eval
             read/eval-package-expression
+            check-available-space
             location->string
             fill-paragraph
             %text-width
@@ -519,6 +521,9 @@ FILE."
 (set! canonicalize-path
   (error-reporting-wrapper canonicalize-path (file) file))
 
+(set! delete-file
+  (error-reporting-wrapper delete-file (file) file))
+
 
 (define (make-regexp* regexp . flags)
   "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
@@ -795,16 +800,17 @@ error."
                   (derivation->output-path derivation out-name)))
                (derivation-outputs derivation))))
 
-(define (check-available-space need)
-  "Make sure at least NEED bytes are available in the store.  Otherwise emit a
+(define* (check-available-space need
+                                #:optional (directory (%store-prefix)))
+  "Make sure at least NEED bytes are available in DIRECTORY.  Otherwise emit a
 warning."
   (let ((free (catch 'system-error
                 (lambda ()
-                  (free-disk-space (%store-prefix)))
+                  (free-disk-space directory))
                 (const #f))))
     (when (and free (>= need free))
       (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%")
-               (/ need 1e6) (/ free 1e6) (%store-prefix)))))
+               (/ need 1e6) (/ free 1e6) directory))))
 
 (define* (show-what-to-build store drv
                              #:key dry-run? (use-substitutes? #t)
@@ -1593,7 +1599,7 @@ and signal handling has already been set up."
      (show-guix-usage))
     ((or ("-h") ("--help"))
      (show-guix-help))
-    (("--version")
+    ((or ("-V") ("--version"))
      (show-version-and-exit "guix"))
     (((? option? o) args ...)
      (format (current-error-port)
diff --git a/guix/utils.scm b/guix/utils.scm
index a5de9605e7..f934b6ed13 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -773,22 +773,28 @@ be determined."
   (line          location-line)                   ; 1-indexed line
   (column        location-column))                ; 0-indexed column
 
-(define location
-  (mlambda (file line column)
-    "Return the <location> object for the given FILE, LINE, and COLUMN."
-    (and line column file
-         (make-location file line column))))
+(define (location file line column)
+  "Return the <location> object for the given FILE, LINE, and COLUMN."
+  (and line column file
+       (make-location file line column)))
 
 (define (source-properties->location loc)
   "Return a location object based on the info in LOC, an alist as returned
 by Guile's `source-properties', `frame-source', `current-source-location',
 etc."
-  (let ((file (assq-ref loc 'filename))
-        (line (assq-ref loc 'line))
-        (col  (assq-ref loc 'column)))
-    ;; In accordance with the GCS, start line and column numbers at 1.  Note
-    ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
-    (location file (and line (+ line 1)) col)))
+  ;; In accordance with the GCS, start line and column numbers at 1.  Note
+  ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
+  (match loc
+    ((('line . line) ('column . col) ('filename . file)) ;common case
+     (and file line col
+          (make-location file (+ line 1) col)))
+    (#f
+     #f)
+    (_
+     (let ((file (assq-ref loc 'filename))
+           (line (assq-ref loc 'line))
+           (col  (assq-ref loc 'column)))
+       (location file (and line (+ line 1)) col)))))
 
 (define (location->source-properties loc)
   "Return the source property association list based on the info in LOC,