Merge branch 'staging' into core-updates

26 files changed, 1025 insertions, 121 deletions

diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index 664515d0ee..e7214155be 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -53,7 +53,7 @@ release corresponding to NAME and VERSION."
   (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/"
                        name "_" version ".tar.gz")
         ;; TODO: use %bioconductor-version from (guix import cran)
-        (string-append "https://bioconductor.org/packages/3.8/bioc/src/contrib/Archive/"
+        (string-append "https://bioconductor.org/packages/3.9/bioc/src/contrib/Archive/"
                        name "_" version ".tar.gz")))
 
 (define %r-build-system-modules
diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
new file mode 100644
index 0000000000..86ee11391d
--- /dev/null
+++ b/guix/build/bzr.scm
@@ -0,0 +1,44 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@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 bzr)
+  #:use-module (guix build utils)
+  #:export (bzr-fetch))
+
+;;; Commentary:
+;;;
+;;; This is the build-side support code of (guix bzr-download).  It allows a
+;;; Bazaar repository to be branched at a specific revision.
+;;;
+;;; Code:
+
+(define* (bzr-fetch url revision directory
+                    #:key (bzr-command "bzr"))
+  "Fetch REVISION from URL into DIRECTORY.  REVISION must be a valid Bazaar
+revision identifier.  Return #t on success, else throw an exception."
+  ;; Do not attempt to write .bzr.log to $HOME, which doesn't exist.
+  (setenv "BZR_LOG" "/dev/null")
+  ;; Disable SSL certificate verification; we rely on the hash instead.
+  (invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
+          "--lightweight" "-r" revision url directory)
+  (with-directory-excursion directory
+    (begin
+      (delete-file-recursively ".bzr")
+      #t)))
+
+;;; bzr.scm ends here
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index b68a1f90d2..9f44bd6ee9 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -131,7 +131,7 @@ directory = '" port)
     ;; to store paths.
     (copy-recursively "." rsrc)
     (touch (string-append rsrc "/.cargo-ok"))
-    (generate-checksums rsrc "/dev/null")
+    (generate-checksums rsrc)
     (install-file "Cargo.toml" rsrc)
     #t))
 
diff --git a/guix/build/cargo-utils.scm b/guix/build/cargo-utils.scm
index 6af572e611..79e5440378 100644
--- a/guix/build/cargo-utils.scm
+++ b/guix/build/cargo-utils.scm
@@ -41,12 +41,10 @@
       (close-pipe port)
       result)))
 
-(define (generate-checksums dir-name src-name)
+(define (generate-checksums dir-name)
   "Given DIR-NAME, a store directory, checksum all the files in it one
 by one and put the result into the file \".cargo-checksum.json\" in
-the same directory.  Also includes the checksum of an extra file
-SRC-NAME as if it was part of the directory DIR-NAME with name
-\"package\"."
+the same directory."
   (let* ((file-names (find-files dir-name "."))
          (dir-prefix-name (string-append dir-name "/"))
          (dir-prefix-name-len (string-length dir-prefix-name))
@@ -62,6 +60,9 @@ SRC-NAME as if it was part of the directory DIR-NAME with name
                   (write file-relative-name port)
                   (display ":" port)
                   (write (file-sha256 file-name) port))) file-names))
+        ;; NB: cargo requires the "package" field in order to check if the Cargo.lock
+        ;; file needs to be regenerated when the value changes. However, it doesn't
+        ;; appear to care what the value is to begin with...
         (display "},\"package\":" port)
-        (write (file-sha256 src-name) port)
+        (write (file-sha256 "/dev/null") port)
         (display "}" port)))))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a64e0f0bd3..0c9c61de4b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -380,6 +380,20 @@ ETIMEDOUT error is raised."
               (apply throw args)
               (loop (cdr addresses))))))))
 
