Merge branch 'master' into core-updates

17 files changed, 466 insertions, 84 deletions

diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index f173b64c83..4be5443083 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -99,7 +99,7 @@ Cargo.toml file present at its root."
   (for-each
     (match-lambda
       ((name . path)
-       (let* ((basepath (basename path))
+       (let* ((basepath (strip-store-file-name path))
               (crate-dir (string-append vendor-dir "/" basepath)))
          (and (crate-src? path)
               ;; Gracefully handle duplicate inputs
@@ -168,9 +168,6 @@ directory = '" port)
       (apply invoke `("cargo" "test" ,@cargo-test-flags))
       #t))
 
-(define (touch file-name)
-  (call-with-output-file file-name (const #t)))
-
 (define* (install #:key inputs outputs skip-build? #:allow-other-keys)
   "Install a given Cargo package."
   (let* ((out (assoc-ref outputs "out")))
diff --git a/guix/docker.scm b/guix/docker.scm
index 757bdeb458..97ac6d982b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -57,22 +57,36 @@
     (created . ,time)
     (container_config . #nil)))
 
-(define (generate-tag path)
-  "Generate an image tag for the given PATH."
-  (match (string-split (basename path) #\-)
-    ((hash name . rest) (string-append name ":" hash))))
+(define (canonicalize-repository-name name)
+  "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+Return a version of TAG that follows these rules."
+  (define ascii-letters
+    (string->char-set "abcdefghijklmnopqrstuvwxyz"))
 
-(define (manifest path id)
+  (define separators
+    (string->char-set "_-."))
+
+  (define repo-char-set
+    (char-set-union char-set:digit ascii-letters separators))
+
+  (string-map (lambda (chr)
+                (if (char-set-contains? repo-char-set chr)
+                    chr
+                    #\.))
+              (string-trim (string-downcase name) separators)))
+
+(define* (manifest path id #:optional (tag "guix"))
   "Generate a simple image manifest."
-  `#(((Config . "config.json")
-      (RepoTags . #(,(generate-tag path)))
-      (Layers . #(,(string-append id "/layer.tar"))))))
+  (let ((tag (canonicalize-repository-name tag)))
+    `#(((Config . "config.json")
+        (RepoTags . #(,(string-append tag ":latest")))
+        (Layers . #(,(string-append id "/layer.tar")))))))
 
 ;; According to the specifications this is required for backwards
 ;; compatibility.  It duplicates information provided by the manifest.
-(define (repositories path id)
+(define* (repositories path id #:optional (tag "guix"))
   "Generate a repositories file referencing PATH and the image ID."
-  `((,(generate-tag path) . ((latest . ,id)))))
+  `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
 
 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
 (define* (config layer time arch #:key entry-point (environment '()))
@@ -112,6 +126,7 @@
 
 (define* (build-docker-image image paths prefix
                              #:key
+                             (repository "guix")
                              (extra-files '())
                              (transformations '())
                              (system (utsname:machine (uname)))
@@ -121,7 +136,9 @@
                              compressor
                              (creation-time (current-time time-utc)))
   "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.
+must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
+is a descriptive name that will show up in \"REPOSITORY\" column of the output
+of \"docker images\".
 
 When DATABASE is true, copy it to /var/guix/db in the image and create
 /var/guix/gcroots and friends.
@@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata."
                              #:entry-point entry-point))))
       (with-output-to-file "manifest.json"
         (lambda ()
-          (scm->json (manifest prefix id))))
+          (scm->json (manifest prefix id repository))))
       (with-output-to-file "repositories"
         (lambda ()
-          (scm->json (repositories prefix id)))))
+          (scm->json (repositories prefix id repository)))))
 
     (apply invoke "tar" "-cf" image "-C" directory
            `(,@%tar-determinism-options
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index d63d44f629..ef067704ad 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -62,7 +62,6 @@
 
             %gnu-updater
             %gnu-ftp-updater
-            %kde-updater
             %xorg-updater
             %kernel.org-updater))
 
@@ -230,12 +229,6 @@ network to check in GNU's database."
             (or (assoc-ref (package-properties package) 'ftp-directory)
                 (string-append "/gnu/" name)))))
 
-(define (sans-extension tarball)
-  "Return TARBALL without its .tar.* or .zip extension."
-  (let ((end (or (string-contains tarball ".tar")
-                 (string-contains tarball ".zip"))))
-    (substring tarball 0 end)))
-
 (define %tarball-rx
   ;; The .zip extensions is notably used for freefont-ttf.
   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
@@ -261,14 +254,15 @@ true."
                                           (string-append project
                                                          "-src")))))))
        (not (regexp-exec %alpha-tarball-rx file))
-       (let ((s (sans-extension file)))
+       (let ((s (tarball-sans-extension file)))
          (regexp-exec %package-name-rx s))))
 
 (define (tarball->version tarball)
   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 \"coreutils-8.23.tar.xz\"."
   (let-values (((name version)
-                (gnu-package-name->name+version (sans-extension tarball))))
+                (gnu-package-name->name+version
+                 (tarball-sans-extension tarball))))
     version))
 
 (define* (releases project
@@ -492,8 +486,9 @@ return the corresponding signature URL, or #f it signatures are unavailable."
       (and (string=? url (basename url))          ;relative reference?
            (release-file? package url)
            (let-values (((name version)
-                         (package-name->name+version (sans-extension url)
-                                                     #\-)))
+                         (package-name->name+version
+                          (tarball-sans-extension url)
+                          #\-)))
              (upstream-source
               (package name)
               (version version)
@@ -565,14 +560,16 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
                                     (release-file? name (basename file))))
                              files)))
       (match (sort relevant (lambda (file1 file2)
-                              (version>? (sans-extension (basename file1))
-                                         (sans-extension (basename file2)))))
+                              (version>? (tarball-sans-extension
+                                          (basename file1))
+                                         (tarball-sans-extension
+                                          (basename file2)))))
         ((and tarballs (reference _ ...))
          (let* ((version  (tarball->version reference))
                 (tarballs (filter (lambda (file)
-                                    (string=? (sans-extension
+                                    (string=? (tarball-sans-extension
                                                (basename file))
-                                              (sans-extension
+                                              (tarball-sans-extension
                                                (basename reference))))
                                   tarballs)))
            (upstream-source
@@ -615,16 +612,6 @@ releases are on gnu.org."
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
-(define (latest-kde-release package)
-  "Return the latest release of PACKAGE, the name of an KDE.org package."
-  (let ((uri (string->uri (origin-uri (package-source package)))))
-    (false-if-ftp-error
-     (latest-ftp-release
-      (package-upstream-name package)
-      #:server "ftp.mirrorservice.org"
-      #:directory (string-append "/sites/ftp.kde.org/pub/kde/"
-                                 (dirname (dirname (uri-path uri))))))))
-
 (define (latest-xorg-release package)
   "Return the latest release of PACKAGE, the name of an X.org package."
   (let ((uri (string->uri (origin-uri (package-source package)))))
@@ -672,13 +659,6 @@ releases are on gnu.org."
                 (pure-gnu-package? package))))
    (latest latest-release*)))
 
-(define %kde-updater
-  (upstream-updater
-    (name 'kde)
-    (description "Updater for KDE packages")
-    (pred (url-prefix-predicate "mirror://kde/"))
-    (latest latest-kde-release)))
-
 (define %xorg-updater
   (upstream-updater
    (name 'xorg)
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 35caa3e463..e47aff2b12 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -49,6 +49,7 @@
             cran-recursive-import
             %cran-updater
             %bioconductor-updater
+            %bioconductor-version
 
             cran-package?
             bioconductor-package?
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index f6057dbf8b..fd1974eae8 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -181,9 +182,11 @@ and LICENSE."
   ;; This regexp matches that.
   (make-regexp "^(.*) OR (.*)$"))
 
-(define (crate->guix-package crate-name)
+(define* (crate->guix-package crate-name #:optional version)
   "Fetch the metadata for CRATE-NAME from crates.io, and return the
-`package' s-expression corresponding to that package, or #f on failure."
+`package' s-expression corresponding to that package, or #f on failure.
+When VERSION is specified, attempt to fetch that version; otherwise fetch the
+latest version of CRATE-NAME."
   (define (string->license string)
     (match (regexp-exec %dual-license-rx string)
       (#f (list (spdx-string->license string)))
@@ -196,12 +199,18 @@ and LICENSE."
   (define crate
     (lookup-crate crate-name))
 
-  (and crate
-       (let* ((version        (find (lambda (version)
-                                      (string=? (crate-version-number version)
-                                                (crate-latest-version crate)))
-                                    (crate-versions crate)))
-              (dependencies   (crate-version-dependencies version))
+  (define version-number
+    (or version
+        (crate-latest-version crate)))
+
+  (define version*
+    (find (lambda (version)
+            (string=? (crate-version-number version)
+                      version-number))
+          (crate-versions crate)))
+
+  (and crate version*
+       (let* ((dependencies   (crate-version-dependencies version*))
               (dep-crates     (filter normal-dependency? dependencies))
               (dev-dep-crates (remove normal-dependency? dependencies))
               (cargo-inputs   (sort (map crate-dependency-id dep-crates)
@@ -210,14 +219,14 @@ and LICENSE."
                (sort (map crate-dependency-id dev-dep-crates)
                      string-ci<?)))
          (make-crate-sexp #:name crate-name
-                          #:version (crate-version-number version)
+                          #:version (crate-version-number version*)
                           #:cargo-inputs cargo-inputs
                           #:cargo-development-inputs cargo-development-inputs
                           #:home-page (or (crate-home-page crate)
                                           (crate-repository crate))
                           #:synopsis (crate-description crate)
                           #:description (crate-description crate)
-                          #:license (and=> (crate-version-license version)
+                          #:license (and=> (crate-version-license version*)
                                            string->license)))))
 
 (define (guix-package->crate-name package)
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 55e1f72a42..55ea00a111 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -161,7 +161,7 @@ empty list."
         url))
 
   (match (json-fetch (decorate release-url) #:headers headers)
-    (()
+    (#()
      ;; We got the empty list, presumably because the user didn't use GitHub's
      ;; "release" mechanism, but hopefully they did use Git tags.
      (json-fetch (decorate tag-url) #:headers headers))
diff --git a/guix/import/kde.scm b/guix/import/kde.scm
new file mode 100644
index 0000000000..6873418d62
--- /dev/null
+++ b/guix/import/kde.scm
@@ -0,0 +1,190 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.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 import kde)
+  #:use-module (guix http-client)
+  #:use-module (guix memoization)
+  #:use-module (guix gnu-maintenance)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
+  #:use-module (web uri)
+
+  #:export (%kde-updater))
+
+;;; Commentary:
+;;;
+;;; This package provides not an actual importer but simply an updater for
+;;; KDE packages.  It grabs available files from the 'ls-lR.bz2' file
+;;; available on download.kde.org.
+;;;
+;;; Code:
+
+(define (tarball->version tarball)
+  "Return the version TARBALL corresponds to.  TARBALL is a file name like
+\"coreutils-8.23.tar.xz\"."
+  (let-values (((name version)
+                (gnu-package-name->name+version
+                 (tarball-sans-extension tarball))))
+    version))
+
+(define %kde-file-list-uri
+  ;; URI of the file list (ls -lR format) for download.kde.org.
+  (string->uri "https://download.kde.org/ls-lR.bz2"))
+
+(define (download.kde.org-files)
+  ;;"Return the list of files available at download.kde.org."
+
+    (define (ls-lR-line->filename path line)
+      ;; Remove mode, blocks, user, group, size, date, time and one space,
+      ;; then prepend PATH
+      (regexp-substitute
+       #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post))
+
+    (define (canonicalize path)
+      (let* ((path (if (string-prefix? "/srv/archives/ftp/" path)
+                       (string-drop path (string-length "/srv/archives/ftp"))
+                       path))
+             (path (if (string-suffix? ":" path)
+                       (string-drop-right path 1)
+                       path))
+             (path (if (not (string-suffix? "/" path))
+                       (string-append path "/")
+                       path)))
+        path))
+
+    (define (write-cache input cache)
+      "Read bzipped ls-lR from INPUT, and write it as a list of file paths to
+CACHE."
+      (call-with-decompressed-port 'bzip2 input
+        (lambda (input)
+          (let loop_dirs ((files '()))
+            ;; process a new directory block
+            (let ((path (read-line input)))
+              (if
+               (or (eof-object? path) (string= path ""))
+               (write (reverse files) cache)
+               (let loop_entries ((path (canonicalize path))
+                                  (files files))
+                 ;; process entries within the directory block
+                 (let ((line (read-line input)))
+                   (cond
+                    ((eof-object? line)
+                     (write (reverse files) cache))
+                    ((string-prefix? "-" line)
+                     ;; this is a file entry: prepend to FILES, then re-enter
+                     ;; the loop for remaining entries
+                     (loop_entries path
+                                   (cons (ls-lR-line->filename path line) files)
+                                   ))
+                    ((not (string= line ""))
+                     ;; this is a non-file entry: ignore it, just re-enter the
+                     ;; loop for remaining entries
+                     (loop_entries path files))
+                    ;; empty line: directory block end, re-enter the outer
+                    ;; loop for the next block
+                    (#t (loop_dirs files)))))))))))
+
+  (define (cache-miss uri)
+    (format (current-error-port) "fetching ~a...~%" (uri->string uri)))
+
+  (let* ((port (http-fetch/cached %kde-file-list-uri
+                                  #:ttl 3600
+                                  #:write-cache write-cache
+                                  #:cache-miss cache-miss))
+         (files (read port)))
+    (close-port port)
+    files))
+
+(define (uri->kde-path-pattern uri)
+  "Build a regexp from the package's URI suitable for matching the package
+path version-agnostic.
+
+Example:
+Input:
+   mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip
+Output:
+   //stable/frameworks/[^/]+/portingAids/
+"
+
+  (define version-regexp
+    ;; regexp for matching versions as used in the ld-lR file
+    (make-regexp
+     (string-join '("^([0-9]+\\.)+[0-9]+-?"   ;; 5.12.90, 4.2.0-preview
+                    "^[0-9]+$"                ;; 20031002
+                    ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1
+                    "|")))
+
+  (define (version->pattern part)
+    ;; If a path element might be a version, replace it by a catch-all part
+    (if (regexp-exec version-regexp part)
+        "[^/]+"
+        part))
+
+  (let* ((path (uri-path uri))
+         (directory-parts (string-split (dirname path) #\/)))
+    (make-regexp
+     (string-append
+      (string-join (map version->pattern directory-parts) "/")
+      "/"))))
+
+(define (latest-kde-release package)
+  "Return the latest release of PACKAGE, a KDE package, or #f if it could
+not be determined."
+  (let* ((uri      (string->uri (origin-uri (package-source package))))
+         (path-rx  (uri->kde-path-pattern uri))
+         (name     (package-upstream-name package))
+         (files    (download.kde.org-files))
+         (relevant (filter (lambda (file)
+                             (and (regexp-exec path-rx file)
+                                  (release-file? name (basename file))))
+                           files)))
+    (match (sort relevant (lambda (file1 file2)
+                            (version>? (tarball-sans-extension
+                                        (basename file1))
+                                       (tarball-sans-extension
+                                        (basename file2)))))
+           ((and tarballs (reference _ ...))
+            (let* ((version  (tarball->version reference))
+                   (tarballs (filter (lambda (file)
+                                       (string=? (tarball-sans-extension
+                                                  (basename file))
+                                                 (tarball-sans-extension
+                                                  (basename reference))))
+                                     tarballs)))
+              (upstream-source
+               (package name)
+               (version version)
+               (urls (map (lambda (file)
+                            (string-append "mirror://kde/" file))
+                          tarballs)))))
+           (()
+            #f))))
+
+(define %kde-updater
+  (upstream-updater
+    (name 'kde)
+    (description "Updater for KDE packages")
+    (pred (url-prefix-predicate "mirror://kde/"))
+    (latest latest-kde-release)))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 252875eeab..4694b6e7ef 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -212,10 +212,19 @@ with dashes."
 (define (beautify-description description)
   "Improve the package DESCRIPTION by turning a beginning sentence fragment
 into a proper sentence and by using two spaces between sentences."
-  (let ((cleaned (if (string-prefix? "A " description)
-                     (string-append "This package provides a"
-                                    (substring description 1))
-                     description)))
+  (let ((cleaned (cond
+                  ((string-prefix? "A " description)
+                   (string-append "This package provides a"
+                                  (substring description 1)))
+                  ((string-prefix? "Provides " description)
+                   (string-append "This package provides"
+                                  (substring description
+                                             (string-length "Provides"))))
+                  ((string-prefix? "Functions " description)
+                   (string-append "This package provides functions"
+                                  (substring description
+                                             (string-length "Functions"))))
+                  (else description))))
     ;; Use double spacing between sentences
     (regexp-substitute/global #f "\\. \\b"
                               cleaned 'pre ".  " 'post)))
diff --git a/guix/packages.scm b/guix/packages.scm
index 39ab28d807..f2c94c7bc2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -352,7 +352,7 @@ object."
 
   (match (package-location package)
     (($ <location> file line column)
-     (catch 'system
+     (catch 'system-error
        (lambda ()
          ;; In general we want to keep relative file names for modules.
          (with-fluids ((%file-port-name-canonicalization 'relative))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index f7f7edda48..cfe0a37c42 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -463,6 +463,10 @@ host file systems to mount inside the container.  If USER is not #f, each
 target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
 will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
 ~/.guix-profile to the environment profile."
+  (define (optional-mapping->fs mapping)
+    (and (file-exists? (file-system-mapping-source mapping))
+         (file-system-mapping->bind-mount mapping)))
+
   (mlet %store-monad ((reqs (inputs->requisites
                              (list (direct-store-path bash) profile))))
     (return
@@ -499,11 +503,6 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
                                   (target cwd)
                                   (writable? #t)))
                            '())))
-              ;; When in Rome, do as Nix build.cc does: Automagically
-              ;; map common network configuration files.
-              (if network?
-                  %network-file-mappings
-                  '())
               ;; Mappings for the union closure of all inputs.
               (map (lambda (dir)
                      (file-system-mapping
@@ -512,6 +511,10 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
                       (writable? #f)))
                    reqs)))
             (file-systems (append %container-file-systems
+                                  (if network?
+                                      (filter-map optional-mapping->fs
+                                                  %network-file-mappings)
+                                      '())
                                   (map file-system-mapping->bind-mount
                                        mappings))))
        (exit/status
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 31657326b6..3f20a2e192 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -57,6 +57,8 @@ Invoke the garbage collector.\n"))
   (display (G_ "
       --list-roots       list the user's garbage collector roots"))
   (display (G_ "
+      --list-busy        list store items used by running processes"))
+  (display (G_ "
       --optimize         optimize the store by deduplicating identical files"))
   (display (G_ "
       --list-dead        list dead paths"))
@@ -174,6 +176,10 @@ is deprecated; use '-D'~%"))
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-roots
                               (alist-delete 'action result))))
+        (option '("list-busy") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-busy
+                              (alist-delete 'action result))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -265,6 +271,12 @@ is deprecated; use '-D'~%"))
                   (newline))
                 roots)))
 
+  (define (list-busy)
+    ;; List store items used by running processes.
+    (for-each (lambda (item)
+                (display item) (newline))
+              (busy-store-items)))
+
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
@@ -305,6 +317,9 @@ is deprecated; use '-D'~%"))
         ((list-roots)
          (assert-no-extra-arguments)
          (list-roots))
+        ((list-busy)
+         (assert-no-extra-arguments)
+         (list-busy))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index cab9a4397b..7ae8638911 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -2,6 +2,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -75,6 +76,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n"))
                   (alist-cons 'argument arg result))
                 %default-options))
 
+
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
                             (('argument . value)
@@ -82,11 +84,16 @@ Import and convert the crate.io package for PACKAGE-NAME.\n"))
                             (_ #f))
                            (reverse opts))))
     (match args
-      ((package-name)
-       (let ((sexp (crate->guix-package package-name)))
+      ((spec)
+       (define-values (name version)
+         (package-name->name+version spec))
+
+       (let ((sexp (crate->guix-package name version)))
          (unless sexp
            (leave (G_ "failed to download meta-data for package '~a'~%")
-                  package-name))
+                  (if version
+                      (string-append name "@" version)
+                      name)))
          sexp))
       (()
        (leave (G_ "too few arguments~%")))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index de5b3fc0ff..920d6c01fe 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -516,6 +516,18 @@ the image."
               `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
                 ,@(append-map symlink->directives '#$symlinks)))
 
+            (define tag
+              ;; Compute a meaningful "repository" name, which will show up in
+              ;; the output of "docker images".
+              (let ((manifest (profile-manifest #$profile)))
+                (let loop ((names (map manifest-entry-name
+                                       (manifest-entries manifest))))
+                  (define str (string-join names "-"))
+                  (if (< (string-length str) 40)
+                      str
+                      (match names
+                        ((_) str)
+                        ((names ... _) (loop names))))))) ;drop one entry
 
             (setenv "PATH" (string-append #$archiver "/bin"))
 
@@ -524,6 +536,7 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
+                                #:repository tag
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:environment environment
@@ -944,7 +957,8 @@ Create a bundle of PACKAGE.\n"))
                                   (list (transform store package) output))
                                  ((? package? package)
                                   (list (transform store package) "out")))
-                               (filter-map maybe-package-argument opts)))
+                               (reverse
+                                (filter-map maybe-package-argument opts))))
            (manifest-file (assoc-ref opts 'manifest)))
       (define properties
         (if (assoc-ref opts 'save-provenance?)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 4591d0f308..daf6fcf947 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -368,8 +368,16 @@ the latest known version of ~a (~a)~%")
                      (upstream-source-version source)))))))
     (#f
      (when warn?
-       (warn-no-updater package)))))
-
+       ;; Distinguish between "no updater" and "failing updater."
+       (match (lookup-updater package updaters)
+         ((? upstream-updater? updater)
+          (warning (package-location package)
+                   (G_ "'~a' updater failed to determine available \
+releases for ~a~%")
+                   (upstream-updater-name updater)
+                   (package-name package)))
+         (#f
+          (warn-no-updater package)))))))
 
 
 ;;;
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 4f23ae34e8..58653507f8 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,9 +26,13 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
+  #:use-module (rnrs io ports)
   #:re-export (%gc-roots-directory)
   #:export (gc-roots
-            user-owned?))
+            user-owned?
+            busy-store-items))
 
 ;;; Commentary:
 ;;;
@@ -118,3 +122,124 @@ are user-controlled symlinks stored anywhere on the file system."
 
       (= (stat:uid stat) uid))
     (const #f)))
+
+
+;;;
+;;; Listing "busy" store items: those referenced by currently running
+;;; processes.
+;;;
+
+(define %proc-directory
+  ;; Mount point of Linuxish /proc file system.
+  "/proc")
+
+(define (proc-file-roots dir file)
+  "Return a one-element list containing the file pointed to by DIR/FILE,
+or the empty list."
+  (or (and=> (false-if-exception (readlink (string-append dir "/" file)))
+             list)
+      '()))
+
+(define proc-exe-roots (cut proc-file-roots <> "exe"))
+(define proc-cwd-roots (cut proc-file-roots <> "cwd"))
+
+(define (proc-fd-roots dir)
+  "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+  (let ((dir (string-append dir "/fd")))
+    (filter-map (lambda (file)
+                  (let ((target (false-if-exception
+                                 (readlink (string-append dir "/" file)))))
+                    (and target
+                         (string-prefix? "/" target)
+                         target)))
+                (or (scandir dir string->number) '()))))
+
+(define (proc-maps-roots dir)
+  "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+  (define %file-mapping-line
+    (make-regexp "^.*[[:blank:]]+/([^ ]+)$"))
+
+  (call-with-input-file (string-append dir "/maps")
+    (lambda (maps)
+      (let loop ((line  (read-line maps))
+                 (roots '()))
+        (cond ((eof-object? line)
+               roots)
+              ((regexp-exec %file-mapping-line line)
+               =>
+               (lambda (match)
+                 (let ((file (string-append "/"
+                                            (match:substring match 1))))
+                   (loop (read-line maps)
+                         (cons file roots)))))
+              (else
+               (loop (read-line maps) roots)))))))
+
+(define (proc-environ-roots dir)
+  "Return the list of store files referenced by DIR/environ, where DIR is a
+/proc/XYZ directory."
+  (define split-on-nul
+    (cute string-tokenize <>
+          (char-set-complement (char-set #\nul))))
+
+  (define (rhs-file-names str)
+    (let ((equal (string-index str #\=)))
+      (if equal
+          (let* ((str (substring str (+ 1 equal)))
+                 (rx  (string-append (regexp-quote %store-directory)
+                                     "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
+            (map match:substring (list-matches rx str)))
+          '())))
+
+  (define environ
+    (string-append dir "/environ"))
+
+  (append-map rhs-file-names
+              (split-on-nul
+               (call-with-input-file environ
+                 get-string-all))))
+
+(define (referenced-files)
+  "Return the list of referenced store items."
+  (append-map (lambda (pid)
+                (let ((proc (string-append %proc-directory "/" pid)))
+                  (catch 'system-error
+                    (lambda ()
+                      (append (proc-exe-roots proc)
+                              (proc-cwd-roots proc)
+                              (proc-fd-roots proc)
+                              (proc-maps-roots proc)
+                              (proc-environ-roots proc)))
+                    (lambda args
+                      (let ((err (system-error-errno args)))
+                        (if (or (= ENOENT err)    ;TOCTTOU race
+                                (= ESRCH err)     ;ditto
+                                (= EACCES err))   ;not running as root
+                            '()
+                            (apply throw args)))))))
+              (scandir %proc-directory string->number
+                       (lambda (a b)
+                         (< (string->number a) (string->number b))))))
+
+(define canonicalize-store-item
+  (let* ((store  (string-append %store-directory "/"))
+         (prefix (string-length store)))
+    (lambda (file)
+      "Return #f if FILE is not a store item; otherwise, return the store file
+name without any sub-directory components."
+      (and (string-prefix? store file)
+           (string-append store
+                          (let ((base (string-drop file prefix)))
+                            (match (string-index base #\/)
+                              (#f    base)
+                              (slash (string-take base slash)))))))))
+
+(define (busy-store-items)
+  "Return the list of store items used by the currently running processes.
+
+This code should typically run as root; it allows the garbage collector to
+determine which store items must not be deleted."
+  (delete-duplicates
+   (filter-map canonicalize-store-item (referenced-files))))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index d4f9c5bb45..aa47dab4b4 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -245,18 +245,18 @@ correspond to the same version."
 (define (lookup-updater package updaters)
   "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
 them matches."
-  (any (match-lambda
-         (($ <upstream-updater> name description pred latest)
-          (and (pred package) latest)))
-       updaters))
+  (find (match-lambda
+          (($ <upstream-updater> name description pred latest)
+           (pred package)))
+        updaters))
 
 (define (package-latest-release package updaters)
   "Return an upstream source to update PACKAGE, a <package> object, or #f if
 none of UPDATERS matches PACKAGE.  It is the caller's responsibility to ensure
 that the returned source is newer than the current one."
   (match (lookup-updater package updaters)
-    ((? procedure? latest-release)
-     (latest-release package))
+    ((? upstream-updater? updater)
+     ((upstream-updater-latest updater) package))
     (_ #f)))
 
 (define (package-latest-release* package updaters)
diff --git a/guix/utils.scm b/guix/utils.scm
index f480c3291f..1f99c5b3f5 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -91,6 +91,7 @@
             arguments-from-environment-variable
             file-extension
             file-sans-extension
+            tarball-sans-extension
             compressed-file?
             switch-symlinks
             call-with-temporary-output-file
@@ -578,6 +579,12 @@ minor version numbers from version-string."
         (substring file 0 dot)
         file)))
 
+(define (tarball-sans-extension tarball)
+  "Return TARBALL without its .tar.* or .zip extension."
+  (let ((end (or (string-contains tarball ".tar")
+                 (string-contains tarball ".zip"))))
+    (substring tarball 0 end)))
+
 (define (compressed-file? file)
   "Return true if FILE denotes a compressed file."
   (->bool (member (file-extension file)