Merge branch 'master' into core-updates

12 files changed, 468 insertions, 131 deletions

diff --git a/guix/ci.scm b/guix/ci.scm
new file mode 100644
index 0000000000..881f3d3927
--- /dev/null
+++ b/guix/ci.scm
@@ -0,0 +1,78 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 ci)
+  #:use-module (guix http-client)
+  #:autoload   (json parser) (json->scm)
+  #:use-module (srfi srfi-9)
+  #:export (build?
+            build-id
+            build-derivation
+            build-system
+            build-status
+            build-timestamp
+
+            %query-limit
+            queued-builds
+            latest-builds))
+
+;;; Commentary:
+;;;
+;;; This module provides a client to the HTTP interface of the Hydra and
+;;; Cuirass continuous integration (CI) tools.
+;;;
+;;; Code:
+
+(define-record-type <build>
+  (make-build id derivation system status timestamp)
+  build?
+  (id          build-id)                          ;integer
+  (derivation  build-derivation)                  ;string | #f
+  (system      build-system)                      ;string
+  (status      build-status)                      ;integer
+  (timestamp   build-timestamp))                  ;integer
+
+(define %query-limit
+  ;; Max number of builds requested in queries.
+  1000)
+
+(define (json-fetch url)
+  (let* ((port (http-fetch url))
+         (json (json->scm port)))
+    (close-port port)
+    json))
+
+(define (json->build json)
+  (make-build (hash-ref json "id")
+              (hash-ref json "derivation")
+              (hash-ref json "system")
+              (hash-ref json "buildstatus")
+              (hash-ref json "timestamp")))
+
+(define* (queued-builds url #:optional (limit %query-limit))
+  "Return the list of queued derivations on URL."
+  (let ((queue (json-fetch (string-append url "/api/queue?nr="
+                                          (number->string limit)))))
+    (map json->build queue)))
+
+(define* (latest-builds url #:optional (limit %query-limit))
+  (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
+                                           (number->string limit)))))
+    ;; Note: Hydra does not provide a "derivation" field for entries in
+    ;; 'latestbuilds', but Cuirass does.
+    (map json->build latest)))
diff --git a/guix/docker.scm b/guix/docker.scm
index 060232148e..a75534c33b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,9 +24,12 @@
   #:use-module ((guix build utils)
                 #:select (mkdir-p
                           delete-file-recursively
-                          with-directory-excursion))
-  #:use-module (guix build store-copy)
+                          with-directory-excursion
+                          invoke))
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module ((texinfo string-utils)
+                #:select (escape-special-chars))
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (build-docker-image))
@@ -33,8 +37,7 @@
 ;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
 (module-use! (current-module) (resolve-interface '(json)))
 
-;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
-;; containing the closure at PATH.
+;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
 (define docker-id
   (compose bytevector->base16-string sha256 string->utf8))
 
@@ -102,82 +105,123 @@ return \"a\"."
     ((first rest ...)
      first)))
 