+(define (setup-http-tunnel port uri)
+  "Establish over PORT an HTTP tunnel to the destination server of URI."
+  (define target
+    (string-append (uri-host uri) ":"
+                   (number->string
+                    (or (uri-port uri)
+                        (match (uri-scheme uri)
+                          ('http 80)
+                          ('https 443))))))
+  (format port "CONNECT ~a HTTP/1.1\r\n" target)
+  (format port "Host: ~a\r\n\r\n" target)
+  (force-output port)
+  (read-response port))
+
 (define* (open-connection-for-uri uri
                                   #:key
                                   timeout
@@ -393,21 +407,20 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
   (define https?
     (eq? 'https (uri-scheme uri)))
 
+  (define https-proxy (let ((proxy (getenv "https_proxy")))
+                        (and (not (equal? proxy ""))
+                             proxy)))
+
   (let-syntax ((with-https-proxy
                 (syntax-rules ()
                   ((_ exp)
                    ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
-                   ;; FIXME: Proxying is not supported for https.
                    (let ((thunk (lambda () exp)))
                      (if (and https?
                               (module-variable
                                (resolve-interface '(web client))
                                'current-http-proxy))
-                         (parameterize ((current-http-proxy #f))
-                           (when (and=> (getenv "https_proxy")
-                                        (negate string-null?))
-                             (format (current-error-port)
-                                     "warning: 'https_proxy' is ignored~%"))
+                         (parameterize ((current-http-proxy https-proxy))
                            (thunk))
                          (thunk)))))))
     (with-https-proxy
@@ -415,6 +428,9 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
        ;; Buffer input and output on this port.
        (setvbuf s 'block %http-receive-buffer-size)
 
+       (when (and https? https-proxy)
+         (setup-http-tunnel s uri))
+
        (if https?
            (tls-wrap s (uri-host uri)
                      #:verify-certificate? verify-certificate?)
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 282df19f24..858068ba98 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Petter <petter@mykolab.ch>
 ;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module (guix build union)
   #:use-module (guix build utils)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
@@ -151,22 +153,40 @@ dependencies, so it should be self-contained."
   #t)
 
 (define* (unpack #:key source import-path unpack-path #:allow-other-keys)
-  "Relative to $GOPATH, unpack SOURCE in the UNPACK-PATH, or the IMPORT-PATH is
-the UNPACK-PATH is unset.  When SOURCE is a directory, copy it instead of
+  "Relative to $GOPATH, unpack SOURCE in UNPACK-PATH, or IMPORT-PATH when
+UNPACK-PATH is unset.  If the SOURCE archive has a single top level directory,
+it is stripped so that the sources appear directly under UNPACK-PATH.  When
+SOURCE is a directory, copy its content into UNPACK-PATH instead of
 unpacking."
-  (if (string-null? import-path)
-      ((display "WARNING: The Go import path is unset.\n")))
-  (if (string-null? unpack-path)
-      (set! unpack-path import-path))
+  (define (unpack-maybe-strip source dest)
+    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
+                                       "/scratch-dir"))
+           (out (mkdir-p scratch-dir)))
+      (with-directory-excursion scratch-dir
+        (if (string-suffix? ".zip" source)
+            (invoke "unzip" source)
+            (invoke "tar" "-xvf" source))
+        (let ((top-level-files (remove (lambda (x)
+                                         (member x '("." "..")))
+                                       (scandir "."))))
+          (match top-level-files
+            ((top-level-file)
+             (when (file-is-directory? top-level-file)
+               (copy-recursively top-level-file dest #:keep-mtime? #t)))
+            (_
+             (copy-recursively "." dest #:keep-mtime? #t)))))
+      (delete-file-recursively scratch-dir)))
+
+  (when (string-null? import-path)
+    (display "WARNING: The Go import path is unset.\n"))
+  (when (string-null? unpack-path)
+    (set! unpack-path import-path))
   (let ((dest (string-append (getenv "GOPATH") "/src/" unpack-path)))
     (mkdir-p dest)
     (if (file-is-directory? source)
-      (begin
         (copy-recursively source dest #:keep-mtime? #t)
-        #t)
-      (if (string-suffix? ".zip" source)
-        (invoke "unzip" "-d" dest source)
-        (invoke "tar" "-C" dest "-xvf" source)))))
+        (unpack-maybe-strip source dest)))
+  #t)
 
 (define (go-package? name)
   (string-prefix? "go-" name))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 749616ceb1..3abe65bc4f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -104,6 +104,7 @@
             network-interface-netmask
             network-interface-running?
             loopback-network-interface?
+            arp-network-interface?
             network-interface-address
             set-network-interface-netmask
             set-network-interface-up
@@ -1160,6 +1161,7 @@ bytes."
 (define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
 (define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
 (define-as-needed IFF_RUNNING #x40)               ;interface RFC2863 OPER_UP
+(define-as-needed IFF_NOARP #x80)                 ;ARP disabled or unsupported
 
 (define IF_NAMESIZE 16)                           ;maximum interface name size
 
@@ -1341,6 +1343,13 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_RUNNING)))))
 
+(define (arp-network-interface? name)
+  "Return true if NAME supports the Address Resolution Protocol."
+  (let* ((sock  (socket SOCK_STREAM AF_INET 0))
+         (flags (network-interface-flags sock name)))
+    (close-port sock)
+    (zero? (logand flags IFF_NOARP))))
+
 (define-as-needed (set-network-interface-flags socket name flags)
   "Set the flag of network interface NAME to FLAGS."
   (let ((req (make-bytevector ifreq-struct-size)))
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
new file mode 100644
index 0000000000..d30833c5d7
--- /dev/null
+++ b/guix/bzr-download.scm
@@ -0,0 +1,85 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@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 bzr-download)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)   ;for 'source-module-closure'
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix store)
+
+  #:export (bzr-reference
+            bzr-reference?
+            bzr-reference-url
+            bzr-reference-revision
+
+            bzr-fetch))
+
+;;; Commentary:
+;;;
+;;; An <origin> method that fetches a specific revision from a Bazaar
+;;; repository.  The repository URL and revision identifier are specified with
+;;; a <bzr-reference> object.
+;;;
+;;; Code:
+
+(define-record-type* <bzr-reference>
+  bzr-reference make-bzr-reference
+  bzr-reference?
+  (url bzr-reference-url)
+  (revision bzr-reference-revision))
+
+(define (bzr-package)
+  "Return the default Bazaar package."
+  (let ((distro (resolve-interface '(gnu packages version-control))))
+    (module-ref distro 'bazaar)))
+
+(define* (bzr-fetch ref hash-algo hash
+                       #:optional name
+                       #:key (system (%current-system)) (guile (default-guile))
+                       (bzr (bzr-package)))
+  "Return a fixed-output derivation that fetches REF, a <bzr-reference>
+object.  The output is expected to have recursive hash HASH of type
+HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
+  (define build
+    (with-imported-modules (source-module-closure
+                            '((guix build bzr)))
+      #~(begin
+          (use-modules (guix build bzr))
+          (bzr-fetch
+           (getenv "bzr url") (getenv "bzr reference") #$output
+           #:bzr-command (string-append #+bzr "/bin/bzr")))))
+
+  (mlet %store-monad ((guile (package->derivation guile system)))
+    (gexp->derivation (or name "bzr-branch") build
+                      ;; Use environment variables and a fixed script name so
+                      ;; there's only one script in store for all the
+                      ;; downloads.
+                      #:script-name "bzr-download"
+                      #:env-vars
+                      `(("bzr url" . ,(bzr-reference-url ref))
+                        ("bzr reference" . ,(bzr-reference-revision ref)))
+                      #:system system
+                      #:local-build? #t  ;don't offload repo branching
+                      #:hash-algo hash-algo
+                      #:hash hash
+                      #:recursive? #t
+                      #:guile-for-build guile)))
+
+;;; bzr-download.scm ends here
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 247b15ed81..0ada0f3c38 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -34,6 +34,7 @@
 
             %system
             %libz
+            %liblz
             %gzip
             %bzip2
             %xz))
@@ -90,6 +91,9 @@
 (define %libz
   "@LIBZ@")
 
+(define %liblz
+  "@LIBLZ@")
+
 (define %gzip
   "@GZIP@")
 
diff --git a/guix/docker.scm b/guix/docker.scm
index c6e9c6fee5..7fe83d9797 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -73,7 +73,7 @@
   `((,(generate-tag path) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
-(define (config layer time arch)
+(define* (config layer time arch #:key entry-point)
   "Generate a minimal image configuration for the given LAYER file."
   ;; "architecture" must be values matching "platform.arch" in the
   ;; runtime-spec at
@@ -81,7 +81,9 @@
   `((architecture . ,arch)
     (comment . "Generated by GNU Guix")
     (created . ,time)
-    (config . #nil)
+    (config . ,(if entry-point
+                   `((entrypoint . ,entry-point))
+                   #nil))
     (container_config . #nil)
     (os . "linux")
     (rootfs . ((type . "layers")
@@ -110,6 +112,7 @@ return \"a\"."
                              (transformations '())
                              (system (utsname:machine (uname)))
                              database
+                             entry-point
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
@@ -118,6 +121,9 @@ must be a store path that is a prefix of any store paths in PATHS.
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
 
+When ENTRY-POINT is true, it must be a list of strings; it is stored as the
+entry point in the Docker image JSON structure.
+
 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
@@ -227,7 +233,8 @@ SRFI-19 time-utc object, as the creation time in metadata."
       (with-output-to-file "config.json"
         (lambda ()
           (scm->json (config (string-append id "/layer.tar")
-                             time arch))))
+                             time arch
+                             #:entry-point entry-point))))
       (with-output-to-file "manifest.json"
         (lambda ()
           (scm->json (manifest prefix id))))
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 36b3c930d7..a434a39f2d 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -79,7 +79,7 @@
 ;;;
 
 (define %gnumaint-base-url
-  "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/")
+  "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
 
 (define %package-list-url
   (string->uri
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index b287be6941..4763fccd36 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -128,9 +128,9 @@ package definition."
 (define %cran-url "https://cran.r-project.org/web/packages/")
 (define %bioconductor-url "https://bioconductor.org/packages/")
 
-;; The latest Bioconductor release is 3.8.  Bioconductor packages should be
+;; The latest Bioconductor release is 3.9.  Bioconductor packages should be
 ;; updated together.
-(define %bioconductor-version "3.8")
+(define %bioconductor-version "3.9")
 
 (define %bioconductor-packages-list-url
   (string-append "https://bioconductor.org/packages/"
@@ -237,6 +237,11 @@ empty list when the FIELD cannot be found."
         "translations"
         "utils"))
 
+;; The field for system dependencies is often abused to specify non-package
+;; dependencies (such as c++11).  This list is used to ignore them.
+(define invalid-packages
+  (list "c++11"))
+
 (define cran-guix-name (cut guix-name "r-" <>))
 
 (define (needs-fortran? tarball)
@@ -310,7 +315,8 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                       (if (needs-zlib? tarball) '("zlib") '())
                       (map string-downcase (listify meta "SystemRequirements"))))
          (propagate  (filter (lambda (name)
-                               (not (member name default-r-packages)))
+                               (not (member name (append default-r-packages
+                                                         invalid-packages))))
                              (lset-union equal?
                                          (listify meta "Imports")
                                          (listify meta "LinkingTo")
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 4d12339204..cdac70420a 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -174,6 +174,29 @@ the package e.g. 'bedtools2'.  Return #f if there is no releases"
   (define (pre-release? x)
     (hash-ref x "prerelease"))
 
+  (define (release->version release)
+    (let ((tag (or (hash-ref release "tag_name") ;a "release"
+                   (hash-ref release "name")))   ;a tag
+          (name-length (string-length package-name)))
+      (cond
+       ;; some tags include the name of the package e.g. "fdupes-1.51"
+       ;; so remove these
+       ((and (< name-length (string-length tag))
+             (string=? (string-append package-name "-")
+                       (substring tag 0 (+ name-length 1))))
+        (substring tag (+ name-length 1)))
+       ;; some tags start with a "v" e.g. "v0.25.0"
+       ;; where some are just the version number
+       ((string-prefix? "v" tag)
+        (substring tag 1))
+       ;; Finally, reject tags that don't start with a digit:
+       ;; they may not represent a release.
+       ((and (not (string-null? tag))
+             (char-set-contains? char-set:digit
+                                 (string-ref tag 0)))
+        tag)
+       (else #f))))
+
   (let* ((json (fetch-releases-or-tags url)))
     (if (eq? json #f)
         (if (%github-token)
@@ -183,32 +206,13 @@ API when using a GitHub token")
 API. This may be fixed by using an access token and setting the environment
 variable GUIX_GITHUB_TOKEN, for instance one procured from
 https://github.com/settings/tokens"))
-        (any
-         (lambda (release)
-           (let ((tag (or (hash-ref release "tag_name") ;a "release"
-                          (hash-ref release "name")))   ;a tag
-                 (name-length (string-length package-name)))
-             (cond
-              ;; some tags include the name of the package e.g. "fdupes-1.51"
-              ;; so remove these
-              ((and (< name-length (string-length tag))
-                    (string=? (string-append package-name "-")
-                              (substring tag 0 (+ name-length 1))))
-               (substring tag (+ name-length 1)))
-              ;; some tags start with a "v" e.g. "v0.25.0"
-              ;; where some are just the version number
-              ((string-prefix? "v" tag)
-               (substring tag 1))
-              ;; Finally, reject tags that don't start with a digit:
-              ;; they may not represent a release.
-              ((and (not (string-null? tag))
-                    (char-set-contains? char-set:digit
-                                        (string-ref tag 0)))
-               tag)
-              (else #f))))
-         (match (remove pre-release? json)
-           (() json) ; keep everything
-           (releases releases))))))
+        (match (sort (filter-map release->version
+                                 (match (remove pre-release? json)
+                                   (() json) ; keep everything
+                                   (releases releases)))
+                     version>?)
+          ((latest-release . _) latest-release)
+          (() #f)))))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
diff --git a/guix/lzlib.scm b/guix/lzlib.scm
new file mode 100644
index 0000000000..a6dac46049
--- /dev/null
+++ b/guix/lzlib.scm
@@ -0,0 +1,625 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
+;;;
+;;; 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 lzlib)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs arithmetic bitwise)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (system foreign)
+  #:use-module (guix config)
+  #:export (lzlib-available?
+            make-lzip-input-port
+            make-lzip-output-port
+            call-with-lzip-input-port
+            call-with-lzip-output-port
+            %default-member-length-limit
+            %default-compression-level))
+
+;;; Commentary:
+;;;
+;;; Bindings to the lzlib / liblz API.  Some convenience functions are also
+;;; provided (see the export).
+;;;
+;;; While the bindings are complete, the convenience functions only support
+;;; single member archives.  To decompress single member archives, we loop
+;;; until lz-decompress-read returns 0.  This is simpler.  To support multiple
+;;; members properly, we need (among others) to call lz-decompress-finish and
+;;; loop over lz-decompress-read until lz-decompress-finished? returns #t.
+;;; Otherwise a multi-member archive starting with an empty member would only
+;;; decompress the empty member and stop there, resulting in truncated output.
+
+;;; Code:
+
+(define %lzlib
+  ;; File name of lzlib's shared library.  When updating via 'guix pull',
+  ;; '%liblz' might be undefined so protect against it.
+  (delay (dynamic-link (if (defined? '%liblz)
+                           %liblz
+                           "liblz"))))
+
+(define (lzlib-available?)
+  "Return true if lzlib is available, #f otherwise."
+  (false-if-exception (force %lzlib)))
+
+(define (lzlib-procedure ret name parameters)
+  "Return a procedure corresponding to C function NAME in liblz, or #f if
+either lzlib or the function could not be found."
+  (match (false-if-exception (dynamic-func name (force %lzlib)))
+    ((? pointer? ptr)
+     (pointer->procedure ret ptr parameters))
+    (#f
+     #f)))
+
+(define-wrapped-pointer-type <lz-decoder>
+  ;; Scheme counterpart of the 'LZ_Decoder' opaque type.
+  lz-decoder?
+  pointer->lz-decoder
+  lz-decoder->pointer
+  (lambda (obj port)
+    (format port "#<lz-decoder ~a>"
+            (number->string (object-address obj) 16))))
+
+(define-wrapped-pointer-type <lz-encoder>
+  ;; Scheme counterpart of the 'LZ_Encoder' opaque type.
+  lz-encoder?
+  pointer->lz-encoder
+  lz-encoder->pointer
+  (lambda (obj port)
+    (format port "#<lz-encoder ~a>"
+            (number->string (object-address obj) 16))))
+
+;; From lzlib.h
+(define %error-number-ok 0)
+(define %error-number-bad-argument 1)
+(define %error-number-mem-error 2)
+(define %error-number-sequence-error 3)
+(define %error-number-header-error 4)
+(define %error-number-unexpected-eof 5)
+(define %error-number-data-error 6)
+(define %error-number-library-error 7)
+
+
+;; Compression bindings.
+
+(define lz-compress-open
+  (let ((proc (lzlib-procedure '* "LZ_compress_open" (list int int uint64)))
+        ;; member-size is an "unsigned long long", and the C standard guarantees
+        ;; a minimum range of 0..2^64-1.
+        (unlimited-size (- (expt 2 64) 1)))
+    (lambda* (dictionary-size match-length-limit #:optional (member-size unlimited-size))
+      "Initialize the internal stream state for compression and returns a
+pointer that can only be used as the encoder argument for the other
+lz-compress functions, or a null pointer if the encoder could not be
+allocated.
+
+See the manual: (lzlib) Compression functions."
+      (let ((encoder-ptr (proc dictionary-size match-length-limit member-size)))
+        (if (not (= (lz-compress-error encoder-ptr) -1))
+            (pointer->lz-encoder encoder-ptr)
+            (throw 'lzlib-error 'lz-compress-open))))))
+
+(define lz-compress-close
+  (let ((proc (lzlib-procedure int "LZ_compress_close" '(*))))
+    (lambda (encoder)
+      "Close encoder.  ENCODER can no longer be used as an argument to any
+lz-compress function. "
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-close ret)
+            ret)))))
+
+(define lz-compress-finish
+  (let ((proc (lzlib-procedure int "LZ_compress_finish" '(*))))
+    (lambda (encoder)
+      "Tell that all the data for this member have already been written (with
+the `lz-compress-write' function).  It is safe to call `lz-compress-finish' as
+many times as needed.  After all the produced compressed data have been read
+with `lz-compress-read' and `lz-compress-member-finished?' returns #t, a new
+member can be started with 'lz-compress-restart-member'."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-finish (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-restart-member
+  (let ((proc (lzlib-procedure int "LZ_compress_restart_member" (list '* uint64))))
+    (lambda (encoder member-size)
+      "Start a new member in a multimember data stream.
+Call this function only after `lz-compress-member-finished?' indicates that the
+current member has been fully read (with the `lz-compress-read' function)."
+      (let ((ret (proc (lz-encoder->pointer encoder) member-size)))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-restart-member
+                   (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-sync-flush
+  (let ((proc (lzlib-procedure int "LZ_compress_sync_flush" (list '*))))
+    (lambda (encoder)
+      "Make available to `lz-compress-read' all the data already written with
+the `LZ-compress-write' function.  First call `lz-compress-sync-flush'.  Then
+call 'lz-compress-read' until it returns 0.
+
+Repeated use of `LZ-compress-sync-flush' may degrade compression ratio,
+so use it only when needed. "
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-sync-flush
+                   (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-read
+  (let ((proc (lzlib-procedure int "LZ_compress_read" (list '* '* int))))
+    (lambda* (encoder lzfile-bv #:optional (start 0) (count (bytevector-length lzfile-bv)))
+      "Read up to COUNT bytes from the encoder stream, storing the results in LZFILE-BV.
+Return the number of uncompressed bytes written, a strictly positive integer."
+      (let ((ret (proc (lz-encoder->pointer encoder)
+                       (bytevector->pointer lzfile-bv start)
+                       count)))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-read (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-write
+  (let ((proc (lzlib-procedure int "LZ_compress_write" (list '* '* int))))
+    (lambda* (encoder bv #:optional (start 0) (count (bytevector-length bv)))
+      "Write up to COUNT bytes from BV to the encoder stream.  Return the
+number of uncompressed bytes written, a strictly positive integer."
+      (let ((ret (proc (lz-encoder->pointer encoder)
+                       (bytevector->pointer bv start)
+                       count)))
+        (if (< ret 0)
+            (throw 'lzlib-error 'lz-compress-write (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-write-size
+  (let ((proc (lzlib-procedure int "LZ_compress_write_size" '(*))))
+    (lambda (encoder)
+      "The maximum number of bytes that can be immediately written through the
+`lz-compress-write' function.
+
+It is guaranteed that an immediate call to `lz-compress-write' will accept a
+SIZE up to the returned number of bytes. "
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-write-size (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-error
+  (let ((proc (lzlib-procedure int "LZ_compress_errno" '(*))))
+    (lambda (encoder)
+      "ENCODER can be a Scheme object or a pointer."
+      (let* ((error-number (proc (if (lz-encoder? encoder)
+                                     (lz-encoder->pointer encoder)
+                                     encoder))))
+        error-number))))
+
+(define lz-compress-finished?
+  (let ((proc (lzlib-procedure int "LZ_compress_finished" '(*))))
+    (lambda (encoder)
+      "Return #t if all the data have been read and `lz-compress-close' can
+be safely called. Otherwise return #f."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (match ret
+          (1 #t)
+          (0 #f)
+          (_ (throw 'lzlib-error 'lz-compress-finished? (lz-compress-error encoder))))))))
+
+(define lz-compress-member-finished?
+  (let ((proc (lzlib-procedure int "LZ_compress_member_finished" '(*))))
+    (lambda (encoder)
+      "Return #t if the current member, in a multimember data stream, has
+been fully read and 'lz-compress-restart-member' can be safely called.
+Otherwise return #f."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (match ret
+          (1 #t)
+          (0 #f)
+          (_ (throw 'lzlib-error 'lz-compress-member-finished? (lz-compress-error encoder))))))))
+
+(define lz-compress-data-position
+  (let ((proc (lzlib-procedure uint64 "LZ_compress_data_position" '(*))))
+    (lambda (encoder)
+      "Return the number of input bytes already compressed in the current
+member."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-data-position
+                   (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-member-position
+  (let ((proc (lzlib-procedure uint64 "LZ_compress_member_position" '(*))))
+    (lambda (encoder)
+      "Return the number of compressed bytes already produced, but perhaps
+not yet read, in the current member."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-member-position
+                   (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-total-in-size
+  (let ((proc (lzlib-procedure uint64 "LZ_compress_total_in_size" '(*))))
+    (lambda (encoder)
+      "Return the total number of input bytes already compressed."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-total-in-size
+                   (lz-compress-error encoder))
+            ret)))))
+
+(define lz-compress-total-out-size
+  (let ((proc (lzlib-procedure uint64 "LZ_compress_total_out_size" '(*))))
+    (lambda (encoder)
+      "Return the total number of compressed bytes already produced, but
+perhaps not yet read."
+      (let ((ret (proc (lz-encoder->pointer encoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-compress-total-out-size
+                   (lz-compress-error encoder))
+            ret)))))
+
+
+;; Decompression bindings.
+
+(define lz-decompress-open
+  (let ((proc (lzlib-procedure '* "LZ_decompress_open" '())))
+    (lambda ()
+      "Initializes the internal stream state for decompression and returns a
+pointer that can only be used as the decoder argument for the other
+lz-decompress functions, or a null pointer if the decoder could not be
+allocated.
+
+See the manual: (lzlib) Decompression functions."
+      (let ((decoder-ptr (proc)))
+        (if (not (= (lz-decompress-error decoder-ptr) -1))
+            (pointer->lz-decoder decoder-ptr)
+            (throw 'lzlib-error 'lz-decompress-open))))))
+
+(define lz-decompress-close
+  (let ((proc (lzlib-procedure int "LZ_decompress_close" '(*))))
+    (lambda (decoder)
+      "Close decoder.  DECODER can no longer be used as an argument to any
+lz-decompress function. "
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-close ret)
+            ret)))))
+
+(define lz-decompress-finish
+  (let ((proc (lzlib-procedure int "LZ_decompress_finish" '(*))))
+    (lambda (decoder)
+      "Tell that all the data for this stream have already been written (with
+the `lz-decompress-write' function).  It is safe to call
+`lz-decompress-finish' as many times as needed."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-finish (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-reset
+  (let ((proc (lzlib-procedure int "LZ_decompress_reset" '(*))))
+    (lambda (decoder)
+      "Reset the internal state of DECODER as it was just after opening it
+with the `lz-decompress-open' function.  Data stored in the internal buffers
+is discarded.  Position counters are set to 0."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-reset
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-sync-to-member
+  (let ((proc (lzlib-procedure int "LZ_decompress_sync_to_member" '(*))))
+    (lambda (decoder)
+      "Reset the error state of DECODER and enters a search state that lasts
+until a new member header (or the end of the stream) is found.  After a
+successful call to `lz-decompress-sync-to-member', data written with
+`lz-decompress-write' will be consumed and 'lz-decompress-read' will return 0
+until a header is found.
+
+This function is useful to discard any data preceding the first member, or to
+discard the rest of the current member, for example in case of a data
+error.  If the decoder is already at the beginning of a member, this function
+does nothing."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-sync-to-member
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-read
+  (let ((proc (lzlib-procedure int "LZ_decompress_read" (list '* '* int))))
+    (lambda* (decoder file-bv #:optional (start 0) (count (bytevector-length file-bv)))
+      "Read up to COUNT bytes from the decoder stream, storing the results in FILE-BV.
+Return the number of uncompressed bytes written, a non-negative positive integer."
+      (let ((ret (proc (lz-decoder->pointer decoder)
+                       (bytevector->pointer file-bv start)
+                       count)))
+        (if (< ret 0)
+            (throw 'lzlib-error 'lz-decompress-read (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-write
+  (let ((proc (lzlib-procedure int "LZ_decompress_write" (list '* '* int))))
+    (lambda* (decoder bv #:optional (start 0) (count (bytevector-length bv)))
+      "Write up to COUNT bytes from BV to the decoder stream.  Return the
+number of uncompressed bytes written, a non-negative integer."
+      (let ((ret (proc (lz-decoder->pointer decoder)
+                       (bytevector->pointer bv start)
+                       count)))
+        (if (< ret 0)
+            (throw 'lzlib-error 'lz-decompress-write (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-write-size
+  (let ((proc (lzlib-procedure int "LZ_decompress_write_size" '(*))))
+    (lambda (decoder)
+      "Return the maximum number of bytes that can be immediately written
+through the `lz-decompress-write' function.
+
+It is guaranteed that an immediate call to `lz-decompress-write' will accept a
+SIZE up to the returned number of bytes. "
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-write-size (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-error
+  (let ((proc (lzlib-procedure int "LZ_decompress_errno" '(*))))
+    (lambda (decoder)
+      "DECODER can be a Scheme object or a pointer."
+      (let* ((error-number (proc (if (lz-decoder? decoder)
+                                     (lz-decoder->pointer decoder)
+                                     decoder))))
+        error-number))))
+
+(define lz-decompress-finished?
+  (let ((proc (lzlib-procedure int "LZ_decompress_finished" '(*))))
+    (lambda (decoder)
+      "Return #t if all the data have been read and `lz-decompress-close' can
+be safely called.  Otherwise return #f."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (match ret
+          (1 #t)
+          (0 #f)
+          (_ (throw 'lzlib-error 'lz-decompress-finished? (lz-decompress-error decoder))))))))
+
+(define lz-decompress-member-finished?
+  (let ((proc (lzlib-procedure int "LZ_decompress_member_finished" '(*))))
+    (lambda (decoder)
+      "Return #t if the current member, in a multimember data stream, has
+been fully read and `lz-decompress-restart-member' can be safely called.
+Otherwise return #f."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (match ret
+          (1 #t)
+          (0 #f)
+          (_ (throw 'lzlib-error 'lz-decompress-member-finished? (lz-decompress-error decoder))))))))
+
+(define lz-decompress-member-version
+  (let ((proc (lzlib-procedure int "LZ_decompress_member_version" '(*))))
+    (lambda (decoder)
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        "Return the version of current member from member header."
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-data-position
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-dictionary-size
+  (let ((proc (lzlib-procedure int "LZ_decompress_dictionary_size" '(*))))
+    (lambda (decoder)
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        "Return the dictionary size of current member from member header."
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-member-position
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-data-crc
+  (let ((proc (lzlib-procedure unsigned-int "LZ_decompress_data_crc" '(*))))
+    (lambda (decoder)
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        "Return the 32 bit Cyclic Redundancy Check of the data decompressed
+from the current member.  The returned value is valid only when
+`lz-decompress-member-finished' returns #t. "
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-member-position
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-data-position
+  (let ((proc (lzlib-procedure uint64 "LZ_decompress_data_position" '(*))))
+    (lambda (decoder)
+      "Return the number of decompressed bytes already produced, but perhaps
+not yet read, in the current member."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-data-position
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-member-position
+  (let ((proc (lzlib-procedure uint64 "LZ_decompress_member_position" '(*))))
+    (lambda (decoder)
+      "Return the number of input bytes already decompressed in the current
+member."
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-member-position
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-total-in-size
+  (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_in_size" '(*))))
+    (lambda (decoder)
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        "Return the total number of input bytes already compressed."
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-total-in-size
+                   (lz-decompress-error decoder))
+            ret)))))
+
+(define lz-decompress-total-out-size
+  (let ((proc (lzlib-procedure uint64 "LZ_decompress_total_out_size" '(*))))
+    (lambda (decoder)
+      (let ((ret (proc (lz-decoder->pointer decoder))))
+        "Return the total number of compressed bytes already produced, but
+perhaps not yet read."
+        (if (= ret -1)
+            (throw 'lzlib-error 'lz-decompress-total-out-size
+                   (lz-decompress-error decoder))
+            ret)))))
+
+
+;; High level functions.
+(define* (lzread! decoder file-port bv
+                  #:optional (start 0) (count (bytevector-length bv)))
+  "Read up to COUNT bytes from FILE-PORT into BV at offset START.  Return the
+number of uncompressed bytes actually read; it is zero if COUNT is zero or if
+the end-of-stream has been reached."
+  ;; WARNING: Because we don't alternate between lz-reads and lz-writes, we can't
+  ;; process more than lz-decompress-write-size from the file-port.
+  (when (> count (lz-decompress-write-size decoder))
+    (set! count (lz-decompress-write-size decoder)))
+  (let ((file-bv (get-bytevector-n file-port count)))
+    (unless (eof-object? file-bv)
+      (lz-decompress-write decoder file-bv 0 (bytevector-length file-bv))))
+  (let ((read 0))
+    (let loop ((rd 0))
+      (if (< start (bytevector-length bv))
+          (begin
+            (set! rd (lz-decompress-read decoder bv start (- (bytevector-length bv) start)))
+            (set! start (+ start rd))
+            (set! read (+ read rd)))
+          (set! rd 0))
+      (unless (= rd 0)
+        (loop rd)))
+    read))
+
+(define* (lzwrite encoder bv lz-port
+                  #:optional (start 0) (count (bytevector-length bv)))
+  "Write up to COUNT bytes from BV at offset START into LZ-PORT.  Return
+the number of uncompressed bytes written, a non-negative integer."
+  (let ((written 0)
+        (read 0))
+    (while (and (< 0 (lz-compress-write-size encoder))
+                (< written count))
+      (set! written (+ written
+                       (lz-compress-write encoder bv (+ start written) (- count written)))))
+    (when (= written 0)
+      (lz-compress-finish encoder))
+    (let ((lz-bv (make-bytevector written)))
+      (let loop ((rd 0))
+        (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
+        (put-bytevector lz-port lz-bv 0 rd)
+        (set! read (+ read rd))
+        (unless (= rd 0)
+          (loop rd))))
+    ;; `written' is the total byte count of uncompressed data.
+    written))
+
+
+;;;
+;;; Port interface.
+;;;
+
+;; Alist of (levels (dictionary-size match-length-limit)).  0 is the fastest.
+;; See bbexample.c in lzlib's source.
+(define %compression-levels
+  `((0 (65535 16))
+    (1 (,(bitwise-arithmetic-shift-left 1 20) 5))
+    (2 (,(bitwise-arithmetic-shift-left 3 19) 6))
+    (3 (,(bitwise-arithmetic-shift-left 1 21) 8))
+    (4 (,(bitwise-arithmetic-shift-left 3 20) 12))
+    (5 (,(bitwise-arithmetic-shift-left 1 22) 20))
+    (6 (,(bitwise-arithmetic-shift-left 1 23) 36))
+    (7 (,(bitwise-arithmetic-shift-left 1 24) 68))
+    (8 (,(bitwise-arithmetic-shift-left 3 23) 132))
+    (9 (,(bitwise-arithmetic-shift-left 1 25) 273))))
+
+(define %default-compression-level
+  6)
+
+(define* (make-lzip-input-port port)
+  "Return an input port that decompresses data read from PORT, a file port.
+PORT is automatically closed when the resulting port is closed."
+  (define decoder (lz-decompress-open))
+
+  (define (read! bv start count)
+    (lzread! decoder port bv start count))
+
+  (make-custom-binary-input-port "lzip-input" read! #f #f
+                                 (lambda ()
+                                   (lz-decompress-close decoder)
+                                   (close-port port))))
+
+(define* (make-lzip-output-port port
+                                #:key
+                                (level %default-compression-level))
+  "Return an output port that compresses data at the given LEVEL, using PORT,
+a file port, as its sink.  PORT is automatically closed when the resulting
+port is closed."
+  (define encoder (apply lz-compress-open
+                         (car (assoc-ref %compression-levels level))))
+
+  (define (write! bv start count)
+    (lzwrite encoder bv port start count))
+
+  (make-custom-binary-output-port "lzip-output" write! #f #f
+                                  (lambda ()
+                                    (lz-compress-finish encoder)
+                                    ;; "lz-read" the trailing metadata added by `lz-compress-finish'.
+                                    (let ((lz-bv (make-bytevector (* 64 1024))))
+                                      (let loop ((rd 0))
+                                        (set! rd (lz-compress-read encoder lz-bv 0 (bytevector-length lz-bv)))
+                                        (put-bytevector port lz-bv 0 rd)
+                                        (unless (= rd 0)
+                                          (loop rd))))
+                                    (lz-compress-close encoder)
+                                    (close-port port))))
+
+(define* (call-with-lzip-input-port port proc)
+  "Call PROC with a port that wraps PORT and decompresses data read from it.
+PORT is closed upon completion."
+  (let ((lzip (make-lzip-input-port port)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc lzip))
+      (lambda ()
+        (close-port lzip)))))
+
+(define* (call-with-lzip-output-port port proc
+                                     #:key
+                                     (level %default-compression-level))
+  "Call PROC with an output port that wraps PORT and compresses data.  PORT is
+close upon completion."
+  (let ((lzip (make-lzip-output-port port
+                                     #:level level)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (proc lzip))
+      (lambda ()
+        (close-port lzip)))))
+
+;;; lzlib.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ba143ad16b..8fa700c883 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -65,7 +65,7 @@
 
 (define %default-log-urls
   ;; Default base URLs for build logs.
-  '("http://ci.guix.info/log"))
+  '("http://ci.guix.gnu.org/log"))
 
 ;; XXX: The following procedure cannot be in (guix store) because of the
 ;; dependency on (guix derivations).
@@ -370,7 +370,10 @@ a checkout of the Git repository at the given URL."
                       (package
                         (inherit old)
                         (source (git-checkout (url url)
-                                              (recursive? #t)))))))))
+                                              (recursive? #t)))))))
+             (_
+              (leave (G_ "~a: invalid Git URL replacement specification~%")
+                     spec))))
          replacement-specs))
 
   (define rewrite
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 99c351ae43..c1341628a8 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -341,7 +341,7 @@ for the corresponding packages."
                      (list (package->manifest-entry* package output))))
                   (('package 'package (? string? spec))
                    (package-environment-inputs
-                    (specification->package+output spec)))
+                    (transform (specification->package+output spec))))
                   (('expression mode str)
                    ;; Add all the outputs of the package STR evaluates to.
                    (packages->outputs (read/eval str) mode))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 2a7b84b847..802b26c64c 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -724,6 +724,10 @@ please email '~a'~%")
                       (alist-cons 'profile-name arg result))
                      (_
                       (leave (G_ "~a: unsupported profile name~%") arg)))))
+         (option '(#\r "root") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'gc-root arg result)))
+
          (option '(#\v "verbosity") #t #f
                  (lambda (opt name arg result)
                    (let ((level (string->number* arg)))
@@ -769,6 +773,9 @@ Create a bundle of PACKAGE.\n"))
       --profile-name=NAME
                          populate /var/guix/profiles/.../NAME"))
   (display (G_ "
+  -r, --root=FILE        make FILE a symlink to the result, and register it
+                         as a garbage collector root"))
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (G_ "
       --bootstrap        use the bootstrap binaries to build the pack"))
@@ -882,7 +889,11 @@ Create a bundle of PACKAGE.\n"))
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
                  (localstatedir? (assoc-ref opts 'localstatedir?))
-                 (profile-name   (assoc-ref opts 'profile-name)))
+                 (profile-name   (assoc-ref opts 'profile-name))
+                 (gc-root        (assoc-ref opts 'gc-root)))
+            (when (null? (manifest-entries manifest))
+              (warning (G_ "no packages specified; building an empty pack~%")))
+
             (run-with-store store
               (mlet* %store-monad ((profile (profile-derivation
                                              manifest
@@ -919,6 +930,11 @@ Create a bundle of PACKAGE.\n"))
                                        #:dry-run? dry-run?)
                   (munless dry-run?
                     (built-derivations (list drv))
+                    (mwhen gc-root
+                      (register-root* (match (derivation->output-paths drv)
+                                        (((names . items) ...)
+                                         items))
+                                      gc-root))
                     (return (format #t "~a~%"
                                     (derivation->output-path drv))))))
               #:system (assoc-ref opts 'system))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index aa27984ea2..06e4cf5b9c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -180,9 +180,9 @@ hooks\" run when building the profile."
 ;;;
 
 (define (find-packages-by-description regexps)
-  "Return two values: the list of packages whose name, synopsis, or
-description matches at least one of REGEXPS sorted by relevance, and the list
-of relevance scores."
+  "Return two values: the list of packages whose name, synopsis, description,
+or output matches at least one of REGEXPS sorted by relevance, and the list of
+relevance scores."
   (let ((matches (fold-packages (lambda (package result)
                                   (if (package-superseded package)
                                       result
diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm
index 6a2f603599..a2ab017490 100644
--- a/guix/scripts/processes.scm
+++ b/guix/scripts/processes.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -103,9 +103,16 @@ processes."
   (let ((directory (string-append "/proc/"
                                   (number->string (process-id process))
                                   "/fd")))
-    (map (lambda (fd)
-           (readlink (string-append directory "/" fd)))
-         (or (scandir directory string->number) '()))))
+    (filter-map (lambda (fd)
+                  ;; There's a TOCTTOU race here, hence the 'catch'.
+                  (catch 'system-error
+                    (lambda ()
+                      (readlink (string-append directory "/" fd)))
+                    (lambda args
+                      (if (= ENOENT (system-error-errno args))
+                          #f
+                          (apply throw args)))))
+                (or (scandir directory string->number) '()))))
 
 ;; Daemon session.
 (define-record-type <daemon-session>
@@ -151,15 +158,22 @@ active sessions, and the master 'guix-daemon' process."
                      (= pid (process-parent-id process))))
               processes))
 
-    (values (map (lambda (process)
-                   (match (process-command process)
-                     ((argv0 (= string->number client) _ ...)
-                      (let ((files (process-open-files process)))
-                        (daemon-session process
-                                        (lookup-process client)
-                                        (lookup-children (process-id process))
-                                        (filter lock-file? files))))))
-                 children)
+    (define (child-process->session process)
+      (match (process-command process)
+        ((argv0 (= string->number client) _ ...)
+         (let ((files  (process-open-files process))
+               (client (lookup-process client)))
+           ;; After a client has died, there's a window during which its
+           ;; corresponding 'guix-daemon' process is still alive, in which
+           ;; case 'lookup-process' returns #f.  In that case ignore the
+           ;; session.
+           (and client
+                (daemon-session process client
+                                (lookup-children
+                                 (process-id process))
+                                (filter lock-file? files)))))))
+
+    (values (filter-map child-process->session children)
             master)))
 
 (define (daemon-session->recutils session port)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 3929cd402e..2d428546c9 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -203,6 +203,10 @@ true, display what would be built without actually building it."
   (define update-profile
     (store-lift build-and-use-profile))
 
+  (define guix-command
+    ;; The 'guix' command before we've built the new profile.
+    (which "guix"))
+
   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
     (mbegin %store-monad
       (update-profile profile manifest
@@ -211,17 +215,18 @@ true, display what would be built without actually building it."
       (munless dry-run?
         (return (newline))
         (return (display-profile-news profile #:concise? #t))
-        (match (which "guix")
-          (#f (return #f))
-          (str
-           (let ((new (map (cut string-append <> "/bin/guix")
-                           (list (user-friendly-profile profile)
-                                 profile))))
-             (unless (member str new)
-               (display-hint (format #f (G_ "After setting @code{PATH}, run
+        (if guix-command
+            (let ((new (map (cut string-append <> "/bin/guix")
+                            (list (user-friendly-profile profile)
+                                  profile))))
+              ;; Is the 'guix' command previously in $PATH the same as the new
+              ;; one?  If the answer is "no", then suggest 'hash guix'.
+              (unless (member guix-command new)
+                (display-hint (format #f (G_ "After setting @code{PATH}, run
 @command{hash guix} to make sure your shell refers to @file{~a}.")
-                                     (first new))))
-             (return #f))))))))
+                                      (first new))))
+              (return #f))
+            (return #f))))))
 
 (define (honor-lets-encrypt-certificates! store)
   "Tell Guile-Git to use the Let's Encrypt certificates."
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 797a76db3f..135398ba48 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -1061,7 +1061,7 @@ found."
     (#f
      ;; This can only happen when this script is not invoked by the
      ;; daemon.
-     '("http://ci.guix.info"))))
+     '("http://ci.guix.gnu.org"))))
 
 (define substitute-urls
   ;; List of substitute URLs.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3c3d6cbd5f..60c1ca5c9a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -756,13 +757,17 @@ checking this by themselves in their 'check' procedure."
 
 (define* (system-derivation-for-action os action
                                        #:key image-size file-system-type
-                                       full-boot? mappings)
+                                       full-boot? container-shared-network?
+                                       mappings)
   "Return as a monadic value the derivation for OS according to ACTION."
   (case action
     ((build init reconfigure)
      (operating-system-derivation os))
     ((container)
-     (container-script os #:mappings mappings))
+     (container-script
+      os
+      #:mappings mappings
+      #:shared-network? container-shared-network?))
     ((vm-image)
      (system-qemu-image os #:disk-image-size image-size))
     ((vm)
@@ -781,7 +786,7 @@ checking this by themselves in their 'check' procedure."
                         #:disk-image-size image-size
                         #:file-system-type file-system-type))
     ((docker-image)
-     (system-docker-image os #:register-closures? #t))))
+     (system-docker-image os))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -826,6 +831,7 @@ and TARGET arguments."
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
                          image-size file-system-type full-boot?
+                         container-shared-network?
                          (mappings '())
                          (gc-root #f))
   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
@@ -834,6 +840,8 @@ target root directory; IMAGE-SIZE is the size of the image to be built, for
 the 'vm-image' and 'disk-image' actions.  The root file system is created as a
 FILE-SYSTEM-TYPE file system.  FULL-BOOT? is used for the 'vm' action; it
 determines whether to boot directly to the kernel or to the bootloader.
+CONTAINER-SHARED-NETWORK? determines if the container will use a separate
+network namespace.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything.
@@ -883,6 +891,7 @@ static checks."
                                                 #:file-system-type file-system-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
+                                                #:container-shared-network? container-shared-network?
                                                 #:mappings mappings))
 
        ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
@@ -1020,6 +1029,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
   (display (G_ "
+  -N, --network          for 'container', allow containers to access the network"))
+  (display (G_ "
   -r, --root=FILE        for 'vm', 'vm-image', 'disk-image', 'container',
                          and 'build', make FILE a symlink to the result, and
                          register it as a garbage collector root"))
@@ -1066,6 +1077,9 @@ Some ACTIONS support additional ARGS.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'image-size (size->number arg)
                                result)))
+         (option '(#\N "network") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'container-shared-network? #t result)))
          (option '("no-bootloader" "no-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'install-bootloader? #f result)))
@@ -1129,22 +1143,30 @@ Some ACTIONS support additional ARGS.\n"))
 ACTION must be one of the sub-commands that takes an operating system
 declaration as an argument (a file name.)  OPTS is the raw alist of options
 resulting from command-line parsing."
+  (define (ensure-operating-system file-or-exp obj)
+    (unless (operating-system? obj)
+      (leave (G_ "'~a' does not return an operating system~%")
+             file-or-exp))
+    obj)
+
   (let* ((file        (match args
                         (() #f)
                         ((x . _) x)))
          (expr        (assoc-ref opts 'expression))
          (system      (assoc-ref opts 'system))
-         (os          (cond
-                       ((and expr file)
-                        (leave
-                         (G_ "both file and expression cannot be specified~%")))
-                       (expr
-                        (read/eval expr))
-                       (file
-                        (load* file %user-module
-                                    #:on-error (assoc-ref opts 'on-error)))
-                       (else
-                        (leave (G_ "no configuration specified~%")))))
+         (os          (ensure-operating-system
+                       (or file expr)
+                       (cond
+                        ((and expr file)
+                         (leave
+                          (G_ "both file and expression cannot be specified~%")))
+                        (expr
+                         (read/eval expr))
+                        (file
+                         (load* file %user-module
+                                #:on-error (assoc-ref opts 'on-error)))
+                        (else
+                         (leave (G_ "no configuration specified~%"))))))
 
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
@@ -1182,6 +1204,8 @@ resulting from command-line parsing."
                              #:file-system-type (assoc-ref opts 'file-system-type)
                              #:image-size (assoc-ref opts 'image-size)
                              #:full-boot? (assoc-ref opts 'full-boot?)
+                             #:container-shared-network?
+                             (assoc-ref opts 'container-shared-network?)
                              #:mappings (filter-map (match-lambda
                                                       (('file-system-mapping . m)
                                                        m)
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 4b12f9550e..78b8674e0c 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -252,7 +252,7 @@ are queued~%")
 ;;;
 
 (define (show-help)
-  (display (G_ "Usage: guix weather [OPTIONS]
+  (display (G_ "Usage: guix weather [OPTIONS] [PACKAGES ...]
 Report the availability of substitutes.\n"))
   (display (G_ "
       --substitute-urls=URLS
@@ -469,6 +469,20 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
 ;;;
 
 (define (guix-weather . args)
+  (define (package-list opts)
+    ;; Return the package list specified by OPTS.
+    (let ((file (assoc-ref opts 'manifest))
+          (base (filter-map (match-lambda
+                              (('argument . spec)
+                               (specification->package spec))
+                              (_
+                               #f))
+                            opts)))
+      (if (and (not file) (null? base))
+          (all-packages)
+          (append base
+                  (if file (load-manifest file) '())))))
+
   (with-error-handling
     (parameterize ((current-terminal-columns (terminal-columns)))
       (let* ((opts     (parse-command-line args %options
@@ -481,10 +495,7 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
                                           opts)
                          (() (list (%current-system)))
                          (systems systems)))
-             (packages (let ((file (assoc-ref opts 'manifest)))
-                         (if file
-                             (load-manifest file)
-                             (all-packages))))
+             (packages (package-list opts))
              (items    (with-store store
                          (parameterize ((%graft? #f))
                            (concatenate
diff --git a/guix/self.scm b/guix/self.scm
index 68b87051e9..6d7569ec19 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -377,12 +377,6 @@ TRANSLATIONS, an alist of msgid and msgstr."
 
 (define (info-manual source)
   "Return the Info manual built from SOURCE."
-  (define po4a
-    (specification->package "po4a"))
-
-  (define gettext
-    (specification->package "gettext"))
-
   (define texinfo
     (module-ref (resolve-interface '(gnu packages texinfo))
                 'texinfo))
@@ -588,6 +582,8 @@ load path."
                   ("share/guix/berlin.guixsd.org.pub"
                    ,(file-append* source
                                   "/etc/substitutes/berlin.guixsd.org.pub"))
+                  ("share/guix/ci.guix.gnu.org.pub"  ;alias
+                   ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub"))
                   ("share/guix/ci.guix.info.pub"  ;alias
                    ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub")))))
 
@@ -923,6 +919,7 @@ Info manual."
                                %store-database-directory
                                %config-directory
                                %libz
+                               ;; TODO: %liblz
                                %gzip
                                %bzip2
                                %xz))
diff --git a/guix/store.scm b/guix/store.scm
index 1b485ab5fa..5c6e4e0ca6 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -746,7 +746,7 @@ encoding conversion errors."
   (map (if (false-if-exception (resolve-interface '(gnutls)))
            (cut string-append "https://" <>)
            (cut string-append "http://" <>))
-       '("ci.guix.info")))
+       '("ci.guix.gnu.org")))
 
 (define* (set-build-options server
                             #:key keep-failed? keep-going? fallback?
diff --git a/guix/ui.scm b/guix/ui.scm
index 92c845e944..529401eea8 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -11,6 +11,8 @@
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1370,9 +1372,9 @@ WIDTH columns.  EXTRA-FIELDS is a list of symbol/value pairs to emit."
 (define (relevance obj regexps metrics)
   "Compute a \"relevance score\" for OBJ as a function of its number of
 matches of REGEXPS and accordingly to METRICS.  METRICS is list of
-field/weight pairs, where FIELD is a procedure that returns a string
-describing OBJ, and WEIGHT is a positive integer denoting the weight of this
-field in the final score.
+field/weight pairs, where FIELD is a procedure that returns a string or list
+of strings describing OBJ, and WEIGHT is a positive integer denoting the
+weight of this field in the final score.
 
 A score of zero means that OBJ does not match any of REGEXPS.  The higher the
 score, the more relevant OBJ is to REGEXPS."
@@ -1394,8 +1396,10 @@ score, the more relevant OBJ is to REGEXPS."
             ((field . weight)
              (match (field obj)
                (#f  relevance)
-               (str (+ relevance
-                       (* (score str) weight)))))))
+               ((? string? str)
+                (+ relevance (* (score str) weight)))
+               ((lst ...)
+                (+ relevance (* weight (apply + (map score lst)))))))))
         0
         metrics))
 
@@ -1404,6 +1408,15 @@ score, the more relevant OBJ is to REGEXPS."
   ;; of regexps.
   `((,package-name . 4)
 
+    ;; Match against uncommon outputs.
+    (,(lambda (package)
+        (filter (lambda (output)
+                  (not (member output
+                               ;; Some common outpus shared by many packages.
+                               '("out" "doc" "debug" "lib" "include" "bin"))))
+                (package-outputs package)))
+     . 1)
+
     ;; Match regexps on the raw Texinfo since formatting it is quite expensive
     ;; and doesn't have much of an effect on search results.
     (,(lambda (package)