Merge branch 'master' into staging

20 files changed, 804 insertions, 304 deletions

diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm
new file mode 100644
index 0000000000..8bd41c89f0
--- /dev/null
+++ b/guix/build-system/dune.scm
@@ -0,0 +1,159 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system dune)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module ((guix build-system gnu) #:prefix gnu:)
+  #:use-module ((guix build-system ocaml) #:prefix ocaml:)
+  #:use-module (guix packages)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (%dune-build-system-modules
+            dune-build
+            dune-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using dune. This is implemented as an
+;; extension of `ocaml-build-system'.
+;;
+;; Code:
+
+(define %dune-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build dune-build-system)
+    ,@ocaml:%ocaml-build-system-modules))
+
+(define (default-dune)
+  "Return the default OCaml package."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(gnu packages ocaml))))
+    (module-ref module 'dune)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system target
+                (dune (default-dune))
+                (ocaml (ocaml:default-ocaml))
+                (findlib (ocaml:default-findlib))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs))
+
+  (and (not target)                               ;XXX: no cross-compilation
+       (let ((base (ocaml:lower name
+                                #:source source
+                                #:inputs inputs
+                                #:native-inputs native-inputs
+                                #:outputs outputs
+                                #:system system
+                                #:target target
+                                #:ocaml ocaml
+                                #:findlib findlib
+                                arguments)))
+         (bag
+           (inherit base)
+           (build-inputs `(("dune" ,dune)
+                           ,@(bag-build-inputs base)))
+           (build dune-build)
+           (arguments (strip-keyword-arguments private-keywords arguments))))))
+
+(define* (dune-build store name inputs
+                     #:key (guile #f)
+                     (outputs '("out"))
+                     (search-paths '())
+                     (build-flags ''())
+                     (out-of-source? #t)
+                     (jbuild? #f)
+                     (tests? #t)
+                     (test-flags ''())
+                     (test-target "test")
+                     (install-target "install")
+                     (validate-runpath? #t)
+                     (patch-shebangs? #t)
+                     (strip-binaries? #t)
+                     (strip-flags ''("--strip-debug"))
+                     (strip-directories ''("lib" "lib64" "libexec"
+                                           "bin" "sbin"))
+                     (phases '(@ (guix build dune-build-system)
+                                 %standard-phases))
+                     (system (%current-system))
+                     (imported-modules %dune-build-system-modules)
+                     (modules '((guix build dune-build-system)
+                                (guix build utils))))
+  "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE
+provides a 'setup.ml' file as its build system."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (dune-build #:source ,(match (assoc-ref inputs "source")
+                               (((? derivation? source))
+                                (derivation->output-path source))
+                               ((source)
+                                source)
+                               (source
+                                source))
+                   #:system ,system
+                   #:outputs %outputs
+                   #:inputs %build-inputs
+                   #:search-paths ',(map search-path-specification->sexp
+                                         search-paths)
+                   #:phases ,phases
+                   #:test-flags ,test-flags
+                   #:build-flags ,build-flags
+                   #:out-of-source? ,out-of-source?
+                   #:jbuild? ,jbuild?
+                   #:tests? ,tests?
+                   #:test-target ,test-target
+                   #:install-target ,install-target
+                   #:validate-runpath? ,validate-runpath?
+                   #:patch-shebangs? ,patch-shebangs?
+                   #:strip-binaries? ,strip-binaries?
+                   #:strip-flags ,strip-flags
+                   #:strip-directories ,strip-directories)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                                         ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:system system
+                                #:inputs inputs
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define dune-build-system
+  (build-system
+    (name 'dune)
+    (description "The standard Dune build system")
+    (lower lower)))
+
+;;; dune.scm ends here
diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm
index e5b715f55d..07c69fac76 100644
--- a/guix/build-system/ocaml.scm
+++ b/guix/build-system/ocaml.scm
@@ -31,6 +31,9 @@
             package-with-ocaml4.02
             strip-ocaml4.01-variant
             strip-ocaml4.02-variant
+            default-findlib
+            default-ocaml
+            lower
             ocaml-build
             ocaml-build-system))
 
@@ -76,6 +79,13 @@
   (let ((module (resolve-interface '(gnu packages ocaml))))
     (module-ref module 'ocaml-findlib)))
 
+(define (default-dune-build-system)
+  "Return the dune-build-system."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(guix build-system dune))))
+    (module-ref module 'dune-build-system)))
+
 (define (default-ocaml4.01)
   (let ((ocaml (resolve-interface '(gnu packages ocaml))))
     (module-ref ocaml 'ocaml-4.01)))
@@ -119,7 +129,8 @@ pre-defined variants."
       => force)
 
      ;; Otherwise build the new package object graph.
-     ((eq? (package-build-system p) ocaml-build-system)
+     ((or (eq? (package-build-system p) ocaml-build-system)
+          (eq? (package-build-system p) (default-dune-build-system)))
       (package
         (inherit p)
         (location (package-location p))
@@ -138,7 +149,8 @@ pre-defined variants."
      (else p)))
 
   (define (cut? p)
-    (or (not (eq? (package-build-system p) ocaml-build-system))
+    (or (not (or (eq? (package-build-system p) ocaml-build-system)
+                 (eq? (package-build-system p) (default-dune-build-system))))
         (package-variant p)))
 
   (package-mapping transform cut?))
diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm
new file mode 100644
index 0000000000..fcc2d6567d
--- /dev/null
+++ b/guix/build/dune-build-system.scm
@@ -0,0 +1,69 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build dune-build-system)
+  #:use-module ((guix build ocaml-build-system) #:prefix ocaml:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:export (%standard-phases
+            dune-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard dune build procedure.
+;;
+;; Code:
+
+(define* (build #:key (build-flags '()) (jbuild? #f)
+                (use-make? #f) #:allow-other-keys)
+  "Build the given package."
+  (let ((program (if jbuild? "jbuilder" "dune")))
+    (apply invoke program "build" "@install" build-flags))
+  #t)
+
+(define* (check #:key (test-flags '()) (test-target "test") tests?
+                  (jbuild? #f) #:allow-other-keys)
+  "Test the given package."
+  (when tests?
+    (let ((program (if jbuild? "jbuilder" "dune")))
+      (apply invoke program "runtest" test-target test-flags)))
+  #t)
+
+(define* (install #:key outputs (install-target "install") (jbuild? #f)
+                  #:allow-other-keys)
+  "Install the given package."
+  (let ((out (assoc-ref outputs "out"))
+        (program (if jbuild? "jbuilder" "dune")))
+    (invoke program install-target "--prefix" out))
+  #t)
+
+(define %standard-phases
+  ;; Everything is as with the GNU Build System except for the `configure'
+  ;; , `build', `check' and `install' phases.
+  (modify-phases ocaml:%standard-phases
+    (delete 'configure)
+    (replace 'build build)
+    (replace 'check check)
+    (replace 'install install)))
+
+(define* (dune-build #:key inputs (phases %standard-phases)
+                     #:allow-other-keys #:rest args)
+  "Build the given package, applying all of PHASES in order."
+  (apply ocaml:ocaml-build #:inputs inputs #:phases phases args))
+
+;;; dune-build-system.scm ends here
diff --git a/guix/download.scm b/guix/download.scm
index a7f51b1999..25eaefcffa 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -411,17 +411,11 @@
               (object->string %content-addressed-mirrors)))
 
 (define built-in-builders*
-  (let ((cache (make-weak-key-hash-table)))
+  (let ((proc (store-lift built-in-builders)))
     (lambda ()
       "Return, as a monadic value, the list of built-in builders supported by
-the daemon."
-      (lambda (store)
-        ;; Memoize the result to avoid repeated RPCs.
-        (values (or (hashq-ref cache store)
-                    (let ((result (built-in-builders store)))
-                      (hashq-set! cache store result)
-                      result))
-                store)))))
+the daemon; cache the return value."
+      (mcached (proc) built-in-builders))))
 
 (define* (built-in-download file-name url
                             #:key system hash-algo hash
diff --git a/guix/gexp.scm b/guix/gexp.scm
index fd3b6be348..88cabc8ed5 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -566,15 +566,15 @@ list."
 corresponding input list as a monadic value.  When TARGET is true, use it as
 the cross-compilation target triplet."
   (with-monad %store-monad
-    (sequence %store-monad
-              (map (match-lambda
-                     (((? struct? thing) sub-drv ...)
-                      (mlet %store-monad ((drv (lower-object
-                                                thing system #:target target)))
-                        (return `(,drv ,@sub-drv))))
-                     (input
-                      (return input)))
-                   inputs))))
+    (mapm %store-monad
+          (match-lambda
+            (((? struct? thing) sub-drv ...)
+             (mlet %store-monad ((drv (lower-object
+                                       thing system #:target target)))
+               (return `(,drv ,@sub-drv))))
+            (input
+             (return input)))
+          inputs)))
 
 (define* (lower-reference-graphs graphs #:key system target)
   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
@@ -606,7 +606,7 @@ names and file names suitable for the #:allowed-references argument to
                                                #:target target)))
           (return (derivation->output-path drv))))))
 
-    (sequence %store-monad (map lower lst))))
+    (mapm %store-monad lower lst)))
 
 (define default-guile-derivation
   ;; Here we break the abstraction by talking to the higher-level layer.
@@ -880,15 +880,15 @@ and in the current monad setting (system type, etc.)"
                      #:system system
                      #:target (if (or n? native?) #f target)))
         (($ <gexp-input> (refs ...) output n?)
-         (sequence %store-monad
-                   (map (lambda (ref)
-                          ;; XXX: Automatically convert REF to an gexp-input.
-                          (reference->sexp
-                           (if (gexp-input? ref)
-                               ref
-                               (%gexp-input ref "out" n?))
-                           (or n? native?)))
-                        refs)))
+         (mapm %store-monad
+               (lambda (ref)
+                 ;; XXX: Automatically convert REF to an gexp-input.
+                 (reference->sexp
+                  (if (gexp-input? ref)
+                      ref
+                      (%gexp-input ref "out" n?))
+                  (or n? native?)))
+               refs))
         (($ <gexp-input> (? struct? thing) output n?)
          (let ((target (if (or n? native?) #f target))
                (expand (lookup-expander thing)))
@@ -902,8 +902,8 @@ and in the current monad setting (system type, etc.)"
          (return x)))))
 
   (mlet %store-monad
-      ((args (sequence %store-monad
-                       (map reference->sexp (gexp-references exp)))))
+      ((args (mapm %store-monad
+                   reference->sexp (gexp-references exp))))
     (return (apply (gexp-proc exp) args))))
 
 (define (syntax-location-string s)
@@ -1117,8 +1117,7 @@ to the source files instead of copying them."
       (mlet %store-monad ((file (lower-object file-like system)))
         (return (list final-path file))))))
 
-  (mlet %store-monad ((files (sequence %store-monad
-                                       (map file-pair files))))
+  (mlet %store-monad ((files (mapm %store-monad file-pair files)))
     (define build
       (gexp
        (begin
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 8f2c10258a..aaa1caf035 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
@@ -23,6 +23,7 @@
   #:use-module (ice-9 regex)
   #:use-module ((ice-9 rdelim) #:select (read-string read-line))
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 receive)
@@ -180,9 +181,9 @@ from ~s: ~a (~s)~%"
      ;; Currently, the bioconductor project does not offer a way to access a
      ;; package's DESCRIPTION file over HTTP, so we determine the version,
      ;; download the source tarball, and then extract the DESCRIPTION file.
-     (let* ((version (latest-bioconductor-package-version name))
-            (url     (car (bioconductor-uri name version)))
-            (tarball (with-store store (download-to-store store url))))
+     (and-let* ((version (latest-bioconductor-package-version name))
+                (url     (car (bioconductor-uri name version)))
+                (tarball (with-store store (download-to-store store url))))
        (call-with-temporary-directory
         (lambda (dir)
           (parameterize ((current-error-port (%make-void-port "rw+"))
@@ -346,8 +347,12 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
    (lambda* (package-name #:optional (repo 'cran))
      "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
 s-expression corresponding to that package, or #f on failure."
-     (and=> (fetch-description repo package-name)
-            (cut description->package repo <>)))))
+     (let ((description (fetch-description repo package-name)))
+       (if (and (not description)
+                (eq? repo 'bioconductor))
+           ;; Retry import from CRAN
+           (cran->guix-package package-name 'cran)
+           (description->package repo description))))))
 
 (define* (cran-recursive-import package-name #:optional (repo 'gnu))
   (recursive-import package-name repo
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index f252bdc31a..c42a5d767d 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -17,132 +17,108 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix import opam)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 peg)
+  #:use-module (ice-9 receive)
   #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (web uri)
   #:use-module (guix http-client)
+  #:use-module (guix git)
+  #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix import utils)
   #:use-module ((guix licenses) #:prefix license:)
   #:export (opam->guix-package))
 
-(define (opam-urls)
-  "Fetch the urls.txt file from the opam repository and returns the list of
-URLs it contains."
-  (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt"))))
-    (let loop ((result '()))
-      (let ((line (read-line port)))
-        (if (eof-object? line)
-          (begin
-            (close port)
-            result)
-          (loop (cons line result)))))))
-
-(define (vhash-ref hashtable key default)
-  (match (vhash-assoc key hashtable)
-    (#f default)
-    ((_ . x) x)))
-
-(define (hashtable-update hashtable line)
-  "Parse @var{line} to get the name and version of the package and adds them
-to the hashtable."
-  (let* ((line (string-split line #\ )))
-    (match line
-      ((url foo ...)
-       (if (equal? url "repo")
-         hashtable
-         (match (string-split url #\/)
-           ((type name1 versionstr foo ...)
-            (if (equal? type "packages")
-              (match (string-split versionstr #\.)
-                ((name2 versions ...)
-                 (let ((version (string-join versions ".")))
-                   (if (equal? name1 name2)
-                     (let ((curr (vhash-ref hashtable name1 '())))
-                       (vhash-cons name1 (cons version curr) hashtable))
-                     hashtable)))
-                (_ hashtable))
-              hashtable))
-           (_ hashtable))))
-      (_ hashtable))))
-
-(define (urls->hashtable urls)
-  "Transform urls.txt in a hashtable whose keys are package names and values
-the list of available versions."
-  (let ((hashtable vlist-null))
-    (let loop ((urls urls) (hashtable hashtable))
-      (match urls
-        (() hashtable)
-        ((url rest ...) (loop rest (hashtable-update hashtable url)))))))
+;; Define a PEG parser for the opam format
+(define-peg-pattern SP none (or " " "\n"))
+(define-peg-pattern SP2 body (or " " "\n"))
+(define-peg-pattern QUOTE none "\"")
+(define-peg-pattern QUOTE2 body "\"")
+(define-peg-pattern COLON none ":")
+;; A string character is any character that is not a quote, or a quote preceded by a backslash.
+(define-peg-pattern STRCHR body
+                    (or " " "!" (and (ignore "\\") "\"")
+                        (and (ignore "\\") "\\") (range #\# #\頋)))
+(define-peg-pattern operator all (or "=" "!" "<" ">"))
+
+(define-peg-pattern records body (* (and (or record weird-record) (* SP))))
+(define-peg-pattern record all (and key COLON (* SP) value))
+(define-peg-pattern weird-record all (and key (* SP) dict))
+(define-peg-pattern key body (+ (or (range #\a #\z) "-")))
+(define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
+(define-peg-pattern ground-value body (and (or multiline-string string-pat list-pat var) (* SP)))
+(define-peg-pattern conditional-value all (and ground-value (* SP) condition))
+(define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
+(define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
+(define-peg-pattern var all (+ (or (range #\a #\z) "-")))
+(define-peg-pattern multiline-string all
+                    (and QUOTE QUOTE QUOTE (* SP)
+                         (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
+                                (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
+                         QUOTE QUOTE QUOTE))
+(define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))
+
+(define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
+
+(define-peg-pattern condition-form body
+                    (and
+                      (* SP)
+                      (or condition-and condition-or condition-form2)
+                      (* SP)))
+(define-peg-pattern condition-form2 body
+                    (and (* SP) (or condition-greater-or-equal condition-greater
+                                    condition-lower-or-equal condition-lower
+                                    condition-neq condition-eq condition-content) (* SP)))
+
+;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
+(define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
+(define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
+(define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
+(define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
+(define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
+(define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
+(define-peg-pattern condition-eq all (and condition-content (* SP) (ignore "=") (* SP) condition-content))
+(define-peg-pattern condition-neq all (and condition-content (* SP) (ignore (and "!" "=")) (* SP) condition-content))
+(define-peg-pattern condition-content body (or condition-string condition-var))
+(define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
+(define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
+(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-")))
+
+(define (get-opam-repository)
+  "Update or fetch the latest version of the opam repository and return the
+path to the repository."
+  (receive (location commit)
+    (update-cached-checkout "https://github.com/ocaml/opam-repository")
+    location))
 
 (define (latest-version versions)
   "Find the most recent version from a list of versions."
-  (match versions
-    ((first rest ...)
-     (let loop ((versions rest) (m first))
-       (match versions
-         (() m)
-         ((first rest ...)
-          (loop rest (if (version>? m first) m first))))))))
-
-(define (fetch-package-url uri)
-  "Fetch and parse the url file.  Return the URL the package can be downloaded
-from."
-  (let ((port (http-fetch uri)))
-    (let loop ((result #f))
-      (let ((line (read-line port)))
-        (if (eof-object? line)
-          (begin
-            (close port)
-            result)
-          (let* ((line (string-split line #\ )))
-            (match line
-              ((key value rest ...)
-               (if (member key '("archive:" "http:"))
-                 (loop (string-trim-both value #\"))
-                 (loop result))))))))))
-
-(define (fetch-package-metadata uri)
-  "Fetch and parse the opam file.  Return an association list containing the
-homepage, the license and the list of inputs."
-  (let ((port (http-fetch uri)))
-    (let loop ((result '()) (dependencies? #f))
-      (let ((line (read-line port)))
-        (if (eof-object? line)
-          (begin
-            (close port)
-            result)
-          (let* ((line (string-split line #\ )))
-            (match line
-               ((key value ...)
-                (let ((dependencies?
-                        (if dependencies?
-                          (not (equal? key "]"))
-                          (equal? key "depends:")))
-                      (val (string-trim-both (string-join value "") #\")))
-                  (cond
-                    ((equal? key "homepage:")
-                     (loop (cons `("homepage" . ,val) result) dependencies?))
-                    ((equal? key "license:")
-                     (loop (cons `("license" . ,val) result) dependencies?))
-                    ((and dependencies? (not (equal? val "[")))
-                     (match (string-split val #\{)
-                       ((val rest ...)
-                        (let ((curr (assoc-ref result "inputs"))
-                              (new (string-trim-both
-                                     val (list->char-set '(#\] #\[ #\")))))
-                          (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result)
-                                (if (string-contains val "]") #f dependencies?))))))
-                    (else (loop result dependencies?))))))))))))
-
-(define (string->license str)
-  (cond
-    ((equal? str "MIT") '(license:expat))
-    ((equal? str "GPL2") '(license:gpl2))
-    ((equal? str "LGPLv2") '(license:lgpl2))
-    (else `())))
+  (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
+
+(define (find-latest-version package repository)
+  "Get the latest version of a package as described in the given repository."
+  (let* ((dir (string-append repository "/packages/" package))
+         (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
+    (if versions
+      (let ((versions (map
+                        (lambda (dir)
+                          (string-join (cdr (string-split dir #\.)) "."))
+                        versions)))
+        (latest-version versions))
+      (begin
+        (format #t (G_ "Package not found in opam repository: ~a~%") package)
+        #f))))
+
+(define (get-metadata opam-file)
+  (with-input-from-file opam-file
+    (lambda _
+      (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
 
 (define (ocaml-name->guix-name name)
   (cond
@@ -151,33 +127,85 @@ homepage, the license and the list of inputs."
     ((string-prefix? "conf-" name) (substring name 5))
     (else (string-append "ocaml-" name))))
 
-(define (dependencies->inputs dependencies)
-  "Transform the list of dependencies in a list of inputs."
-  (if (not dependencies)
-    '()
-    (map (lambda (input)
-           (list input (list 'unquote (string->symbol input))))
-         (map ocaml-name->guix-name dependencies))))
+(define (metadata-ref file lookup)
+  (pk 'file file 'lookup lookup)
+  (fold (lambda (record acc)
+          (match record
+            ((record key val)
+             (if (equal? key lookup)
+               (match val
+                 (('list-pat . stuff) stuff)
+                 (('string-pat stuff) stuff)
+                 (('multiline-string stuff) stuff)
+                 (('dict records ...) records))
+               acc))))
+        #f file))
+
+(define (native? condition)
+  (match condition
+    (('condition-var var)
+     (match var
+       ("with-test" #t)
+       ("test" #t)
+       ("build" #t)
+       (_ #f)))
+    ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
+     (or (native? cond-left)
+         (native? cond-right)))
+    (_ #f)))
+
+(define (dependency->input dependency)
+  (match dependency
+    (('string-pat str) str)
+    (('conditional-value val condition)
+     (if (native? condition) "" (dependency->input val)))))
+
+(define (dependency->native-input dependency)
+  (match dependency
+    (('string-pat str) "")
+    (('conditional-value val condition)
+     (if (native? condition) (dependency->input val) ""))))
+
+(define (ocaml-names->guix-names names)
+  (map ocaml-name->guix-name
+       (remove (lambda (name)
+                 (or (equal? "" name))
+                     (equal? "ocaml" name))
+               names)))
+
+(define (depends->inputs depends)
+  (filter (lambda (name)
+            (and (not (equal? "" name))
+                 (not (equal? "ocaml" name))
+                 (not (equal? "ocamlfind" name))))
+    (map dependency->input depends)))
+
+(define (depends->native-inputs depends)
+  (filter (lambda (name) (not (equal? "" name)))
+    (map dependency->native-input depends)))
+
+(define (dependency-list->inputs lst)
+  (map
+    (lambda (dependency)
+      (list dependency (list 'unquote (string->symbol dependency))))
+    (ocaml-names->guix-names lst)))
 
 (define (opam->guix-package name)
-  (let* ((hashtable (urls->hashtable (opam-urls)))
-         (versions (vhash-ref hashtable name #f)))
-    (unless (eq? versions #f)
-      (let* ((version (latest-version versions))
-             (package-url (string-append "https://opam.ocaml.org/packages/" name
-                                         "/" name "." version "/"))
-             (url-url (string-append package-url "url"))
-             (opam-url (string-append package-url "opam"))
-             (source-url (fetch-package-url url-url))
-             (metadata (fetch-package-metadata opam-url))
-             (dependencies (assoc-ref metadata "inputs"))
-             (inputs (dependencies->inputs dependencies)))
+  (and-let* ((repository (get-opam-repository))
+             (version (find-latest-version name repository))
+             (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam"))
+             (opam-content (get-metadata file))
+             (url-dict (metadata-ref (pk 'metadata opam-content) "url"))
+             (source-url (metadata-ref url-dict "src"))
+             (requirements (metadata-ref opam-content "depends"))
+             (inputs (dependency-list->inputs (depends->inputs requirements)))
+             (native-inputs (dependency-list->inputs (depends->native-inputs requirements))))
         (call-with-temporary-output-file
           (lambda (temp port)
             (and (url-fetch source-url temp)
                  `(package
                     (name ,(ocaml-name->guix-name name))
-                    (version ,version)
+                    (version ,(metadata-ref opam-content "version"))
                     (source
                       (origin
                         (method url-fetch)
@@ -187,7 +215,10 @@ homepage, the license and the list of inputs."
                     ,@(if (null? inputs)
                         '()
                         `((inputs ,(list 'quasiquote inputs))))
-                    (home-page ,(assoc-ref metadata "homepage"))
-                    (synopsis "")
-                    (description "")
-                    (license ,@(string->license (assoc-ref metadata "license")))))))))))
+                    ,@(if (null? native-inputs)
+                        '()
+                        `((native-inputs ,(list 'quasiquote native-inputs))))
+                    (home-page ,(metadata-ref opam-content "homepage"))
+                    (synopsis ,(metadata-ref opam-content "synopsis"))
+                    (description ,(metadata-ref opam-content "description"))
+                    (license #f)))))))
diff --git a/guix/packages.scm b/guix/packages.scm
index eab0b3404c..e4c2ac3be5 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -870,14 +870,14 @@ OVERRIDES."
 SYSTEM."
   ;; FIXME: This memoization should be associated with the open store, because
   ;; otherwise it breaks when switching to a different store.
-  (let ((vals (call-with-values thunk list)))
+  (let ((result (thunk)))
     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
     ;; same value for all structs (as of Guile 2.0.6), and because pointer
     ;; equality is sufficient in practice.
     (hashq-set! cache package
-                `((,system ,@vals)
+                `((,system . ,result)
                   ,@(or (hashq-ref cache package) '())))
-    (apply values vals)))
+    result))
 
 (define-syntax cached
   (syntax-rules (=>)
@@ -889,10 +889,8 @@ Return the cached result when available."
        (match (hashq-ref cache package)
          ((alist (... ...))
           (match (assoc-ref alist key)
-            ((vals (... ...))
-             (apply values vals))
-            (#f
-             (cache! cache package key thunk))))
+            (#f (cache! cache package key thunk))
+            (value value)))
          (#f
           (cache! cache package key thunk)))))
     ((_ package system body ...)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ba4446bc2f..8142e5e8e2 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -4,7 +4,7 @@
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
-;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
 ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -788,7 +788,10 @@ MANIFEST."
 
   (gexp->derivation "info-dir" build
                     #:local-build? #t
-                    #:substitutable? #f))
+                    #:substitutable? #f
+                    #:properties
+                    `((type . profile-hook)
+                      (hook . info-dir))))
 
 (define (ghc-package-cache-file manifest)
   "Return a derivation that builds the GHC 'package.cache' file for all the
@@ -842,7 +845,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
              (map manifest-entry-name (manifest-entries manifest)))
         (gexp->derivation "ghc-package-cache" build
                           #:local-build? #t
-                          #:substitutable? #f)
+                          #:substitutable? #f
+                          #:properties
+                          `((type . profile-hook)
+                            (hook . ghc-package-cache)))
         (return #f))))
 
 (define (ca-certificate-bundle manifest)
@@ -910,7 +916,10 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
 
   (gexp->derivation "ca-certificate-bundle" build
                     #:local-build? #t
-                    #:substitutable? #f))
+                    #:substitutable? #f
+                    #:properties
+                    `((type . profile-hook)
+                      (hook . ca-certificate-bundle))))
 
 (define (glib-schemas manifest)
   "Return a derivation that unions all schemas from manifest entries and
@@ -960,7 +969,10 @@ creates the Glib 'gschemas.compiled' file."
     (if %glib
         (gexp->derivation "glib-schemas" build
                           #:local-build? #t
-                          #:substitutable? #f)
+                          #:substitutable? #f
+                          #:properties
+                          `((type . profile-hook)
+                            (hook . glib-schemas)))
         (return #f))))
 
 (define (gtk-icon-themes manifest)
@@ -1016,7 +1028,10 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
     (if %gtk+
         (gexp->derivation "gtk-icon-themes" build
                           #:local-build? #t
-                          #:substitutable? #f)
+                          #:substitutable? #f
+                          #:properties
+                          `((type . profile-hook)
+                            (hook . gtk-icon-themes)))
         (return #f))))
 
 (define (gtk-im-modules manifest)
@@ -1088,7 +1103,10 @@ for both major versions of GTK+."
       (if (or gtk+ gtk+-2)
           (gexp->derivation "gtk-im-modules" gexp
                             #:local-build? #t
-                            #:substitutable? #f)
+                            #:substitutable? #f
+                            #:properties
+                            `((type . profile-hook)
+                              (hook . gtk-im-modules)))
           (return #f)))))
 
 (define (xdg-desktop-database manifest)
@@ -1126,7 +1144,10 @@ MIME type."
     (if glib
         (gexp->derivation "xdg-desktop-database" build
                           #:local-build? #t
-                          #:substitutable? #f)
+                          #:substitutable? #f
+                          #:properties
+                          `((type . profile-hook)
+                            (hook . xdg-desktop-database)))
         (return #f))))
 
 (define (xdg-mime-database manifest)
@@ -1165,7 +1186,10 @@ entries.  It's used to query the MIME type of a given file."
     (if glib
         (gexp->derivation "xdg-mime-database" build
                           #:local-build? #t
-                          #:substitutable? #f)
+                          #:substitutable? #f
+                          #:properties
+                          `((type . profile-hook)
+                            (hook . xdg-mime-database)))
         (return #f))))
 
 ;; Several font packages may install font files into same directory, so
@@ -1236,7 +1260,10 @@ files for the fonts of the @var{manifest} entries."
                                 (guix build union)
                                 (srfi srfi-26))
                     #:local-build? #t
-                    #:substitutable? #f))
+                    #:substitutable? #f
+                    #:properties
+                    `((type . profile-hook)
+                      (hook . fonts-dir))))
 
 (define (manual-database manifest)
   "Return a derivation that builds the manual page database (\"mandb\") for
@@ -1306,7 +1333,10 @@ the entries in MANIFEST."
                     ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
                     #:env-vars `(("MALLOC_PERTURB_" . "1"))
 
-                    #:local-build? #t))
+                    #:local-build? #t
+                    #:properties
+                    `((type . profile-hook)
+                      (hook . manual-database))))
 
 (define %default-profile-hooks
   ;; This is the list of derivation-returning procedures that are called by
@@ -1353,10 +1383,10 @@ are cross-built for TARGET."
                                                          #:target target)))
                        (extras (if (null? (manifest-entries manifest))
                                    (return '())
-                                   (sequence %store-monad
-                                             (map (lambda (hook)
-                                                    (hook manifest))
-                                                  hooks)))))
+                                   (mapm %store-monad
+                                         (lambda (hook)
+                                           (hook manifest))
+                                         hooks))))
     (define inputs
       (append (filter-map (lambda (drv)
                             (and (derivation? drv)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 5965e3426e..86e1eb115f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -162,6 +162,8 @@ COMMAND or an interactive shell in that environment.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
@@ -261,7 +263,9 @@ COMMAND or an interactive shell in that environment.\n"))
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
-         %standard-build-options))
+
+         (append %transformation-options
+                 %standard-build-options)))
 
 (define (pick-all alist key)
   "Return a list of values in ALIST associated with KEY."
@@ -274,7 +278,7 @@ COMMAND or an interactive shell in that environment.\n"))
             (_ memo)))
         '() alist))
 
-(define (options/resolve-packages opts)
+(define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by manifest entries
 for the corresponding packages."
   (define (manifest-entry=? e1 e2)
@@ -282,15 +286,21 @@ for the corresponding packages."
          (string=? (manifest-entry-output e1)
                    (manifest-entry-output e2))))
 
+  (define transform
+    (cut (options->transformation opts) store <>))
+
+  (define* (package->manifest-entry* package #:optional (output "out"))
+    (package->manifest-entry (transform package) output))
+
   (define (packages->outputs packages mode)
     (match packages
       ((? package? package)
        (if (eq? mode 'ad-hoc-package)
-           (list (package->manifest-entry package))
+           (list (package->manifest-entry* package))
            (package-environment-inputs package)))
       (((? package? package) (? string? output))
        (if (eq? mode 'ad-hoc-package)
-           (list (package->manifest-entry package output))
+           (list (package->manifest-entry* package output))
            (package-environment-inputs package)))
       ((lst ...)
        (append-map (cut packages->outputs <> mode) lst))))
@@ -301,7 +311,7 @@ for the corresponding packages."
                   (('package 'ad-hoc-package (? string? spec))
                    (let-values (((package output)
                                  (specification->package+output spec)))
-                     (list (package->manifest-entry package output))))
+                     (list (package->manifest-entry* package output))))
                   (('package 'package (? string? spec))
                    (package-environment-inputs
                     (specification->package+output spec)))
@@ -364,8 +374,8 @@ requisite store items i.e. the union closure of all the inputs."
        ((? direct-store-path? path)
         (list path)))))
 
-  (mlet %store-monad ((reqs (sequence %store-monad
-                                      (map input->requisites inputs))))
+  (mlet %store-monad ((reqs (mapm %store-monad
+                                  input->requisites inputs)))
     (return (delete-duplicates (concatenate reqs)))))
 
 (define (status->exit-code status)
@@ -654,7 +664,6 @@ message if any test fails."
                                ;; within the container.
                                '("/bin/sh")
                                (list %default-shell))))
-           (manifest   (options/resolve-packages opts))
            (mappings   (pick-all opts 'file-system-mapping)))
 
       (when container? (assert-container-features))
@@ -666,6 +675,9 @@ message if any test fails."
 
       (with-store store
         (with-status-report print-build-event
+          (define manifest
+            (options/resolve-packages store opts))
+
           (set-build-options-from-command-line store opts)
 
           ;; Use the bootstrap Guile when requested.
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index ee5857e16b..1e0ea1c4c6 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -321,6 +321,13 @@ hook."
     (set-port-revealed! port 1)
     port))
 
+(define (node-free-disk-space node)
+  "Return the free disk space, in bytes, in NODE's store."
+  (node-eval node
+             `(begin
+                (use-modules (guix build syscalls))
+                (free-disk-space ,(%store-prefix)))))
+
 (define* (transfer-and-offload drv machine
                                #:key
                                (inputs '())
@@ -360,9 +367,19 @@ MACHINE."
                      (derivation-file-name drv)
                      (build-machine-name machine)
                      (nix-protocol-error-message c))
-             ;; Use exit code 100 for a permanent build failure.  The daemon
-             ;; interprets other non-zero codes as transient build failures.
-             (primitive-exit 100)))
+             (let* ((space (false-if-exception
+                            (node-free-disk-space (make-node session)))))
+
+               ;; Use exit code 100 for a permanent build failure.  The daemon
+               ;; interprets other non-zero codes as transient build failures.
+               (if (and space (< space (* 10 (expt 2 20))))
+                   (begin
+                     (format (current-error-port)
+                             (G_ "build failure may have been caused by lack \
+of free disk space on '~a'~%")
+                             (build-machine-name machine))
+                     (primitive-exit 1))
+                   (primitive-exit 100)))))
     (parameterize ((current-build-output-port (build-log-port)))
       (build-derivations store (list drv))))
 
@@ -392,33 +409,37 @@ MACHINE."
                (build-requirements-features requirements)
                (build-machine-features machine))))
 
-(define (machine-load machine)
-  "Return the load of MACHINE, divided by the number of parallel builds
-allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
-  ;; Note: This procedure is costly since it creates a new SSH session.
-  (match (false-if-exception (open-ssh-session machine))
-    ((? session? session)
-     (let* ((pipe (open-remote-pipe* session OPEN_READ
-                                     "cat" "/proc/loadavg"))
-            (line (read-line pipe)))
-       (close-port pipe)
-       (disconnect! session)
-
-       (if (eof-object? line)
-           +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
-           (match (string-tokenize line)
-             ((one five fifteen . x)
-              (let* ((raw        (string->number one))
-                     (jobs       (build-machine-parallel-builds machine))
-                     (normalized (/ raw jobs)))
-                (format (current-error-port) "load on machine '~a' is ~s\
+(define %minimum-disk-space
+  ;; Minimum disk space required on the build machine for a build to be
+  ;; offloaded.  This keeps us from offloading to machines that are bound to
+  ;; run out of disk space.
+  (* 100 (expt 2 20)))                            ;100 MiB
+
+(define (node-load node)
+  "Return the load on NODE.  Return +∞ if NODE is misbehaving."
+  (let ((line (node-eval node
+                         '(begin
+                            (use-modules (ice-9 rdelim))
+                            (call-with-input-file "/proc/loadavg"
+                              read-string)))))
+    (if (eof-object? line)
+        +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
+        (match (string-tokenize line)
+          ((one five fifteen . x)
+           (string->number one))
+          (x
+           +inf.0)))))
+
+(define (normalized-load machine load)
+  "Divide LOAD by the number of parallel builds of MACHINE."
+  (if (rational? load)
+      (let* ((jobs       (build-machine-parallel-builds machine))
+             (normalized (/ load jobs)))
+        (format (current-error-port) "load on machine '~a' is ~s\
  (normalized: ~s)~%"
-                        (build-machine-name machine) raw normalized)
-                normalized))
-             (x
-              +inf.0)))))        ;something's fishy about MACHINE, so avoid it
-    (x
-     +inf.0)))                      ;failed to connect to MACHINE, so avoid it
+                (build-machine-name machine) load normalized)
+        normalized)
+      load))
 
 (define (machine-lock-file machine hint)
   "Return the name of MACHINE's lock file for HINT."
@@ -484,21 +505,32 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
       (match machines+slots
         (((best slot) others ...)
          ;; Return the best machine unless it's already overloaded.
-         ;; Note: We call 'machine-load' only as a last resort because it is
+         ;; Note: We call 'node-load' only as a last resort because it is
          ;; too costly to call it once for every machine.
-         (if (< (machine-load best) 2.)
-             (match others
-               (((machines slots) ...)
-                ;; Release slots from the uninteresting machines.
-                (for-each release-build-slot slots)
-
-                ;; The caller must keep SLOT to protect it from GC and to
-                ;; eventually release it.
-                (values best slot)))
-             (begin
-               ;; BEST is overloaded, so try the next one.
-               (release-build-slot slot)
-               (loop others))))
+         (let* ((session (false-if-exception (open-ssh-session best)))
+                (node    (and session (make-node session)))
+                (load    (and node (normalized-load best (node-load node))))
+                (space   (and node (node-free-disk-space node))))
+           (when session (disconnect! session))
+           (if (and node (< load 2.) (>= space %minimum-disk-space))
+               (match others
+                 (((machines slots) ...)
+                  ;; Release slots from the uninteresting machines.
+                  (for-each release-build-slot slots)
+
+                  ;; The caller must keep SLOT to protect it from GC and to
+                  ;; eventually release it.
+                  (values best slot)))
+               (begin
+                 ;; BEST is unsuitable, so try the next one.
+                 (when (and space (< space %minimum-disk-space))
+                   (format (current-error-port)
+                           "skipping machine '~a' because it is low \
+on disk space (~,2f MiB free)~%"
+                           (build-machine-name best)
+                           (/ space (expt 2 20) 1.)))
+                 (release-build-slot slot)
+                 (loop others)))))
         (()
          (values #f #f))))))
 
@@ -689,16 +721,20 @@ machine."
     (info (G_ "getting status of ~a build machines defined in '~a'...~%")
           (length machines) machine-file)
     (for-each (lambda (machine)
-                (let* ((node (make-node (open-ssh-session machine)))
-                       (uts (node-eval node '(uname))))
+                (let* ((session (open-ssh-session machine))
+                       (node    (make-node session))
+                       (uts     (node-eval node '(uname)))
+                       (load    (node-load node))
+                       (free    (node-free-disk-space node)))
+                  (disconnect! session)
                   (format #t "~a~%  kernel: ~a ~a~%  architecture: ~a~%\
-  host name: ~a~%  normalized load: ~a~%"
+  host name: ~a~%  normalized load: ~a~%  free disk space: ~,2f MiB~%"
                           (build-machine-name machine)
                           (utsname:sysname uts) (utsname:release uts)
                           (utsname:machine uts)
                           (utsname:nodename uts)
-                          (parameterize ((current-error-port (%make-void-port "rw+")))
-                                        (machine-load machine)))))
+                          load
+                          (/ free (expt 2 20) 1.))))
               machines)))
 
 
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c5326b33da..a236f3e45c 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -537,14 +537,19 @@ requested using POOL."
         (not-found request))))
 
 (define* (render-nar/cached store cache request store-item
-                            #:key (compression %no-compression))
+                            #:key ttl (compression %no-compression))
   "Respond to REQUEST with a nar for STORE-ITEM.  If the nar is in CACHE,
-return it; otherwise, return 404."
+return it; otherwise, return 404.  When TTL is true, use it as the
+'Cache-Control' expiration time."
   (let ((cached (nar-cache-file cache store-item
                                 #:compression compression)))
     (if (file-exists? cached)
         (values `((content-type . (application/octet-stream
                                    (charset . "ISO-8859-1")))
+                  ,@(if ttl
+                        `((cache-control (max-age . ,ttl)))
+                        '())
+
                   ;; XXX: We're not returning the actual contents, deferring
                   ;; instead to 'http-write'.  This is a hack to work around
                   ;; <http://bugs.gnu.org/21093>.
@@ -819,6 +824,7 @@ blocking."
                                      %default-gzip-compression))))
                  (if cache
                      (render-nar/cached store cache request store-item
+                                        #:ttl narinfo-ttl
                                         #:compression compression)
                      (render-nar store request store-item
                                  #:compression compression)))
@@ -829,6 +835,7 @@ blocking."
            (if (nar-path? components)
                (if cache
                    (render-nar/cached store cache request store-item
+                                      #:ttl narinfo-ttl
                                       #:compression %no-compression)
                    (render-nar store request store-item
                                #:compression %no-compression))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index d6dc9b6448..53b1777241 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -392,12 +392,21 @@ No authentication and authorization checks are performed here!"
 (define (narinfo-sha256 narinfo)
   "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
 'Signature' field."
+  (define %mandatory-fields
+    ;; List of fields that must be signed.  If they are not signed, the
+    ;; narinfo is considered unsigned.
+    '("StorePath" "NarHash" "References"))
+
   (let ((contents (narinfo-contents narinfo)))
     (match (string-contains contents "Signature:")
       (#f #f)
       (index
-       (let ((above-signature (string-take contents index)))
-         (sha256 (string->utf8 above-signature)))))))
+       (let* ((above-signature (string-take contents index))
+              (signed-fields (match (call-with-input-string above-signature
+                                      fields->alist)
+                               (((fields . values) ...) fields))))
+         (and (every (cut member <> signed-fields) %mandatory-fields)
+              (sha256 (string->utf8 above-signature))))))))
 
 (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
                          #:key verbose?)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 8eb32c62bc..6cda3ccbd6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -993,7 +993,8 @@ Some ACTIONS support additional ARGS.\n"))
                          instead of reading FILE, when applicable"))
   (display (G_ "
       --on-error=STRATEGY
-                         apply STRATEGY when an error occurs while reading FILE"))
+                         apply STRATEGY (one of nothing-special, backtrace,
+                         or debug) when an error occurs while reading FILE"))
   (display (G_ "
       --file-system-type=TYPE
                          for 'disk-image', produce a root file system of TYPE
diff --git a/guix/status.scm b/guix/status.scm
index 868bfdca21..d4fc4ca16e 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -289,6 +290,31 @@ on."
    ("^(.*)(warning)([[:blank:]]*)(:)(.*)"
     RESET  MAGENTA   BOLD        BOLD BOLD)))
 
+(define (hook-message hook-type)
+  "Return a human-readable string for the profile hook type HOOK-TYPE."
+  (match hook-type
+    ('info-dir
+     (G_ "building directory of Info manuals..."))
+    ('ghc-package-cache
+     (G_ "building GHC package cache..."))
+    ('ca-certificate-bundle
+     (G_ "building CA certificate bundle..."))
+    ('glib-schemas
+     (G_ "generating GLib schema cache..."))
+    ('gtk-icon-themes
+     (G_ "creating GTK+ icon theme cache..."))
+    ('gtk-im-modules
+     (G_ "building cache files for GTK+ input methods..."))
+    ('xdg-desktop-database
+     (G_ "building XDG desktop file cache..."))
+    ('xdg-mime-database
+     (G_ "building XDG MIME database..."))
+    ('fonts-dir
+     (G_ "building fonts directory..."))
+    ('manual-database
+     (G_ "building database for manual pages..."))
+    (_ #f)))
+
 (define* (print-build-event event old-status status
                             #:optional (port (current-error-port))
                             #:key
@@ -336,6 +362,13 @@ addition to build events."
                                     "applying ~a grafts for ~a..."
                                     count))
                      count drv)))
+         ('profile-hook
+          (let ((hook-type (assq-ref properties 'hook)))
+            (or (and=> (hook-message hook-type)
+                       (lambda (msg)
+                         (format port (info msg))))
+                (format port (info (G_ "running profile hook of type '~a'..."))
+                        hook-type))))
          (_
           (format port (info (G_ "building ~a...")) drv))))
      (newline port))
diff --git a/guix/store.scm b/guix/store.scm
index 509fd4def6..042dfab67f 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -846,6 +846,14 @@ bytevector) as its internal buffer, and a thunk to flush this output port."
                                           write #f #f flush)
           flush))
 
+(define profiled?
+  (let ((profiled
+         (or (and=> (getenv "GUIX_PROFILING") string-tokenize)
+             '())))
+    (lambda (component)
+      "Return true if COMPONENT profiling is active."
+      (member component profiled))))
+
 (define %rpc-calls
   ;; Mapping from RPC names (symbols) to invocation counts.
   (make-hash-table))
@@ -1504,24 +1512,55 @@ and RESULT is typically its derivation."
              (object-cache (vhash-consq object (cons result keys)
                                         (nix-server-object-cache store)))))))
 
+(define record-cache-lookup!
+  (if (profiled? "object-cache")
+      (let ((fresh    0)
+            (lookups  0)
+            (hits     0))
+        (register-profiling-hook!
+         "object-cache"
+         (lambda ()
+           (format (current-error-port) "Store object cache:
+  fresh caches: ~5@a
+  lookups:      ~5@a
+  hits:         ~5@a (~,1f%)~%"
+                   fresh lookups hits
+                   (if (zero? lookups)
+                       100.
+                       (* 100. (/ hits lookups))))))
+
+        (lambda (hit? cache)
+          (set! fresh
+            (if (eq? cache vlist-null)
+                (+ 1 fresh)
+                fresh))
+          (set! lookups (+ 1 lookups))
+          (set! hits (if hit? (+ hits 1) hits))))
+      (lambda (x y)
+        #t)))
+
 (define* (lookup-cached-object object #:optional (keys '()))
   "Return the cached object in the store connection corresponding to OBJECT
 and KEYS.  KEYS is a list of additional keys to match against, and which are
 compared with 'equal?'.  Return #f on failure and the cached result
 otherwise."
   (lambda (store)
-    ;; Escape as soon as we find the result.  This avoids traversing the whole
-    ;; vlist chain and significantly reduces the number of 'hashq' calls.
-    (values (let/ec return
-              (vhash-foldq* (lambda (item result)
-                              (match item
-                                ((value . keys*)
-                                 (if (equal? keys keys*)
-                                     (return value)
-                                     result))))
-                            #f object
-                            (nix-server-object-cache store)))
-            store)))
+    (let* ((cache (nix-server-object-cache store))
+
+           ;; Escape as soon as we find the result.  This avoids traversing
+           ;; the whole vlist chain and significantly reduces the number of
+           ;; 'hashq' calls.
+           (value (let/ec return
+                    (vhash-foldq* (lambda (item result)
+                                    (match item
+                                      ((value . keys*)
+                                       (if (equal? keys keys*)
+                                           (return value)
+                                           result))))
+                                  #f object
+                                  cache))))
+      (record-cache-lookup! value cache)
+      (values value store))))
 
 (define* (%mcached mthunk object #:optional (keys '()))
   "Bind the monadic value returned by MTHUNK, which supposedly corresponds to
diff --git a/guix/store/database.scm b/guix/store/database.scm
index e6bfbe763e..4791f49865 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -79,6 +79,15 @@ as specified by SQL-SCHEMA."
 create it and initialize it as a new database."
   (let ((new? (not (file-exists? file)))
         (db   (sqlite-open file)))
+    ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED
+    ;; errors when we have several readers: <https://www.sqlite.org/wal.html>.
+    (sqlite-exec db "PRAGMA journal_mode=WAL;")
+
+    ;; Install a busy handler such that, when the database is locked, sqlite
+    ;; retries until 30 seconds have passed, at which point it gives up and
+    ;; throws SQLITE_BUSY.
+    (sqlite-exec db "PRAGMA busy_timeout = 30000;")
+
     (dynamic-wind noop
                   (lambda ()
                     (when new?
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 21b0c81f3d..a777940f86 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -99,24 +99,38 @@ LINK-PREFIX."
 (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.
+SWAP-DIRECTORY as the directory to store temporary hard links.  Upon ENOSPC
+and EMLINK, TO-REPLACE is left unchanged.
 
 Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
-  (let* ((temp-link (get-temp-link target swap-directory))
-         (parent    (dirname to-replace))
-         (stat      (stat parent)))
-    (make-file-writable parent)
+  (define temp-link
     (catch 'system-error
       (lambda ()
-        (rename-file temp-link to-replace)
-
-        ;; Restore PARENT's mtime and permissions.
-        (set-file-time parent stat)
-        (chmod parent (stat:mode stat)))
+        (get-temp-link target swap-directory))
       (lambda args
-        (delete-file temp-link)
-        (unless (= EMLINK (system-error-errno args))
-          (apply throw args))))))
+        ;; We get ENOSPC when we can't fit an additional entry in
+        ;; SWAP-DIRECTORY.
+        (if (= ENOSPC (system-error-errno args))
+            #f
+            (apply throw args)))))
+
+  ;; If we couldn't create TEMP-LINK, that's OK: just don't do the
+  ;; replacement, which means TO-REPLACE won't be deduplicated.
+  (when temp-link
+    (let* ((parent (dirname to-replace))
+           (stat   (stat parent)))
+      (make-file-writable parent)
+      (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))))
+
+      ;; Restore PARENT's mtime and permissions.
+      (set-file-time parent stat)
+      (chmod parent (stat:mode stat)))))
 
 (define* (deduplicate path hash #:key (store %store-directory))
   "Check if a store item with sha256 hash HASH already exists.  If so,
diff --git a/guix/ui.scm b/guix/ui.scm
index 60636edac0..44336ee8fd 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -502,14 +502,19 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
            (list (strerror (car errno)) file)
            (list errno))))
 
-(define-syntax-rule (error-reporting-wrapper proc (args ...) file)
+(define-syntax apply-formals
+  (syntax-rules ()
+    ((_ proc (args ...)) (proc args ...))
+    ((_ proc (arg1 args ... . rest)) (apply proc arg1 args ... rest))))
+
+(define-syntax-rule (error-reporting-wrapper proc formals file)
   "Wrap PROC such that its 'system-error' exceptions are augmented to mention
 FILE."
   (let ((real-proc (@ (guile) proc)))
-    (lambda (args ...)
+    (lambda formals
       (catch 'system-error
         (lambda ()
-          (real-proc args ...))
+          (apply-formals real-proc formals))
         (augmented-system-error-handler file)))))
 
 (set! symlink
@@ -528,6 +533,8 @@ FILE."
 (set! delete-file
   (error-reporting-wrapper delete-file (file) file))
 
+(set! execlp
+  (error-reporting-wrapper execlp (filename . args) filename))
 
 (define (make-regexp* regexp . flags)
   "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
@@ -822,6 +829,12 @@ warning."
     ('graft #t)
     (_ #f)))
 
+(define (profile-hook-derivation? drv)
+  "Return true if DRV is definitely a profile hook derivation, false otherwise."
+  (match (assq-ref (derivation-properties drv) 'type)
+    ('profile-hook #t)
+    (_ #f)))
+
 (define* (show-what-to-build store drv
                              #:key dry-run? (use-substitutes? #t)
                              (mode (build-mode normal)))
@@ -872,10 +885,28 @@ report what is prerequisites are available for download."
                                            substitutable-references
                                            download))))
                      download))
-                ((graft build)
-                 (partition (compose graft-derivation?
-                                     read-derivation-from-file)
-                            build)))
+                ((graft hook build)
+                 (match (fold (lambda (file acc)
+                                (let ((drv (read-derivation-from-file file)))
+                                  (match acc
+                                    ((#:graft graft #:hook hook #:build build)
+                                     (cond
+                                      ((graft-derivation? drv)
+                                       `(#:graft ,(cons file graft)
+                                         #:hook ,hook
+                                         #:build ,build))
+                                      ((profile-hook-derivation? drv)
+                                       `(#:graft ,graft
+                                         #:hook ,(cons file hook)
+                                         #:build ,build))
+                                      (else
+                                       `(#:graft ,graft
+                                         #:hook ,hook
+                                         #:build ,(cons file build))))))))
+                              '(#:graft () #:hook () #:build ())
+                              build)
+                   ((#:graft graft #:hook hook #:build build)
+                    (values graft hook build)))))
     (define installed-size
       (reduce + 0 (map substitutable-nar-size download)))
 
@@ -913,7 +944,12 @@ report what is prerequisites are available for download."
                   (N_ "~:[The following graft would be made:~%~{   ~a~%~}~;~]"
                       "~:[The following grafts would be made:~%~{   ~a~%~}~;~]"
                       (length graft))
-                  (null? graft) graft))
+                  (null? graft) graft)
+          (format (current-error-port)
+                  (N_ "~:[The following profile hook would be built:~%~{   ~a~%~}~;~]"
+                      "~:[The following profile hooks would be built:~%~{   ~a~%~}~;~]"
+                      (length hook))
+                  (null? hook) hook))
         (begin
           (format (current-error-port)
                   (N_ "~:[The following derivation will be built:~%~{   ~a~%~}~;~]"
@@ -938,7 +974,12 @@ report what is prerequisites are available for download."
                   (N_ "~:[The following graft will be made:~%~{   ~a~%~}~;~]"
                       "~:[The following grafts will be made:~%~{   ~a~%~}~;~]"
                       (length graft))
-                  (null? graft) graft)))
+                  (null? graft) graft)
+          (format (current-error-port)
+                  (N_ "~:[The following profile hook will be built:~%~{   ~a~%~}~;~]"
+                      "~:[The following profile hooks will be built:~%~{   ~a~%~}~;~]"
+                      (length hook))
+                  (null? hook) hook)))
 
     (check-available-space installed-size)
 
diff --git a/guix/utils.scm b/guix/utils.scm
index 9bad06d52f..ed1a418cca 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -731,17 +731,19 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
 ;;; Source location.
 ;;;
 
-(define (absolute-dirname file)
-  "Return the absolute name of the directory containing FILE, or #f upon
+(define absolute-dirname
+  ;; Memoize to avoid repeated 'stat' storms from 'search-path'.
+  (mlambda (file)
+    "Return the absolute name of the directory containing FILE, or #f upon
 failure."
-  (match (search-path %load-path file)
-    (#f #f)
-    ((? string? file)
-     ;; If there are relative names in %LOAD-PATH, FILE can be relative and
-     ;; needs to be canonicalized.
-     (if (string-prefix? "/" file)
-         (dirname file)
-         (canonicalize-path (dirname file))))))
+    (match (search-path %load-path file)
+      (#f #f)
+      ((? string? file)
+       ;; If there are relative names in %LOAD-PATH, FILE can be relative and
+       ;; needs to be canonicalized.
+       (if (string-prefix? "/" file)
+           (dirname file)
+           (canonicalize-path (dirname file)))))))
 
 (define-syntax current-source-directory
   (lambda (s)