-(define* (build-docker-image image path
-                             #:key closure compressor
+(define* (build-docker-image image paths prefix
+                             #:key
                              (symlinks '())
+                             (transformations '())
                              (system (utsname:machine (uname)))
+                             compressor
                              (creation-time (current-time time-utc)))
-  "Write to IMAGE a Docker image archive from the given store PATH.  The image
-contains the closure of PATH, as specified in CLOSURE (a file produced by
-#:references-graphs).  SYMLINKS must be a list of (SOURCE -> TARGET) tuples
-describing symlinks to be created in the image, where each TARGET is relative
-to PATH.  SYSTEM is a GNU triplet (or prefix thereof) of the system the
-binaries at PATH are for; it is used to produce metadata in the image.
-
-Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use
-CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata."
-  (let ((directory "/tmp/docker-image")           ;temporary working directory
-        (closure (canonicalize-path closure))
-        (id (docker-id path))
-        (time (date->string (time-utc->date creation-time) "~4"))
-        (arch (let-syntax ((cond* (syntax-rules ()
-                                    ((_ (pattern clause) ...)
-                                     (cond ((string-prefix? pattern system)
-                                            clause)
-                                           ...
-                                           (else
-                                            (error "unsupported system"
-                                                   system)))))))
-                (cond* ("x86_64" "amd64")
-                       ("i686"   "386")
-                       ("arm"    "arm")
-                       ("mips64" "mips64le")))))
+  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
+must be a store path that is a prefix of any store paths in PATHS.
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
+created in the image, where each TARGET is relative to PREFIX.
+TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
+transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
+in the Docker image so that it begins with NEW instead.  If a path is a
+non-empty directory, then its contents will be recursively added, as well.
+
+SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
+PATHS are for; it is used to produce metadata in the image.  Use COMPRESSOR, a
+command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use CREATION-TIME, a
+SRFI-19 time-utc object, as the creation time in metadata."
+  (define (sanitize path-fragment)
+    (escape-special-chars
+     ;; GNU tar strips the leading slash off of absolute paths before applying
+     ;; the transformations, so we need to do the same, or else our
+     ;; replacements won't match any paths.
+     (string-trim path-fragment #\/)
+     ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
+     ;; We also need to escape "/" because we use it as a delimiter.
+     "/*.^$[]\\"
+     #\\))
+  (define transformation->replacement
+    (match-lambda
+      ((old '-> new)
+       ;; See "(tar) transform" for details on the expression syntax.
+       (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
+  (define (transformations->expression transformations)
+    (let ((replacements (map transformation->replacement transformations)))
+      (string-append
+       ;; Avoid transforming link targets, since that would break some links
+       ;; (e.g., symlinks that point to an absolute store path).
+       "flags=rSH;"
+       (string-join replacements ";")
+       ;; Some paths might still have a leading path delimiter even after tar
+       ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
+       ;; strip any leading path delimiters that remain.
+       ";s,^//*,,")))
+  (define transformation-options
+    (if (eq? '() transformations)
+        '()
+        `("--transform" ,(transformations->expression transformations))))
+  (let* ((directory "/tmp/docker-image") ;temporary working directory
+         (id (docker-id prefix))
+         (time (date->string (time-utc->date creation-time) "~4"))
+         (arch (let-syntax ((cond* (syntax-rules ()
+                                     ((_ (pattern clause) ...)
+                                      (cond ((string-prefix? pattern system)
+                                             clause)
+                                            ...
+                                            (else
+                                             (error "unsupported system"
+                                                    system)))))))
+                 (cond* ("x86_64" "amd64")
+                        ("i686"   "386")
+                        ("arm"    "arm")
+                        ("mips64" "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
-
-    (and (with-directory-excursion directory
-           (mkdir id)
-           (with-directory-excursion id
-             (with-output-to-file "VERSION"
-               (lambda () (display schema-version)))
-             (with-output-to-file "json"
-               (lambda () (scm->json (image-description id time))))
-
-             ;; Wrap it up.
-             (let ((items (call-with-input-file closure
-                            read-reference-graph)))
-               ;; Create SYMLINKS.
-               (for-each (match-lambda
-                           ((source '-> target)
-                            (let ((source (string-trim source #\/)))
-                              (mkdir-p (dirname source))
-                              (symlink (string-append path "/" target)
-                                       source))))
-                         symlinks)
-
-               (and (zero? (apply system* "tar" "-cf" "layer.tar"
-                                  (append %tar-determinism-options
-                                          items
-                                          (map symlink-source symlinks))))
-                    (for-each delete-file-recursively
-                              (map (compose topmost-component symlink-source)
-                                   symlinks)))))
-
-           (with-output-to-file "config.json"
-             (lambda ()
-               (scm->json (config (string-append id "/layer.tar")
-                                  time arch))))
-           (with-output-to-file "manifest.json"
-             (lambda ()
-               (scm->json (manifest path id))))
-           (with-output-to-file "repositories"
-             (lambda ()
-               (scm->json (repositories path id)))))
-
-         (and (zero? (apply system* "tar" "-C" directory "-cf" image
-                            `(,@%tar-determinism-options
-                              ,@(if compressor
-                                    (list "-I" (string-join compressor))
-                                    '())
-                              ".")))
-              (begin (delete-file-recursively directory) #t)))))
+    (with-directory-excursion directory
+      (mkdir id)
+      (with-directory-excursion id
+        (with-output-to-file "VERSION"
+          (lambda () (display schema-version)))
+        (with-output-to-file "json"
+          (lambda () (scm->json (image-description id time))))
+
+        ;; Create SYMLINKS.
+        (for-each (match-lambda
+                    ((source '-> target)
+                     (let ((source (string-trim source #\/)))
+                       (mkdir-p (dirname source))
+                       (symlink (string-append prefix "/" target)
+                                source))))
+                  symlinks)
+
+        (apply invoke "tar" "-cf" "layer.tar"
+               `(,@transformation-options
+                 ,@%tar-determinism-options
+                 ,@paths
+                 ,@(map symlink-source symlinks)))
+        ;; It is possible for "/" to show up in the archive, especially when
+        ;; applying transformations.  For example, the transformation
+        ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
+        ;; the path "/a" into "/".  The presence of "/" in the archive is
+        ;; probably benign, but it is definitely safe to remove it, so let's
+        ;; do that.  This fails when "/" is not in the archive, so use system*
+        ;; instead of invoke to avoid an exception in that case.
+        (system* "tar" "--delete" "/" "-f" "layer.tar")
+        (for-each delete-file-recursively
+                  (map (compose topmost-component symlink-source)
+                       symlinks)))
+
+      (with-output-to-file "config.json"
+        (lambda ()
+          (scm->json (config (string-append id "/layer.tar")
+                             time arch))))
+      (with-output-to-file "manifest.json"
+        (lambda ()
+          (scm->json (manifest prefix id))))
+      (with-output-to-file "repositories"
+        (lambda ()
+          (scm->json (repositories prefix id)))))
+
+    (apply invoke "tar" "-cf" image "-C" directory
+           `(,@%tar-determinism-options
+             ,@(if compressor
+                   (list "-I" (string-join compressor))
+                   '())
+             "."))
+    (delete-file-recursively directory)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8dea022e04..b47965d9eb 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -60,6 +60,7 @@
             program-file-name
             program-file-gexp
             program-file-guile
+            program-file-module-path
 
             scheme-file
             scheme-file?
@@ -380,25 +381,28 @@ This is the declarative counterpart of 'gexp->derivation'."
          (apply gexp->derivation name gexp options)))))
 
 (define-record-type <program-file>
-  (%program-file name gexp guile)
+  (%program-file name gexp guile path)
   program-file?
   (name       program-file-name)                  ;string
   (gexp       program-file-gexp)                  ;gexp
-  (guile      program-file-guile))                ;package
+  (guile      program-file-guile)                 ;package
+  (path       program-file-module-path))          ;list of strings
 
-(define* (program-file name gexp #:key (guile #f))
+(define* (program-file name gexp #:key (guile #f) (module-path %load-path))
   "Return an object representing the executable store item NAME that runs
-GEXP.  GUILE is the Guile package used to execute that script.
+GEXP.  GUILE is the Guile package used to execute that script.  Imported
+modules of GEXP are looked up in MODULE-PATH.
 
 This is the declarative counterpart of 'gexp->script'."
-  (%program-file name gexp guile))
+  (%program-file name gexp guile module-path))
 
 (define-gexp-compiler (program-file-compiler (file <program-file>)
                                              system target)
   ;; Compile FILE by returning a derivation that builds the script.
   (match file
-    (($ <program-file> name gexp guile)
+    (($ <program-file> name gexp guile module-path)
      (gexp->script name gexp
+                   #:module-path module-path
                    #:guile (or guile (default-guile))))))
 
 (define-record-type <scheme-file>
@@ -1116,11 +1120,14 @@ they can refer to each other."
   (module-ref (resolve-interface '(gnu packages guile))
               'guile-2.2))
 
-(define (load-path-expression modules)
+(define* (load-path-expression modules #:optional (path %load-path))
   "Return as a monadic value a gexp that sets '%load-path' and
-'%load-compiled-path' to point to MODULES, a list of module names."
-  (mlet %store-monad ((modules  (imported-modules modules))
-                      (compiled (compiled-modules modules)))
+'%load-compiled-path' to point to MODULES, a list of module names.  MODULES
+are searched for in PATH."
+  (mlet %store-monad ((modules  (imported-modules modules
+                                                  #:module-path path))
+                      (compiled (compiled-modules modules
+                                                  #:module-path path)))
     (return (gexp (eval-when (expand load eval)
                     (set! %load-path
                       (cons (ungexp modules) %load-path))
@@ -1129,11 +1136,13 @@ they can refer to each other."
                             %load-compiled-path)))))))
 
 (define* (gexp->script name exp
-                       #:key (guile (default-guile)))
+                       #:key (guile (default-guile))
+                       (module-path %load-path))
   "Return an executable script NAME that runs EXP using GUILE, with EXP's
-imported modules in its search path."
+imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
-                       (load-path-expression (gexp-modules exp))))
+                       (load-path-expression (gexp-modules exp)
+                                             module-path)))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1148,12 +1157,16 @@ imported modules in its search path."
 
                            (write '(ungexp set-load-path) port)
                            (write '(ungexp exp) port)
-                           (chmod port #o555)))))))
+                           (chmod port #o555))))
+                      #:module-path module-path)))
 
-(define* (gexp->file name exp #:key (set-load-path? #t))
+(define* (gexp->file name exp #:key
+                     (set-load-path? #t)
+                     (module-path %load-path))
   "Return a derivation that builds a file NAME containing EXP.  When
 SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path'
-and '%load-compiled-path' to honor EXP's imported modules."
+and '%load-compiled-path' to honor EXP's imported modules.  Lookup EXP's
+modules in MODULE-PATH."
   (match (if set-load-path? (gexp-modules exp) '())
     (()                                           ;zero modules
      (gexp->derivation name
@@ -1164,13 +1177,15 @@ and '%load-compiled-path' to honor EXP's imported modules."
                        #:local-build? #t
                        #:substitutable? #f))
     ((modules ...)
-     (mlet %store-monad ((set-load-path (load-path-expression modules)))
+     (mlet %store-monad ((set-load-path (load-path-expression modules
+                                                              module-path)))
        (gexp->derivation name
                          (gexp
                           (call-with-output-file (ungexp output)
                             (lambda (port)
                               (write '(ungexp set-load-path) port)
                               (write '(ungexp exp) port))))
+                         #:module-path module-path
                          #:local-build? #t
                          #:substitutable? #f)))))
 
diff --git a/guix/git.scm b/guix/git.scm
index d31c35f64f..103749d0e2 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -147,6 +147,13 @@ Git repositories are kept in the cache directory specified by
      (when cache-exists?
        (remote-fetch (remote-lookup repository "origin")))
      (switch-to-ref repository ref)
+
+     ;; Reclaim file descriptors and memory mappings associated with
+     ;; REPOSITORY as soon as possible.
+     (when (module-defined? (resolve-interface '(git repository))
+                            'repository-close!)
+       (repository-close! repository))
+
      (copy-to-store store cache-dir
                     #:url url
                     #:repository repository))))
diff --git a/guix/modules.scm b/guix/modules.scm
index 6c602eda48..bf656bb241 100644
--- a/guix/modules.scm
+++ b/guix/modules.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +29,7 @@
             file-name->module-name
             module-name->file-name
 
+            source-module-dependencies
             source-module-closure
             live-module-closure
             guix-module-name?))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 57f2d82c5c..401087e830 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -69,13 +69,21 @@
 found.  Return #f if no build log was found."
   (define (valid-url? url)
     ;; Probe URL and return #t if it is accessible.
-    (catch 'getaddrinfo-error
+    (catch #t
       (lambda ()
         (guard (c ((http-get-error? c) #f))
           (close-port (http-fetch url #:buffered? #f))
           #t))
-      (lambda _
-        #f)))
+      (match-lambda*
+        (('getaddrinfo-error . _)
+         #f)
+        (('tls-certificate-error args ...)
+         (report-error (G_ "cannot access build log at '~a':~%") url)
+         (print-exception (current-error-port) #f
+                          'tls-certificate-error args)
+         (exit 1))
+        ((key . args)
+         (apply throw key args)))))
 
   (define (find-url file)
     (let ((base (basename file)))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 4f88c513c0..f8a9702b30 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -332,7 +332,7 @@ packages."
                   (let ((module (make-user-module '())))
                     (packages->outputs (load* file module) mode)))
                  (('manifest . file)
-                  (let ((module (make-user-module '())))
+                  (let ((module (make-user-module '((guix profiles) (gnu)))))
                     (manifest->outputs (load* file module))))
                  (_ '(#f)))
                opts)))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index a31d2236b0..e4ed7227ff 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -61,6 +61,8 @@ Invoke the garbage collector.\n"))
   -R, --requisites       list the requisites of PATHS"))
   (display (G_ "
       --referrers        list the referrers of PATHS"))
+  (display (G_ "
+      --derivers         list the derivers of PATHS"))
   (newline)
   (display (G_ "
       --verify[=OPTS]    verify the integrity of the store; OPTS is a
@@ -153,6 +155,10 @@ Invoke the garbage collector.\n"))
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-referrers
                               (alist-delete 'action result))))
+        (option '("derivers") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-derivers
+                              (alist-delete 'action result))))
         (option '("list-failures") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-failures
@@ -241,6 +247,8 @@ Invoke the garbage collector.\n"))
                            (requisites store (list item)))))
         ((list-referrers)
          (list-relatives referrers))
+        ((list-derivers)
+         (list-relatives valid-derivers))
         ((optimize)
          (assert-no-extra-arguments)
          (optimize-store store))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 78f09f181b..346ca4ea88 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.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.
 ;;;
@@ -27,9 +27,11 @@
   #:use-module (guix gexp)
   #:use-module (guix derivations)
   #:use-module (guix memoization)
+  #:use-module (guix modules)
   #:use-module ((guix build-system gnu) #:select (standard-packages))
   #:use-module (gnu packages)
   #:use-module (guix sets)
+  #:use-module ((guix utils) #:select (location-file))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -44,6 +46,7 @@
             %derivation-node-type
             %reference-node-type
             %referrer-node-type
+            %module-node-type
             %node-types
 
             guix-graph))
@@ -332,6 +335,36 @@ substitutes."
 
 
 ;;;
+;;; Scheme modules.
+;;;
+
+(define (module-from-package package)
+  (file-name->module-name (location-file (package-location package))))
+
+(define (source-module-dependencies* module)
+  "Like 'source-module-dependencies' but filter out modules that are not
+package modules, while attempting to retain user package modules."
+  (remove (match-lambda
+            (('guix _ ...) #t)
+            (('system _ ...) #t)
+            (('language _ ...) #t)
+            (('ice-9 _ ...) #t)
+            (('srfi _ ...) #t)
+            (_ #f))
+          (source-module-dependencies module)))
+
+(define %module-node-type
+  ;; Show the graph of package modules.
+  (node-type
+   (name "module")
+   (description "the graph of package modules")
+   (convert (lift1 (compose list module-from-package) %store-monad))
+   (identifier (lift1 identity %store-monad))
+   (label object->string)
+   (edges (lift1 source-module-dependencies* %store-monad))))
+
+
+;;;
 ;;; List of node types.
 ;;;
 
@@ -344,7 +377,8 @@ substitutes."
         %bag-emerged-node-type
         %derivation-node-type
         %reference-node-type
-        %referrer-node-type))
+        %referrer-node-type
+        %module-node-type))
 
 (define (lookup-node-type name)
   "Return the node type called NAME.  Raise an error if it is not found."
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 59dd117edb..488638adc5 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,7 +34,9 @@
   #:use-module (guix derivations)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
+  #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages guile)
   #:autoload   (gnu packages base) (tar)
   #:autoload   (gnu packages package-management) (guix)
   #:autoload   (gnu packages gnupg) (libgcrypt)
@@ -67,6 +70,11 @@
                     #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
         (compressor "none" "" #f)))
 
+;; This one is only for use in this module, so don't put it in %compressors.
+(define bootstrap-xz
+  (compressor "bootstrap-xz" ".xz"
+              #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e -T0")))
+
 (define (lookup-compressor name)
   "Return the compressor object called NAME.  Error out if it could not be
 found."
@@ -230,6 +238,7 @@ the image."
   (define build
     (with-imported-modules `(,@(source-module-closure '((guix docker))
                                                       #:select? not-config?)
+                             (guix build store-copy)
                              ((guix config) => ,config))
       #~(begin
           ;; Guile-JSON is required by (guix docker).
@@ -237,13 +246,15 @@ the image."
            (string-append #+json "/share/guile/site/"
                           (effective-version)))
 
-          (use-modules (guix docker) (srfi srfi-19))
+          (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
 
           (setenv "PATH" (string-append #$tar "/bin"))
 
-          (build-docker-image #$output #$profile
+          (build-docker-image #$output
+                              (call-with-input-file "profile"
+                                read-reference-graph)
+                              #$profile
                               #:system (or #$target (utsname:machine (uname)))
-                              #:closure "profile"
                               #:symlinks '#$symlinks
                               #:compressor '#$(compressor-command compressor)
                               #:creation-time (make-time time-utc 0 1)))))
@@ -325,6 +336,9 @@ the image."
          (option '("localstatedir") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'localstatedir? #t result)))
+         (option '("bootstrap") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'bootstrap? #t result)))
 
          (append %transformation-options
                  %standard-build-options)))
@@ -352,6 +366,8 @@ Create a bundle of PACKAGE.\n"))
   -m, --manifest=FILE    create a pack with the manifest from FILE"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
+  (display (G_ "
+      --bootstrap        use the bootstrap binaries to build the pack"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -393,28 +409,43 @@ Create a bundle of PACKAGE.\n"))
        (else (packages->manifest packages)))))
 
   (with-error-handling
-    (parameterize ((%graft? (assoc-ref opts 'graft?)))
-      (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-             (manifest    (manifest-from-args opts))
-             (pack-format (assoc-ref opts 'format))
-             (name        (string-append (symbol->string pack-format)
-                                         "-pack"))
-             (target      (assoc-ref opts 'target))
-             (compressor  (assoc-ref opts 'compressor))
-             (symlinks    (assoc-ref opts 'symlinks))
-             (build-image (match (assq-ref %formats pack-format)
-                            ((? procedure? proc) proc)
-                            (#f
-                             (leave (G_ "~a: unknown pack format")
-                                    format))))
-             (localstatedir? (assoc-ref opts 'localstatedir?)))
-        (with-store store
+    (let* ((dry-run?    (assoc-ref opts 'dry-run?))
+           (manifest    (manifest-from-args opts))
+           (pack-format (assoc-ref opts 'format))
+           (name        (string-append (symbol->string pack-format)
+                                       "-pack"))
+           (target      (assoc-ref opts 'target))
+           (bootstrap?  (assoc-ref opts 'bootstrap?))
+           (compressor  (if bootstrap?
+                            bootstrap-xz
+                            (assoc-ref opts 'compressor)))
+           (tar         (if bootstrap?
+                            %bootstrap-coreutils&co
+                            tar))
+           (symlinks    (assoc-ref opts 'symlinks))
+           (build-image (match (assq-ref %formats pack-format)
+                          ((? procedure? proc) proc)
+                          (#f
+                           (leave (G_ "~a: unknown pack format")
+                                  format))))
+           (localstatedir? (assoc-ref opts 'localstatedir?)))
+      (with-store store
+        (parameterize ((%graft? (assoc-ref opts 'graft?))
+                       (%guile-for-build (package-derivation
+                                          store
+                                          (if (assoc-ref opts 'bootstrap?)
+                                              %bootstrap-guile
+                                              (canonical-package guile-2.2)))))
           ;; Set the build options before we do anything else.
           (set-build-options-from-command-line store opts)
 
           (run-with-store store
             (mlet* %store-monad ((profile (profile-derivation
                                            manifest
+                                           #:hooks (if bootstrap?
+                                                       '()
+                                                       %default-profile-hooks)
+                                           #:locales? (not bootstrap?)
                                            #:target target))
                                  (drv (build-image name profile
                                                    #:target
@@ -424,7 +455,9 @@ Create a bundle of PACKAGE.\n"))
                                                    #:symlinks
                                                    symlinks
                                                    #:localstatedir?
-                                                   localstatedir?)))
+                                                   localstatedir?
+                                                   #:tar
+                                                   tar)))
               (mbegin %store-monad
                 (show-what-to-build* (list drv)
                                      #:use-substitutes?
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f0c4a2ba1b..b50cabcd1a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
-;;; Copyright © 2016, 2017 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -701,7 +701,9 @@ checking this by themselves in their 'check' procedure."
                                  ("iso9660" "image.iso")
                                  (_         "disk-image"))
                         #:disk-image-size image-size
-                        #:file-system-type file-system-type))))
+                        #:file-system-type file-system-type))
+    ((docker-image)
+     (system-docker-image os #:register-closures? #t))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -905,6 +907,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "\
    disk-image       build a disk image, suitable for a USB stick\n"))
   (display (G_ "\
+   docker-image     build a Docker image\n"))
+  (display (G_ "\
    init             initialize a root file system to run GNU\n"))
   (display (G_ "\
    extension-graph  emit the service extension graph in Dot format\n"))
@@ -1142,7 +1146,7 @@ argument list and OPTS is the option alist."
           (case action
             ((build container vm vm-image disk-image reconfigure init
               extension-graph shepherd-graph list-generations roll-back
-              switch-generation search)
+              switch-generation search docker-image)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -1171,7 +1175,7 @@ argument list and OPTS is the option alist."
         (exit 1))
 
       (case action
-        ((build container vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image docker-image reconfigure)
          (unless (or (= count 1)
                      (and expr (= count 0)))
            (fail)))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 2e782e36ce..5c934abaef 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -29,11 +29,14 @@
   #:use-module (guix grafts)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
   #:use-module (guix scripts substitute)
+  #:use-module (guix http-client)
+  #:use-module (guix ci)
   #:use-module (gnu packages)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -100,6 +103,57 @@ values."
 (define-syntax-rule (let/time ((time result exp)) body ...)
   (call-with-time (lambda () exp) (lambda (time result) body ...)))
 
+(define (histogram field proc seed lst)
+  "Return an alist giving a histogram of all the values of FIELD for elements
+of LST. FIELD must be a one element procedure that returns a field's value.
+For each FIELD value, call PROC with the previous field-specific result.
+Example:
+
+  (histogram car (lambda (x n) (+ 1 n)) 0 '((a . x)(b . y)(a . z)))
+  => ((a . 2) (b . 1))
+
+meaning that we have two a's and one b."
+  (let loop ((lst lst)
+             (result '()))
+    (match lst
+      (()
+       result)
+      ((head . tail)
+       (let ((value (field head)))
+         (loop tail
+               (match (assoc-ref result value)
+                 (#f
+                  `((,value . ,(proc head seed)) ,@result))
+                 (previous
+                  `((,value . ,(proc head previous))
+                    ,@(alist-delete value result))))))))))
+
+(define (throughput lst timestamp)
+  "Return the throughput, in items per second, given the elements of LST,
+calling TIMESTAMP to get the \"timestamp\" of each item."
+  (let ((oldest (reduce min +inf.0 (map build-timestamp lst)))
+        (now    (time-second (current-time time-utc))))
+    (/ (length lst) (- now oldest) 1.)))
+
+(define (queued-subset queue items)
+  "Return the subset of ITEMS, a list of store file names, that appears in
+QUEUE, a list of builds.  Return #f if elements in QUEUE lack information
+about the derivations queued, as is the case with Hydra."
+  (define queued
+    (append-map (lambda (build)
+                  (match (false-if-exception
+                          (read-derivation-from-file (build-derivation build)))
+                    (#f
+                     '())
+                    (drv
+                     (match (derivation->output-paths drv)
+                       (((names . items) ...) items)))))
+                queue))
+
+  (if (any (negate build-derivation) queue)
+      #f                                          ;no derivation information
+      (lset-intersection string=? queued items)))
+
 (define (report-server-coverage server items)
   "Report the subset of ITEMS available as substitutes on SERVER."
   (define MiB (* (expt 2 20) 1.))
@@ -111,6 +165,8 @@ values."
     (format #t "~a~%" server)
     (let ((obtained  (length narinfos))
           (requested (length items))
+          (missing   (lset-difference string=?
+                                      items (map narinfo-path narinfos)))
           (sizes     (filter-map narinfo-file-size narinfos))
           (time      (+ (time-second time)
                         (/ (time-nanosecond time) 1e9))))
@@ -131,7 +187,56 @@ values."
       (format #t (G_ "  ~,3h seconds per request (~,1h seconds in total)~%")
               (/ time requested 1.) time)
       (format #t (G_ "  ~,1h requests per second~%")
-              (/ requested time 1.)))))
+              (/ requested time 1.))
+
+      (guard (c ((http-get-error? c)
+                 (if (= 404 (http-get-error-code c))
+                     (format (current-error-port)
+                             (G_ "  (continuous integration information \
+unavailable)~%"))
+                     (format (current-error-port)
+                             (G_ "  '~a' returned ~a (~s)~%")
+                             (uri->string (http-get-error-uri c))
+                             (http-get-error-code c)
+                             (http-get-error-reason c)))))
+        (let* ((max    %query-limit)
+               (queue  (queued-builds server max))
+               (len    (length queue))
+               (histo  (histogram build-system
+                                  (lambda (build count)
+                                    (+ 1 count))
+                                  0 queue)))
+          (newline)
+          (unless (null? missing)
+            (let ((missing (length missing)))
+              (match (queued-subset queue missing)
+                (#f #f)
+                ((= length queued)
+                 (format #t (G_ "  ~,1f% (~h out of ~h) of the missing items \
+are queued~%")
+                         (* 100. (/ queued missing))
+                         queued missing)))))
+
+          (if (>= len max)
+              (format #t (G_ "  at least ~h queued builds~%") len)
+              (format #t (G_ "  ~h queued builds~%") len))
+          (for-each (match-lambda
+                      ((system . count)
+                       (format #t (G_ "      ~a: ~a (~0,1f%)~%")
+                               system count (* 100. (/ count len)))))
+                    histo))
+
+        (let* ((latest     (latest-builds server))
+               (builds/sec (throughput latest build-timestamp)))
+          (format #t (G_ "  build rate: ~1,2f builds per hour~%")
+                  (* builds/sec 3600.))
+          (for-each (match-lambda
+                      ((system . builds)
+                       (format #t (G_ "      ~a: ~,2f builds per hour~%")
+                               system
+                               (* (throughput builds build-timestamp)
+                                  3600.))))
+                    (histogram build-system cons '() latest)))))))
 
 
 ;;;