Merge branch 'master' into core-updates

20 files changed, 783 insertions, 225 deletions

diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index 10a1bac844..1e8b3a578e 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2016 David Craven <david@craven.ch>
@@ -35,12 +35,17 @@
   #:export (%cargo-build-system-modules
             %cargo-utils-modules
             cargo-build-system
+            %crate-base-url
             crate-url
             crate-url?
             crate-uri))
 
-(define crate-url "https://crates.io/api/v1/crates/")
-(define crate-url? (cut string-prefix? crate-url <>))
+(define %crate-base-url
+  (make-parameter "https://crates.io"))
+(define crate-url
+  (string-append (%crate-base-url) "/api/v1/crates/"))
+(define crate-url?
+  (cut string-prefix? crate-url <>))
 
 (define (crate-uri name version)
   "Return a URI string for the crate package hosted at crates.io corresponding
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm
new file mode 100644
index 0000000000..488fe9bb1d
--- /dev/null
+++ b/guix/build-system/julia.scm
@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.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 build-system julia)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:export (%julia-build-system-modules
+            julia-build
+            julia-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define %julia-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build julia-build-system)
+    ,@%gnu-build-system-modules))
+
+(define (default-julia)
+  "Return the default Julia package."
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((julia-mod (resolve-interface '(gnu packages julia))))
+    (module-ref julia-mod 'julia)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system target
+                (julia (default-julia))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:target #:julia #:inputs #:native-inputs))
+
+  (and (not target)                        ;XXX: no cross-compilation
+       (bag
+         (name name)
+         (system system)
+         (host-inputs `(,@(if source
+                              `(("source" ,source))
+                              '())
+                        ,@inputs
+                        
+                        ;; Keep the standard inputs of 'gnu-build-system'.
+                        ,@(standard-packages)))
+         (build-inputs `(("julia" ,julia)
+                         ,@native-inputs))
+         (outputs outputs)
+         (build julia-build)
+         (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (julia-build store name inputs
+                      #:key source
+                      (tests? #f)
+                      (phases '(@ (guix build julia-build-system)
+                                  %standard-phases))
+                      (outputs '("out"))
+                      (search-paths '())
+                      (system (%current-system))
+                      (guile #f)
+                      (imported-modules %julia-build-system-modules)
+                      (modules '((guix build julia-build-system)
+                                 (guix build utils))))
+  "Build SOURCE using Julia, and with INPUTS."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (julia-build #:name ,name
+                    #:source ,(match (assoc-ref inputs "source")
+                                (((? derivation? source))
+                                 (derivation->output-path source))
+                                ((source)
+                                 source)
+                                (source
+                                 source))
+                    #:system ,system
+                    #:tests? ,tests?
+                    #:phases ,phases
+                    #:outputs %outputs
+                    #:search-paths ',(map search-path-specification->sexp
+                                          search-paths)
+                    #:inputs %build-inputs)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                                         ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:inputs inputs
+                                #:system system
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define julia-build-system
+  (build-system
+   (name 'julia)
+   (description "The build system for Julia packages")
+   (lower lower)))
+
+;;; julia.scm ends here
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 06ed14b89f..f173b64c83 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -81,10 +81,10 @@ Cargo.toml file present at its root."
          ;; archive, but not nested anywhere else). We do this by cutting up
          ;; each output line and only looking at the second component. We then
          ;; check if it matches Cargo.toml exactly and short circuit if it does.
-         (zero? (apply system* (list "sh" "-c"
-                                     (string-append "tar -tf " path
-                                                    " | cut -d/ -f2"
-                                                    " | grep -q '^Cargo.toml$'"))))))
+         (apply invoke (list "sh" "-c"
+                             (string-append "tar -tf " path
+                                            " | cut -d/ -f2"
+                                            " | grep -q '^Cargo.toml$'")))))
 
 (define* (configure #:key inputs
                     (vendor-dir "guix-vendor")
@@ -157,7 +157,7 @@ directory = '" port)
                 #:allow-other-keys)
   "Build a given Cargo package."
   (or skip-build?
-      (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))))
+      (apply invoke `("cargo" "build" ,@cargo-build-flags))))
 
 (define* (check #:key
                 tests?
@@ -165,7 +165,7 @@ directory = '" port)
                 #:allow-other-keys)
   "Run tests for a given Cargo package."
   (if tests?
-      (zero? (apply system* `("cargo" "test" ,@cargo-test-flags)))
+      (apply invoke `("cargo" "test" ,@cargo-test-flags))
       #t))
 
 (define (touch file-name)
@@ -184,7 +184,7 @@ directory = '" port)
     ;; otherwise cargo will raise an error.
     (or skip-build?
         (not (has-executable-target?))
-        (zero? (system* "cargo" "install" "--path" "." "--root" out)))))
+        (invoke "cargo" "install" "--path" "." "--root" out))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
new file mode 100644
index 0000000000..ff6fcf5fe3
--- /dev/null
+++ b/guix/build/julia-build-system.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.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 build julia-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:export (%standard-phases
+            julia-create-package-toml
+            julia-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define (invoke-julia code)
+  (invoke "julia" "-e" code))
+
+;; subpath where we store the package content
+(define %package-path "/share/julia/packages/")
+
+(define (generate-load-path inputs outputs)
+  (string-append
+   (string-join (map (match-lambda
+                       ((_ . path)
+                        (string-append path %package-path)))
+                     ;; Restrict to inputs beginning with "julia-".
+                     (filter (match-lambda
+                               ((name . _)
+                                (string-prefix? "julia-" name)))
+                             inputs))
+                ":")
+   (string-append ":" (assoc-ref outputs "out") %package-path)
+   ;; stdlib is always required to find Julia's standard libraries.
+   ;; usually there are other two paths in this variable:
+   ;; "@" and "@v#.#"
+   ":@stdlib"))
+
+(define* (install #:key source inputs outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (package-dir (string-append out %package-path
+                                     (string-append
+                                      (strip-store-file-name source)))))
+    (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+    (mkdir-p package-dir)
+    (copy-recursively source package-dir))
+  #t)
+
+;; TODO: Precompilation is working, but I don't know how to tell
+;; julia to use use it. If (on rantime) we set HOME to
+;; store path, julia tries to write files there (failing)
+(define* (precompile #:key source inputs outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (builddir (string-append out "/share/julia/"))
+         (package (strip-store-file-name source)))
+    (mkdir-p builddir)
+    (setenv "JULIA_DEPOT_PATH" builddir)
+    (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+    ;; Actual precompilation
+    (invoke-julia (string-append "using " package)))
+  #t)
+
+(define* (check #:key source inputs outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (package (strip-store-file-name source))
+         (builddir (string-append out "/share/julia/")))
+    (setenv "JULIA_DEPOT_PATH" builddir)
+    (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+    (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")")))
+  #t)
+
+(define (julia-create-package-toml outputs source
+                                   name uuid version
+                                   deps)
+  "Some packages are not using the new Package.toml dependency specifications.
+Write this file manually, so that Julia can find its dependencies."
+  (let ((f (open-file
+            (string-append
+             (assoc-ref outputs "out")
+             %package-path
+             (string-append
+              name "/Project.toml"))
+            "w")))
+    (display (string-append
+              "
+name = \"" name "\"
+uuid = \"" uuid "\"
+version = \"" version "\"
+") f)
+    (when (not (null? deps))
+      (display "[deps]\n" f)
+      (for-each (lambda dep
+                  (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n")
+                           f))
+                deps))
+    (close-port f))
+  #t)
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'check) ; tests must be run after installation
+    (replace 'install install)
+    (add-after 'install 'precompile precompile)
+    ;; (add-after 'install 'check check)
+    ;; TODO: In the future we could add a "system-image-generation" phase
+    ;; where we use PackageCompiler.jl to speed up package loading times
+    (delete 'configure)
+    (delete 'bootstrap)
+    (delete 'patch-usr-bin-file)
+    (delete 'build)))
+
+(define* (julia-build #:key inputs (phases %standard-phases)
+                      #:allow-other-keys #:rest args)
+  "Build the given Julia package, applying all of PHASES in order."
+  (apply gnu:gnu-build
+         #:inputs inputs #:phases phases
+         args))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 97bc6197a3..c7a589c902 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -220,12 +220,19 @@ Also load TEST-ASD-FILE if necessary."
   "Return a lisp keyword for the concatenation of STRINGS."
   (string->symbol (apply string-append ":" strings)))
 
-(define (generate-executable-for-system type system)
+(define* (generate-executable-for-system type system #:key compress?)
   "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
 'asdf:program-op.  The latter will always be standalone.  Depends on having
 created a \"SYSTEM-exec\" system which contains the entry program."
   (lisp-eval-program
    `((require :asdf)
+     ;; Only SBCL supports compression as of 2019-09-02.
+     ,(if (and compress? (string=? (%lisp-type) "sbcl"))
+          '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
+                      (uiop:dump-image (asdf:output-file o c)
+                                       :executable t
+                                       :compression t))
+          '())
      (asdf:operate ',type ,(string-append system "-exec")))))
 
 (define (generate-executable-wrapper-system system dependencies)
@@ -339,6 +346,7 @@ which are not nested."
                         (dependency-prefixes (list (library-output outputs)))
                         (dependencies (list (basename program)))
                         entry-program
+                        compress?
                         #:allow-other-keys)
   "Generate an executable program containing all DEPENDENCIES, and which will
 execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
@@ -350,6 +358,7 @@ retained."
                        #:dependencies dependencies
                        #:dependency-prefixes dependency-prefixes
                        #:entry-program entry-program
+                       #:compress? compress?
                        #:type 'asdf:program-op)
   (let* ((name (basename program))
          (bin-directory (dirname program)))
@@ -382,6 +391,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
                               dependency-prefixes
                               entry-program
                               type
+                              compress?
                               #:allow-other-keys)
   "Generate an executable by using asdf operation TYPE, containing whithin the
 image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
@@ -405,7 +415,7 @@ references to those libraries are retained."
                `(((,bin-directory :**/ :*.*.*)
                   (,bin-directory :**/ :*.*.*)))))))
 
-    (generate-executable-for-system type name)
+    (generate-executable-for-system type name #:compress? compress?)
 
     (let* ((after-store-prefix-index
             (string-index out-file #\/
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d30833c5d7..010e0decff 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -75,6 +75,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       #:env-vars
                       `(("bzr url" . ,(bzr-reference-url ref))
                         ("bzr reference" . ,(bzr-reference-revision ref)))
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
                       #:system system
                       #:local-build? #t  ;don't offload repo branching
                       #:hash-algo hash-algo
diff --git a/guix/ci.scm b/guix/ci.scm
index 1727297dd7..9e21996023 100644
--- a/guix/ci.scm
+++ b/guix/ci.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.
 ;;;
@@ -18,9 +18,10 @@
 
 (define-module (guix ci)
   #:use-module (guix http-client)
-  #:autoload   (json parser) (json->scm)
+  #:use-module (guix json)
+  #:use-module (json)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
   #:export (build?
             build-id
             build-derivation
@@ -42,7 +43,7 @@
             queued-builds
             latest-builds
             latest-evaluations
-            evaluation-for-commit))
+            evaluations-for-commit))
 
 ;;; Commentary:
 ;;;
@@ -51,28 +52,31 @@
 ;;;
 ;;; Code:
 
-(define-record-type <build>
-  (make-build id derivation system status timestamp)
-  build?
-  (id          build-id)                          ;integer
+(define-json-mapping <build> make-build build?
+  json->build
+  (id          build-id "id")                     ;integer
   (derivation  build-derivation)                  ;string | #f
   (system      build-system)                      ;string
-  (status      build-status)                      ;integer
+  (status      build-status "buildstatus" )       ;integer
   (timestamp   build-timestamp))                  ;integer
 
-(define-record-type <checkout>
-  (make-checkout commit input)
-  checkout?
+(define-json-mapping <checkout> make-checkout checkout?
+  json->checkout
   (commit      checkout-commit)                   ;string (SHA1)
   (input       checkout-input))                   ;string (name)
 
-(define-record-type <evaluation>
-  (make-evaluation id spec complete? checkouts)
-  evaluation?
+(define-json-mapping <evaluation> make-evaluation evaluation?
+  json->evaluation
   (id          evaluation-id)                     ;integer
   (spec        evaluation-spec)                   ;string
-  (complete?   evaluation-complete?)              ;Boolean
-  (checkouts   evaluation-checkouts))             ;<checkout>*
+  (complete?   evaluation-complete? "in-progress"
+               (match-lambda
+                 (0 #t)
+                 (_ #f)))                         ;Boolean
+  (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
+               (lambda (checkouts)
+                 (map json->checkout
+                      (vector->list checkouts)))))
 
 (define %query-limit
   ;; Max number of builds requested in queries.
@@ -84,18 +88,11 @@
     (close-port port)
     json))
 
-(define (json->build json)
-  (make-build (hash-ref json "id")
-              (hash-ref json "derivation")
-              (hash-ref json "system")
-              (hash-ref json "buildstatus")
-              (hash-ref json "timestamp")))
-
 (define* (queued-builds url #:optional (limit %query-limit))
   "Return the list of queued derivations on URL."
   (let ((queue (json-fetch (string-append url "/api/queue?nr="
                                           (number->string limit)))))
-    (map json->build queue)))
+    (map json->build (vector->list queue))))
 
 (define* (latest-builds url #:optional (limit %query-limit)
                         #:key evaluation system)
@@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
                                            (option "system" system)))))
     ;; Note: Hydra does not provide a "derivation" field for entries in
     ;; 'latestbuilds', but Cuirass does.
-    (map json->build latest)))
-
-(define (json->checkout json)
-  (make-checkout (hash-ref json "commit")
-                 (hash-ref json "input")))
-
-(define (json->evaluation json)
-  (make-evaluation (hash-ref json "id")
-                   (hash-ref json "specification")
-                   (case (hash-ref json "in-progress")
-                     ((0) #t)
-                     (else #f))
-                   (map json->checkout (hash-ref json "checkouts"))))
+    (map json->build (vector->list latest))))
 
 (define* (latest-evaluations url #:optional (limit %query-limit))
   "Return the latest evaluations performed by the CI server at URL."
   (map json->evaluation
-       (json->scm
-        (http-fetch (string-append url "/api/evaluations?nr="
-                                   (number->string limit))))))
+       (vector->list
+        (json->scm
+         (http-fetch (string-append url "/api/evaluations?nr="
+                                    (number->string limit)))))))
 
 
 (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 8b46f8ef8c..cb42103aae 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "cvs-checkout") build
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
                       #:system system
                       #:hash-algo hash-algo
                       #:hash hash
diff --git a/guix/git-download.scm b/guix/git-download.scm
index c62bb8ad0f..1eae035fc4 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -157,6 +157,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                         ("git commit" . ,(git-reference-commit ref))
                         ("git recursive?" . ,(object->string
                                               (git-reference-recursive? ref))))
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
 
                       #:system system
                       #:local-build? #t           ;don't offload repo cloning
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6b25b87b6b..4cdc1a780a 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "hg-checkout") build
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
                       #:system system
                       #:local-build? #t           ;don't offload repo cloning
                       #:hash-algo hash-algo
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 51c7ea7b2f..35caa3e463 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -230,16 +230,17 @@ from ~s: ~a (~s)~%"
                           (if (boolean? type) meta
                               (cons `(bioconductor-type . ,type) meta))))))))))
     ((git)
-     ;; Download the git repository at "NAME"
-     (call-with-values
-         (lambda () (download name #t))
-       (lambda (dir commit)
-         (and=> (description->alist (with-input-from-file
-                                        (string-append dir "/DESCRIPTION") read-string))
-                (lambda (meta)
-                  (cons* `(git . ,name)
-                         `(git-commit . ,commit)
-                         meta))))))))
+     (and (string-prefix? "http" name)
+          ;; Download the git repository at "NAME"
+          (call-with-values
+              (lambda () (download name #t))
+            (lambda (dir commit)
+              (and=> (description->alist (with-input-from-file
+                                             (string-append dir "/DESCRIPTION") read-string))
+                     (lambda (meta)
+                       (cons* `(git . ,name)
+                              `(git-commit . ,commit)
+                              meta)))))))))
 
 (define (listify meta field)
   "Look up FIELD in the alist META.  If FIELD contains a comma-separated
@@ -494,12 +495,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
      "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
 s-expression corresponding to that package, or #f on failure."
      (let ((description (fetch-description repo package-name)))
-       (if (and (not description)
-                (eq? repo 'bioconductor))
-           ;; Retry import from CRAN
-           (cran->guix-package package-name 'cran)
-           (and description
-                (description->package repo description)))))))
+       (if description
+           (description->package repo description)
+           (case repo
+             ((git)
+              ;; Retry import from Bioconductor
+              (cran->guix-package package-name 'bioconductor))
+             ((bioconductor)
+              ;; Retry import from CRAN
+              (cran->guix-package package-name 'cran))
+             (else #f)))))))
 
 (define* (cran-recursive-import package-name #:optional (repo 'cran))
   (recursive-import package-name repo
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 52c5cb1c30..f6057dbf8b 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module ((guix download) #:prefix download:)
   #:use-module (gcrypt hash)
   #:use-module (guix http-client)
+  #:use-module (guix json)
   #:use-module (guix import json)
   #:use-module (guix import utils)
   #:use-module ((guix licenses) #:prefix license:)
@@ -30,7 +32,7 @@
   #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 pretty-print) ; recursive
+  #:use-module (ice-9 regex)
   #:use-module (json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
@@ -39,46 +41,82 @@
             guix-package->crate-name
             %crate-updater))
 
-(define (crate-fetch crate-name callback)
-  "Fetch the metadata for CRATE-NAME from crates.io and call the callback."
+
+;;;
+;;; Interface to https://crates.io/api/v1.
+;;;
 
-  (define (crates->inputs crates)
-    (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?))
+;; Crates.  A crate is essentially a "package".  It can have several
+;; "versions", each of which has its own set of dependencies, license,
+;; etc.--see <crate-version> below.
+(define-json-mapping <crate> make-crate crate?
+  json->crate
+  (name          crate-name)                      ;string
+  (latest-version crate-latest-version "max_version") ;string
+  (home-page     crate-home-page "homepage")      ;string | #nil
+  (repository    crate-repository)                ;string
+  (description   crate-description)               ;string
+  (keywords      crate-keywords                   ;list of strings
+                 "keywords" vector->list)
+  (categories    crate-categories                 ;list of strings
+                 "categories" vector->list)
+  (versions      crate-versions "actual_versions" ;list of <crate-version>
+                 (lambda (vector)
+                   (map json->crate-version
+                        (vector->list vector))))
+  (links         crate-links))                    ;alist
 
-  (define (string->license string)
-    (map spdx-string->license (string-split string #\/)))
-
-  (define (crate-kind-predicate kind)
-    (lambda (dep) (string=? (assoc-ref dep "kind") kind)))
-
-  (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
-             (crate (assoc-ref crate-json "crate"))
-             (name (assoc-ref crate "name"))
-             (version (assoc-ref crate "max_version"))
-             (homepage (assoc-ref crate "homepage"))
-             (repository (assoc-ref crate "repository"))
-             (synopsis (assoc-ref crate "description"))
-             (description (assoc-ref crate "description"))
-             (license (or (and=> (assoc-ref crate "license")
-                                 string->license)
-                          '()))                   ;missing license info
-             (path (string-append "/" version "/dependencies"))
-             (deps-json (json-fetch (string-append crate-url name path)))
-             (deps (vector->list (assoc-ref deps-json "dependencies")))
-             (dep-crates (filter (crate-kind-predicate "normal") deps))
-             (dev-dep-crates
-              (filter (lambda (dep)
-                        (not ((crate-kind-predicate "normal") dep))) deps))
-             (cargo-inputs (crates->inputs dep-crates))
-             (cargo-development-inputs (crates->inputs dev-dep-crates))
-             (home-page (match homepage
-                          (() repository)
-                          (_ homepage))))
-    (callback #:name name #:version version
-              #:cargo-inputs cargo-inputs
-              #:cargo-development-inputs cargo-development-inputs
-              #:home-page home-page #:synopsis synopsis
-              #:description description #:license license)))
+;; Crate version.
+(define-json-mapping <crate-version> make-crate-version crate-version?
+  json->crate-version
+  (id            crate-version-id)                ;integer
+  (number        crate-version-number "num")      ;string
+  (download-path crate-version-download-path "dl_path") ;string
+  (readme-path   crate-version-readme-path "readme_path") ;string
+  (license       crate-version-license "license") ;string
+  (links         crate-version-links))            ;alist
+
+;; Crate dependency.  Each dependency (each edge in the graph) is annotated as
+;; being a "normal" dependency or a development dependency.  There also
+;; information about the minimum required version, such as "^0.0.41".
+(define-json-mapping <crate-dependency> make-crate-dependency
+  crate-dependency?
+  json->crate-dependency
+  (id            crate-dependency-id "crate_id")  ;string
+  (kind          crate-dependency-kind "kind"     ;'normal | 'dev
+                 string->symbol)
+  (requirement   crate-dependency-requirement "req")) ;string
+
+(define (lookup-crate name)
+  "Look up NAME on https://crates.io and return the corresopnding <crate>
+record or #f if it was not found."
+  (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
+                                         name))))
+    (and=> (and json (assoc-ref json "crate"))
+           (lambda (alist)
+             ;; The "versions" field of ALIST is simply a list of version IDs
+             ;; (integers).  Here, we squeeze in the actual version
+             ;; dictionaries that are not part of ALIST but are just more
+             ;; convenient handled this way.
+             (let ((versions (or (assoc-ref json "versions") '#())))
+               (json->crate `(,@alist
+                              ("actual_versions" . ,versions))))))))
+
+(define (crate-version-dependencies version)
+  "Return the list of <crate-dependency> records of VERSION, a
+<crate-version>."
+  (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
+         (url  (string-append (%crate-base-url) path)))
+    (match (assoc-ref (or (json-fetch url) '()) "dependencies")
+      ((? vector? vector)
+       (map json->crate-dependency (vector->list vector)))
+      (_
+       '()))))
+
+
+;;;
+;;; Converting crates to Guix packages.
+;;;
 
 (define (maybe-cargo-inputs package-names)
   (match (package-names->package-inputs package-names)
@@ -138,10 +176,49 @@ and LICENSE."
          (close-port port)
          pkg))
 
+(define %dual-license-rx
+  ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0".
+  ;; This regexp matches that.
+  (make-regexp "^(.*) OR (.*)$"))
+
 (define (crate->guix-package crate-name)
   "Fetch the metadata for CRATE-NAME from crates.io, and return the
 `package' s-expression corresponding to that package, or #f on failure."
-  (crate-fetch crate-name make-crate-sexp))
+  (define (string->license string)
+    (match (regexp-exec %dual-license-rx string)
+      (#f (list (spdx-string->license string)))
+      (m  (list (spdx-string->license (match:substring m 1))
+                (spdx-string->license (match:substring m 2))))))
+
+  (define (normal-dependency? dependency)
+    (eq? (crate-dependency-kind dependency) 'normal))
+
+  (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))
+              (dep-crates     (filter normal-dependency? dependencies))
+              (dev-dep-crates (remove normal-dependency? dependencies))
+              (cargo-inputs   (sort (map crate-dependency-id dep-crates)
+                                    string-ci<?))
+              (cargo-development-inputs
+               (sort (map crate-dependency-id dev-dep-crates)
+                     string-ci<?)))
+         (make-crate-sexp #:name crate-name
+                          #: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)
+                                           string->license)))))
 
 (define (guix-package->crate-name package)
   "Return the crate name of PACKAGE."
@@ -157,6 +234,7 @@ and LICENSE."
 (define (crate-name->package-name name)
   (string-append "rust-" (string-join (string-split name #\_) "-")))
 
+
 ;;;
 ;;; Updater
 ;;;
@@ -175,9 +253,9 @@ and LICENSE."
 (define (latest-release package)
   "Return an <upstream-source> for the latest release of PACKAGE."
   (let* ((crate-name (guix-package->crate-name package))
-         (callback (lambda* (#:key version #:allow-other-keys) version))
-         (version (crate-fetch crate-name callback))
-         (url (crate-uri crate-name version)))
+         (crate      (lookup-crate crate-name))
+         (version    (crate-latest-version crate))
+         (url        (crate-uri crate-name version)))
     (upstream-source
      (package (package-name package))
      (version version)
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 5dcc0e97a3..7f089a5cf3 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -238,7 +238,9 @@ path to the repository."
              (version (find-latest-version name repository))
              (file (string-append repository "/packages/" name "/" name "." version "/opam")))
     `(("metadata" ,@(get-metadata file))
-      ("version" . ,version))))
+      ("version" . ,(if (string-prefix? "v" version)
+                        (substring version 1)
+                        version)))))
 
 (define (opam->guix-package name)
   (and-let* ((opam-file (opam-fetch name))
@@ -283,7 +285,7 @@ path to the repository."
                                           'ocaml-build-system))
                        ,@(if (null? inputs)
                            '()
-                           `((inputs ,(list 'quasiquote inputs))))
+                           `((propagated-inputs ,(list 'quasiquote inputs))))
                        ,@(if (null? native-inputs)
                            '()
                            `((native-inputs ,(list 'quasiquote native-inputs))))
diff --git a/guix/json.scm b/guix/json.scm
new file mode 100644
index 0000000000..20f0bd8f13
--- /dev/null
+++ b/guix/json.scm
@@ -0,0 +1,62 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix json)
+  #:use-module (json)
+  #:use-module (srfi srfi-9)
+  #:export (define-json-mapping))
+
+;;; Commentary:
+;;;
+;;; Helpers to map JSON objects to SRFI-9 records.  Taken from (guix swh).
+;;;
+;;; Code:
+
+(define-syntax-rule (define-json-reader json->record ctor spec ...)
+  "Define JSON->RECORD as a procedure that converts a JSON representation,
+read from a port, string, or hash table, into a record created by CTOR and
+following SPEC, a series of field specifications."
+  (define (json->record input)
+    (let ((table (cond ((port? input)
+                        (json->scm input))
+                       ((string? input)
+                        (json-string->scm input))
+                       ((or (null? input) (pair? input))
+                        input))))
+      (let-syntax ((extract-field (syntax-rules ()
+                                    ((_ table (field key json->value))
+                                     (json->value (assoc-ref table key)))
+                                    ((_ table (field key))
+                                     (assoc-ref table key))
+                                    ((_ table (field))
+                                     (assoc-ref table
+                                                (symbol->string 'field))))))
+        (ctor (extract-field table spec) ...)))))
+
+(define-syntax-rule (define-json-mapping rtd ctor pred json->record
+                      (field getter spec ...) ...)
+  "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
+and define JSON->RECORD as a conversion from JSON to a record of this type."
+  (begin
+    (define-record-type rtd
+      (ctor field ...)
+      pred
+      (field getter) ...)
+
+    (define-json-reader json->record ctor
+      (field spec ...) ...)))
diff --git a/guix/lint.scm b/guix/lint.scm
index 212ff70d54..ba38bef806 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -44,6 +44,8 @@
   #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
   #:use-module (guix gnu-maintenance)
   #:use-module (guix cve)
+  #:use-module ((guix swh) #:hide (origin?))
+  #:autoload   (guix git-download) (git-reference?)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -80,6 +82,7 @@
             check-vulnerabilities
             check-for-updates
             check-formatting
+            check-archival
 
             lint-warning
             lint-warning?
@@ -950,6 +953,16 @@ display a message including MESSAGE and return ERROR-VALUE."
                   message
                   (tls-certificate-error-string args))
          error-value)
+        ((and ('system-error _ ...) args)
+         (let ((errno (system-error-errno args)))
+           (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
+               (let ((details (call-with-output-string
+                                (lambda (port)
+                                  (print-exception port #f (car args)
+                                                   (cdr args))))))
+                 (warning (G_ "~a: ~a~%") message details)
+                 error-value)
+               (apply throw args))))
         (args
          (apply throw args))))))
 
@@ -1023,6 +1036,93 @@ the NIST server non-fatal."
          '()))
     (#f '()))) ; cannot find newer upstream release
 
+
+(define (check-archival package)
+  "Check whether PACKAGE's source code is archived on Software Heritage.  If
+it's not, and if its source code is a VCS snapshot, then send a \"save\"
+request to Software Heritage.
+
+Software Heritage imposes limits on the request rate per client IP address.
+This checker prints a notice and stops doing anything once that limit has been
+reached."
+  (define (response->warning url method response)
+    (if (request-rate-limit-reached? url method)
+        (list (make-warning package
+                            (G_ "Software Heritage rate limit reached; \
+try again later")
+                            #:field 'source))
+        (list (make-warning package
+                            (G_ "'~a' returned ~a")
+                            (list url (response-code response))
+                            #:field 'source))))
+
+  (define skip-key (gensym "skip-archival-check"))
+
+  (define (skip-when-limit-reached url method)
+    (or (not (request-rate-limit-reached? url method))
+        (throw skip-key #t)))
+
+  (parameterize ((%allow-request? skip-when-limit-reached))
+    (catch #t
+      (lambda ()
+        (match (and (origin? (package-source package))
+                    (package-source package))
+          (#f                                     ;no source
+           '())
+          ((= origin-uri (? git-reference? reference))
+           (define url
+             (git-reference-url reference))
+           (define commit
+             (git-reference-commit reference))
+
+           (match (if (commit-id? commit)
+                      (or (lookup-revision commit)
+                          (lookup-origin-revision url commit))
+                      (lookup-origin-revision url commit))
+             ((? revision? revision)
+              '())
+             (#f
+              ;; Revision is missing from the archive, attempt to save it.
+              (catch 'swh-error
+                (lambda ()
+                  (save-origin (git-reference-url reference) "git")
+                  (list (make-warning
+                         package
+                         ;; TRANSLATORS: "Software Heritage" is a proper noun
+                         ;; that must remain untranslated.  See
+                         ;; <https://www.softwareheritage.org>.
+                         (G_ "scheduled Software Heritage archival")
+                         #:field 'source)))
+                (lambda (key url method response . _)
+                  (cond ((= 429 (response-code response))
+                         (list (make-warning
+                                package
+                                (G_ "archival rate limit exceeded; \
+try again later")
+                                #:field 'source)))
+                        (else
+                         (response->warning url method response))))))))
+          ((? origin? origin)
+           ;; Since "save" origins are not supported for non-VCS source, all
+           ;; we can do is tell whether a given tarball is available or not.
+           (if (origin-sha256 origin)             ;XXX: for ungoogled-chromium
+               (match (lookup-content (origin-sha256 origin) "sha256")
+                 (#f
+                  (list (make-warning package
+                                      (G_ "source not archived on Software \
+Heritage")
+                                      #:field 'source)))
+                 ((? content?)
+                  '()))
+               '()))))
+      (match-lambda*
+        ((key url method response)
+         (response->warning url method response))
+        ((key . args)
+         (if (eq? key skip-key)
+             '()
+             (apply throw key args)))))))
+
 
 ;;;
 ;;; Source code formatting.
@@ -1031,7 +1131,7 @@ the NIST server non-fatal."
 (define (report-tabulations package line line-number)
   "Warn about tabulations found in LINE."
   (match (string-index line #\tab)
-    (#f #t)
+    (#f #f)
     (index
      (make-warning package
                    (G_ "tabulation on line ~a, column ~a")
@@ -1043,44 +1143,44 @@ the NIST server non-fatal."
 
 (define (report-trailing-white-space package line line-number)
   "Warn about trailing white space in LINE."
-  (unless (or (string=? line (string-trim-right line))
-              (string=? line (string #\page)))
-    (make-warning package
-                  (G_ "trailing white space on line ~a")
-                  (list line-number)
-                  #:location
-                  (location (package-file package)
-                            line-number
-                            0))))
+  (and (not (or (string=? line (string-trim-right line))
+                (string=? line (string #\page))))
+       (make-warning package
+                     (G_ "trailing white space on line ~a")
+                     (list line-number)
+                     #:location
+                     (location (package-file package)
+                               line-number
+                               0))))
 
 (define (report-long-line package line line-number)
   "Emit a warning if LINE is too long."
   ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
   ;; make it hard to fit within that limit and we want to avoid making too
   ;; much noise.
-  (when (> (string-length line) 90)
-    (make-warning package
-                  (G_ "line ~a is way too long (~a characters)")
-                  (list line-number (string-length line))
-                  #:location
-                  (location (package-file package)
-                            line-number
-                            0))))
+  (and (> (string-length line) 90)
+       (make-warning package
+                     (G_ "line ~a is way too long (~a characters)")
+                     (list line-number (string-length line))
+                     #:location
+                     (location (package-file package)
+                               line-number
+                               0))))
 
 (define %hanging-paren-rx
   (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
 
 (define (report-lone-parentheses package line line-number)
   "Emit a warning if LINE contains hanging parentheses."
-  (when (regexp-exec %hanging-paren-rx line)
-    (make-warning package
-                  (G_ "parentheses feel lonely, \
+  (and (regexp-exec %hanging-paren-rx line)
+       (make-warning package
+                     (G_ "parentheses feel lonely, \
 move to the previous or next line")
-                  (list line-number)
-                  #:location
-                  (location (package-file package)
-                            line-number
-                            0))))
+                     (list line-number)
+                     #:location
+                     (location (package-file package)
+                               line-number
+                               0))))
 
 (define %formatting-reporters
   ;; List of procedures that report formatting issues.  These are not separate
@@ -1130,11 +1230,9 @@ them for PACKAGE."
                          warnings
                          (if (< line-number starting-line)
                              '()
-                             (filter
-                              lint-warning?
-                              (map (lambda (report)
-                                     (report package line line-number))
-                                   reporters))))))))))))
+                             (filter-map (lambda (report)
+                                           (report package line line-number))
+                                         reporters)))))))))))
 
 (define (check-formatting package)
   "Check the formatting of the source code of PACKAGE."
@@ -1229,7 +1327,11 @@ or a list thereof")
    (lint-checker
      (name        'refresh)
      (description "Check the package for new upstream releases")
-     (check       check-for-updates))))
+     (check       check-for-updates))
+   (lint-checker
+     (name        'archival)
+     (description "Ensure source code archival on Software Heritage")
+     (check       check-archival))))
 
 (define %all-checkers
   (append %local-checkers
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 329de41143..cf571756fd 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -66,11 +66,15 @@ Perform the deployment specified by FILE.\n"))
          %standard-build-options))
 
 (define %default-options
-  `((substitutes? . #t)
-    (build-hook? . #t)
-    (graft? . #t)
+  ;; Alist of default option values.
+  `((verbosity . 1)
     (debug . 0)
-    (verbosity . 1)))
+    (graft? . #t)
+    (substitutes? . #t)
+    (build-hook? . #t)
+    (print-build-trace? . #t)
+    (print-extended-build-trace? . #t)
+    (multiplexed-build-output? . #t)))
 
 (define (load-source-file file)
   "Load FILE as a user module."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9fc3a10e98..27b014db68 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -384,12 +384,14 @@ STORE is an open connection to the store."
                              (bootloader bootloader)))
 
          ;; Make the specified system generation the default entry.
-         (params (profile-boot-parameters %system-profile (list number)))
+         (params (first (profile-boot-parameters %system-profile
+                                                 (list number))))
          (old-generations
           (delv number (reverse (generation-numbers %system-profile))))
          (old-params (profile-boot-parameters
                        %system-profile old-generations))
-         (entries (map boot-parameters->menu-entry params))
+         (entries (cons (boot-parameters->menu-entry params)
+                        (boot-parameters-bootloader-menu-entries params)))
          (old-entries (map boot-parameters->menu-entry old-params)))
     (run-with-store store
       (mlet* %store-monad
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 5c25437059..4139cbc2e2 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
@@ -131,6 +131,9 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "svn-checkout") build
+                      #:leaked-env-vars '("http_proxy" "https_proxy"
+                                          "LC_ALL" "LC_MESSAGES" "LANG"
+                                          "COLUMNS")
                       #:system system
                       #:hash-algo hash-algo
                       #:hash hash
diff --git a/guix/swh.scm b/guix/swh.scm
index c253e217da..7acad05928 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -20,6 +20,8 @@
   #:use-module (guix base16)
   #:use-module (guix build utils)
   #:use-module ((guix build syscalls) #:select (mkdtemp!))
+  #:use-module (web uri)
+  #:use-module (guix json)
   #:use-module (web client)
   #:use-module (web response)
   #:use-module (json)
@@ -32,6 +34,9 @@
   #:use-module (ice-9 popen)
   #:use-module ((ice-9 ftw) #:select (scandir))
   #:export (%swh-base-url
+            %allow-request?
+
+            request-rate-limit-reached?
 
             origin?
             origin-id
@@ -101,6 +106,8 @@
             request-cooking
             vault-fetch
 
+            commit-id?
+
             swh-download))
 
 ;;; Commentary:
@@ -129,40 +136,6 @@
       url
       (string-append url "/")))
 
-(define-syntax-rule (define-json-reader json->record ctor spec ...)
-  "Define JSON->RECORD as a procedure that converts a JSON representation,
-read from a port, string, or hash table, into a record created by CTOR and
-following SPEC, a series of field specifications."
-  (define (json->record input)
-    (let ((table (cond ((port? input)
-                        (json->scm input))
-                       ((string? input)
-                        (json-string->scm input))
-                       ((or (null? input) (pair? input))
-                        input))))
-      (let-syntax ((extract-field (syntax-rules ()
-                                    ((_ table (field key json->value))
-                                     (json->value (assoc-ref table key)))
-                                    ((_ table (field key))
-                                     (assoc-ref table key))
-                                    ((_ table (field))
-                                     (assoc-ref table
-                                                (symbol->string 'field))))))
-        (ctor (extract-field table spec) ...)))))
-
-(define-syntax-rule (define-json-mapping rtd ctor pred json->record
-                      (field getter spec ...) ...)
-  "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
-and define JSON->RECORD as a conversion from JSON to a record of this type."
-  (begin
-    (define-record-type rtd
-      (ctor field ...)
-      pred
-      (field getter) ...)
-
-    (define-json-reader json->record ctor
-      (field spec ...) ...)))
-
 (define %date-regexp
   ;; Match strings like "2014-11-17T22:09:38+01:00" or
   ;; "2018-09-30T23:20:07.815449+00:00"".
@@ -196,31 +169,71 @@ Software Heritage."
     ((? string? str) str)
     ((? null?) #f)))
 
+(define %allow-request?
+  ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
+  ;; to keep going.  This can be used to disallow a requests when
+  ;; 'request-rate-limit-reached?' returns true, for instance.
+  (make-parameter (const #t)))
+
+;; The time when the rate limit for "/origin/save" POST requests and that of
+;; other requests will be reset.
+;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+(define %save-rate-limit-reset-time 0)
+(define %general-rate-limit-reset-time 0)
+
+(define (request-rate-limit-reached? url method)
+  "Return true if the rate limit has been reached for URI."
+  (define uri
+    (string->uri url))
+
+  (define reset-time
+    (if (and (eq? method http-post)
+             (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+        %save-rate-limit-reset-time
+        %general-rate-limit-reset-time))
+
+  (< (car (gettimeofday)) reset-time))
+
+(define (update-rate-limit-reset-time! url method response)
+  "Update the rate limit reset time for URL and METHOD based on the headers in
+RESPONSE."
+  (let ((uri (string->uri url)))
+    (match (assq-ref (response-headers response) 'x-ratelimit-reset)
+      ((= string->number (? number? reset))
+       (if (and (eq? method http-post)
+                (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+           (set! %save-rate-limit-reset-time reset)
+           (set! %general-rate-limit-reset-time reset)))
+      (_
+       #f))))
+
 (define* (call url decode #:optional (method http-get)
                #:key (false-if-404? #t))
   "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
 using DECODE, a one-argument procedure that takes an input port.  When
 FALSE-IF-404? is true, return #f upon 404 responses."
-  (let*-values (((response port)
-                 (method url #:streaming? #t)))
-    ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
-    (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
-      (#f #t)
-      ((? (compose zero? string->number))
-       (throw 'swh-error url response))
-      (_ #t))
-
-    (cond ((= 200 (response-code response))
-           (let ((result (decode port)))
-             (close-port port)
-             result))
-          ((and false-if-404?
-                (= 404 (response-code response)))
-           (close-port port)
-           #f)
-          (else
-           (close-port port)
-           (throw 'swh-error url response)))))
+  (and ((%allow-request?) url method)
+       (let*-values (((response port)
+                      (method url #:streaming? #t)))
+         ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+         (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
+           (#f #t)
+           ((? (compose zero? string->number))
+            (update-rate-limit-reset-time! url method response)
+            (throw 'swh-error url method response))
+           (_ #t))
+
+         (cond ((= 200 (response-code response))
+                (let ((result (decode port)))
+                  (close-port port)
+                  result))
+               ((and false-if-404?
+                     (= 404 (response-code response)))
+                (close-port port)
+                #f)
+               (else
+                (close-port port)
+                (throw 'swh-error url method response))))))
 
 (define-syntax define-query
   (syntax-rules (path)
@@ -524,7 +537,7 @@ requested bundle cooking, waiting for completion...~%"))
 
 (define (commit-id? reference)
   "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
-it is a tag name."
+it is a tag name.  This is based on a simple heuristic so use with care!"
   (and (= (string-length reference) 40)
        (string-every char-set:hex-digit reference)))
 
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index a56d6f213d..05ce39bca2 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +22,7 @@
   #:use-module (web server http)
   #:use-module (web response)
   #:use-module (srfi srfi-39)
+  #:use-module (ice-9 match)
   #:export (with-http-server
             call-with-http-server
             %http-server-port
@@ -69,10 +70,20 @@ needed."
   (string-append "http://localhost:" (number->string (%http-server-port))
                  "/foo/bar"))
 
-(define* (call-with-http-server code data thunk
-                                #:key (headers '()))
-  "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
+(define* (call-with-http-server responses+data thunk)
+  "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests.  Each elements of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string."
+  (define responses
+    (map (match-lambda
+           (((? response? response) data)
+            (list response data))
+           (((? integer? code) data)
+            (list (build-response #:code code
+                                  #:reason-phrase "Such is life")
+                  data)))
+         responses+data))
+
   (define (http-write server client response body)
     "Write RESPONSE."
     (let* ((response (write-response response client))
@@ -82,7 +93,8 @@ string) on HTTP requests."
        (else
         (write-response-body response body)))
       (close-port port)
-      (quit #t)                                   ;exit the server thread
+      (when (null? responses)
+        (quit #t))                                ;exit the server thread
       (values)))
 
   ;; Mutex and condition variable to synchronize with the HTTP server.
@@ -105,10 +117,10 @@ string) on HTTP requests."
 
   (define (server-body)
     (define (handle request body)
-      (values (build-response #:code code
-                              #:reason-phrase "Such is life"
-                              #:headers headers)
-              data))
+      (match responses
+        (((response data) rest ...)
+         (set! responses rest)
+         (values response data))))
 
     (let ((socket (open-http-server-socket)))
       (catch 'quit
@@ -126,10 +138,7 @@ string) on HTTP requests."
 
 (define-syntax with-http-server
   (syntax-rules ()
-    ((_ (code headers) data body ...)
-     (call-with-http-server code data (lambda () body ...)
-                            #:headers headers))
-    ((_ code data body ...)
-     (call-with-http-server code data (lambda () body ...)))))
+    ((_ responses+data body ...)
+     (call-with-http-server responses+data (lambda () body ...)))))
 
 ;;; http.scm ends here