Merge remote-tracking branch 'origin/master' into staging

27 files changed, 290 insertions, 169 deletions

diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index efade6f74b..c8f04b2298 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2017, 2021-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net>
@@ -212,6 +212,7 @@ provides a 'setup.py' file as its build system."
                                                   system #:graft? #f)))
     (gexp->derivation name build
                       #:system system
+                      #:graft? #f                 ;consistent with 'gnu-build'
                       #:target #f
                       #:guile-for-build guile)))
 
diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm
index a9bf728f25..7e3a54f1f8 100644
--- a/guix/build-system/qt.scm
+++ b/guix/build-system/qt.scm
@@ -181,6 +181,7 @@ provides a 'CMakeLists.txt' file as its build system."
   (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                   system #:graft? #f)))
     (gexp->derivation name builder
+                      #:graft? #f                 ;consistent with 'gnu-build'
                       #:system system
                       #:guile-for-build guile)))
 
@@ -269,6 +270,7 @@ build system."
   (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                   system #:graft? #f)))
     (gexp->derivation name builder
+                      #:graft? #f                 ;consistent with 'gnu-build'
                       #:system system
                       #:guile-for-build guile)))
 
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 7842b0a9fc..61926beb80 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -46,6 +46,7 @@
             MS_NOEXEC
             MS_REMOUNT
             MS_NOATIME
+            MS_NODIRATIME
             MS_STRICTATIME
             MS_RELATIME
             MS_BIND
@@ -537,6 +538,7 @@ the last argument of `mknod'."
 (define MS_NOEXEC             8)
 (define MS_REMOUNT           32)
 (define MS_NOATIME         1024)
+(define MS_NODIRATIME      2048)
 (define MS_BIND            4096)
 (define MS_MOVE            8192)
 (define MS_SHARED       1048576)
@@ -640,7 +642,8 @@ the remaining unprocessed options."
                         ("nodev"      => MS_NODEV)
                         ("noexec"     => MS_NOEXEC)
                         ("relatime"   => MS_RELATIME)
-                        ("noatime"    => MS_NOATIME)))))))
+                        ("noatime"    => MS_NOATIME)
+                        ("nodiratime" => MS_NODIRATIME)))))))
 
 (define (mount-flags mount)
   "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of
@@ -873,7 +876,7 @@ fdatasync(2) on the underlying file descriptor."
      (ST_NODEV      => MS_NODEV)
      (ST_NOEXEC     => MS_NOEXEC)
      (ST_NOATIME    => MS_NOATIME)
-     (ST_NODIRATIME => 0)                         ;FIXME
+     (ST_NODIRATIME => MS_NODIRATIME)
      (ST_RELATIME   => MS_RELATIME))))
 
 (define-c-struct %statfs                          ;<bits/statfs.h>
diff --git a/guix/channels.scm b/guix/channels.scm
index f1c23c17fb..d84228c47e 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -248,7 +248,7 @@ could be found at DIRECTORY or one of its ancestors."
 'latest-repository-commit'."
   (match (channel-commit channel)
     (#f      `(branch . ,(channel-branch channel)))
-    (commit  `(commit . ,(channel-commit channel)))))
+    (commit  `(tag-or-commit . ,(channel-commit channel)))))
 
 (define sexp->channel-introduction
   (match-lambda
diff --git a/guix/ci.scm b/guix/ci.scm
index 88b80f781d..ecdffde2d1 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -24,6 +24,7 @@
                 #:select (resolve-uri-reference))
   #:use-module (json)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 match)
   #:use-module (web uri)
   #:use-module (guix i18n)
@@ -42,6 +43,9 @@
             build-system
             build-status
             build-timestamp
+            build-start-time
+            build-stop-time
+            build-duration
             build-products
 
             checkout?
@@ -84,6 +88,11 @@
 ;;;
 ;;; Code:
 
+(define (seconds->date seconds)
+  "Given SECONDS, a number of seconds since 1970-01-01, return the
+corresponding date object."
+  (time-utc->date (make-time time-utc 0 seconds)))
+
 (define-json-mapping <build-product> make-build-product
   build-product?
   json->build-product
@@ -118,6 +127,10 @@
   (status      build-status "buildstatus"         ;symbol
                integer->build-status)
   (timestamp   build-timestamp)                   ;integer
+  (start-time  build-start-time "starttime"       ;date
+               seconds->date)
+  (stop-time   build-stop-time "stoptime"         ;date
+               seconds->date)
   (products    build-products "buildproducts"     ;<build-product>*
                (lambda (products)
                  (map json->build-product
@@ -201,6 +214,14 @@ api-agnostic."
 (define* (json-api-fetch base-url path #:rest query)
   (json-fetch (apply api-url base-url path query)))
 
+(define (build-duration build)
+  "Return the duration in seconds of BUILD."
+  (define duration
+    (time-difference (date->time-utc (build-stop-time build))
+                     (date->time-utc (build-start-time build))))
+
+  (time-second duration))
+
 (define* (queued-builds url #:optional (limit %query-limit))
   "Return the list of queued derivations on URL."
   (let ((queue
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 73595a216b..5f92174a2c 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -25,7 +25,6 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix derivations)
-  #:use-module (guix grafts)
   #:use-module (guix utils)
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
diff --git a/guix/git.scm b/guix/git.scm
index 10e6dcaf23..95630a5e69 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -272,12 +272,15 @@ corresponding Git object."
                   ;; There's no such tag, so it must be a commit ID.
                   (resolve `(commit . ,str)))))))
       (('tag    . tag)
-       (let ((oid (reference-name->oid repository
-                                       (string-append "refs/tags/" tag))))
-         ;; OID may point to a "tag" object, but it can also point directly
-         ;; to a "commit" object, as surprising as it may seem.  Return that
-         ;; object, whatever that is.
-         (object-lookup repository oid))))))
+       (let* ((oid (reference-name->oid repository
+                                        (string-append "refs/tags/" tag)))
+              (obj (object-lookup repository oid)))
+         ;; OID may designate an "annotated tag" object or a "commit" object.
+         ;; Return the commit object in both cases.
+         (if (= OBJ-TAG (object-type obj))
+             (object-lookup repository
+                            (tag-target-id (tag-lookup repository oid)))
+             obj))))))
 
 (define (switch-to-ref repository ref)
   "Switch to REPOSITORY's branch, commit or tag specified by REF.  Return the
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 0ffda8f9aa..1686aa1413 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +24,7 @@
   #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (guix sets)
+  #:use-module (guix gexp)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
@@ -39,12 +40,11 @@
             graft-replacement-output
 
             graft-derivation
-            graft-derivation/shallow
-
-            %graft?
-            without-grafting
-            set-grafting
-            grafting?))
+            graft-derivation/shallow)
+  #:re-export (%graft?                            ;for backward compatibility
+               without-grafting
+               set-grafting
+               grafting?))
 
 (define-record-type* <graft> graft make-graft
   graft?
@@ -79,7 +79,7 @@
     (($ <graft> (? string? item))
      item)))
 
-(define* (graft-derivation/shallow store drv grafts
+(define* (graft-derivation/shallow drv grafts
                                    #:key
                                    (name (derivation-name drv))
                                    (outputs (derivation-output-names drv))
@@ -88,72 +88,60 @@
   "Return a derivation called NAME, which applies GRAFTS to the specified
 OUTPUTS of DRV.  This procedure performs \"shallow\" grafting in that GRAFTS
 are not recursively applied to dependencies of DRV."
-  ;; XXX: Someday rewrite using gexps.
   (define mapping
     ;; List of store item pairs.
-    (map (match-lambda
-          (($ <graft> source source-output target target-output)
-           (cons (if (derivation? source)
-                     (derivation->output-path source source-output)
-                     source)
-                 (if (derivation? target)
-                     (derivation->output-path target target-output)
-                     target))))
+    (map (lambda (graft)
+           (gexp
+            ((ungexp (graft-origin graft)
+                     (graft-origin-output graft))
+             . (ungexp (graft-replacement graft)
+                       (graft-replacement-output graft)))))
          grafts))
 
-  (define output-pairs
-    (map (lambda (output)
-           (cons output
-                 (derivation-output-path
-                  (assoc-ref (derivation-outputs drv) output))))
-         outputs))
-
   (define build
-    `(begin
-       (use-modules (guix build graft)
-                    (guix build utils)
-                    (ice-9 match))
-
-       (let* ((old-outputs ',output-pairs)
-              (mapping (append ',mapping
-                               (map (match-lambda
-                                      ((name . file)
-                                       (cons (assoc-ref old-outputs name)
-                                             file)))
-                                    %outputs))))
-         (graft old-outputs %outputs mapping))))
-
-  (define add-label
-    (cut cons "x" <>))
+    (with-imported-modules '((guix build graft)
+                             (guix build utils)
+                             (guix build debug-link)
+                             (guix elf))
+      #~(begin
+          (use-modules (guix build graft)
+                       (guix build utils)
+                       (ice-9 match))
+
+          (define %outputs
+            (ungexp (outputs->gexp outputs)))
+
+          (let* ((old-outputs '(ungexp
+                                (map (lambda (output)
+                                       (gexp ((ungexp output)
+                                              . (ungexp drv output))))
+                                     outputs)))
+                 (mapping (append '(ungexp mapping)
+                                  (map (match-lambda
+                                         ((name . file)
+                                          (cons (assoc-ref old-outputs name)
+                                                file)))
+                                       %outputs))))
+            (graft old-outputs %outputs mapping)))))
+
 
   (define properties
     `((type . graft)
       (graft (count . ,(length grafts)))))
 
-  (match grafts
-    ((($ <graft> sources source-outputs targets target-outputs) ...)
-     (let ((sources (zip sources source-outputs))
-           (targets (zip targets target-outputs)))
-       (build-expression->derivation store name build
-                                     #:system system
-                                     #:guile-for-build guile
-                                     #:modules '((guix build graft)
-                                                 (guix build utils)
-                                                 (guix build debug-link)
-                                                 (guix elf))
-                                     #:inputs `(,@(map (lambda (out)
-                                                         `("x" ,drv ,out))
-                                                       outputs)
-                                                ,@(append (map add-label sources)
-                                                          (map add-label targets)))
-                                     #:outputs outputs
-
-                                     ;; Grafts are computationally cheap so no
-                                     ;; need to offload or substitute.
-                                     #:local-build? #t
-                                     #:substitutable? #f
-
-                                     #:properties properties)))))
+  (gexp->derivation name build
+                    #:system system
+                    #:guile-for-build guile
+
+                    ;; Grafts are computationally cheap so no
+                    ;; need to offload or substitute.
+                    #:local-build? #t
+                    #:substitutable? #f
+
+                    #:properties properties))
+
+(define graft-derivation/shallow*
+  (store-lower graft-derivation/shallow))
 
 (define (non-self-references store drv outputs)
   "Return the list of references of the OUTPUTS of DRV, excluding self
@@ -292,10 +280,10 @@ derivations to the corresponding set of grafts."
               ;; Use APPLICABLE, the subset of GRAFTS that is really
               ;; applicable to DRV, to avoid creating several identical
               ;; grafted variants of DRV.
-              (let* ((new    (graft-derivation/shallow store drv applicable
-                                                       #:outputs outputs
-                                                       #:guile guile
-                                                       #:system system))
+              (let* ((new    (graft-derivation/shallow* store drv applicable
+                                                        #:outputs outputs
+                                                        #:guile guile
+                                                        #:system system))
                      (grafts (append (map (lambda (output)
                                             (graft
                                               (origin drv)
@@ -334,36 +322,6 @@ DRV, and graft DRV itself to refer to those grafted dependencies."
            (graft-replacement first)
            drv)))))
 
-
-;; The following might feel more at home in (guix packages) but since (guix
-;; gexp), which is a lower level, needs them, we put them here.
-
-(define %graft?
-  ;; Whether to honor package grafts by default.
-  (make-parameter #t))
-
-(define (call-without-grafting thunk)
-  (lambda (store)
-    (values (parameterize ((%graft? #f))
-              (run-with-store store (thunk)))
-            store)))
-
-(define-syntax-rule (without-grafting mexp ...)
-  "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is
-false."
-  (call-without-grafting (lambda () (mbegin %store-monad mexp ...))))
-
-(define-inlinable (set-grafting enable?)
-  ;; This monadic procedure enables grafting when ENABLE? is true, and
-  ;; disables it otherwise.  It returns the previous setting.
-  (lambda (store)
-    (values (%graft? enable?) store)))
-
-(define-inlinable (grafting?)
-  ;; Return a Boolean indicating whether grafting is enabled.
-  (lambda (store)
-    (values (%graft?) store)))
-
 ;; Local Variables:
 ;; eval: (put 'with-cache 'scheme-indent-function 1)
 ;; End:
diff --git a/guix/inferior.scm b/guix/inferior.scm
index cbb3c0a36e..2fe34ca0dc 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -835,7 +835,7 @@ prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
         (branch (channel-branch channel)))
     (if (and commit (commit-id? commit))
         commit
-        (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
+        (let* ((ref (if commit `(tag-or-commit . ,commit) `(branch . ,branch)))
                (cache commit relation
                      (update-cached-checkout (channel-url channel)
                                              #:ref ref
diff --git a/guix/lint.scm b/guix/lint.scm
index 7ee3a3122f..8e3976171f 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -34,6 +34,7 @@
   #:use-module (guix store)
   #:autoload   (guix base16) (bytevector->base16-string)
   #:use-module (guix base32)
+  #:autoload   (guix base64) (base64-encode)
   #:use-module (guix build-system)
   #:use-module (guix diagnostics)
   #:use-module (guix download)
@@ -46,7 +47,6 @@
                                 gexp->approximate-sexp))
   #:use-module (guix licenses)
   #:use-module (guix records)
-  #:use-module (guix grafts)
   #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (guix memoization)
@@ -59,10 +59,20 @@
   #:use-module ((guix swh) #:hide (origin?))
   #:autoload   (guix git-download) (git-reference?
                                     git-reference-url git-reference-commit)
+  #:autoload   (guix svn-download) (svn-reference?
+                                    svn-reference-url
+                                    svn-reference-user-name
+                                    svn-reference-password
+
+                                    svn-multi-reference?
+                                    svn-multi-reference-url
+                                    svn-multi-reference-user-name
+                                    svn-multi-reference-password)
   #:use-module (guix import stackage)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
+  #:autoload   (rnrs bytevectors) (string->utf8)
   #:use-module (web client)
   #:use-module (web uri)
   #:use-module ((guix build download)
@@ -721,8 +731,14 @@ response from URI, and additional details, such as the actual HTTP response.
 TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
 for connections to complete; when TIMEOUT is #f, wait as long as needed."
   (define headers
-    '((User-Agent . "GNU Guile")
-      (Accept . "*/*")))
+    `((User-Agent . "GNU Guile")
+      (Accept . "*/*")
+      ,@(match (uri-userinfo uri)
+          ((? string? str)                        ;"basic authentication"
+           `((Authorization . ,(string-append "Basic "
+                                              (base64-encode
+                                               (string->utf8 str))))))
+          (_ '()))))
 
   (let loop ((uri     uri)
              (visited '()))
@@ -1130,6 +1146,40 @@ descriptions maintained upstream."
     ((uris ...)
      uris)))
 
+(define (svn-reference-uri-with-userinfo ref)
+  "Return the URI of REF, an <svn-reference> or <svn-multi-reference> object,
+but with an additional 'userinfo' part corresponding to REF's user name and
+password, provided REF's URI is HTTP or HTTPS."
+  ;; XXX: For lack of record type inheritance.
+  (define ->url
+    (if (svn-reference? ref)
+        svn-reference-url
+        svn-multi-reference-url))
+  (define ->user-name
+    (if (svn-reference? ref)
+        svn-reference-user-name
+        svn-multi-reference-user-name))
+  (define ->password
+    (if (svn-reference? ref)
+        svn-reference-password
+        svn-multi-reference-password))
+
+  (let ((uri (string->uri (->url ref))))
+    (if (and (->user-name ref)
+             (memq (uri-scheme uri) '(http https)))
+        (build-uri (uri-scheme uri)
+                   #:userinfo
+                   (string-append (->user-name ref)
+                                  (if (->password ref)
+                                      (string-append
+                                       ":" (->password ref))
+                                      ""))
+                   #:host (uri-host uri)
+                   #:port (uri-port uri)
+                   #:query (uri-query uri)
+                   #:fragment (uri-fragment uri))
+        uri)))
+
 (define (check-source package)
   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 'source' is not reachable."
@@ -1175,6 +1225,12 @@ descriptions maintained upstream."
          ((git-reference? (origin-uri origin))
           (warnings-for-uris
            (list (string->uri (git-reference-url (origin-uri origin))))))
+         ((or (svn-reference? (origin-uri origin))
+              (svn-multi-reference? (origin-uri origin)))
+          (let ((uri (svn-reference-uri-with-userinfo (origin-uri origin))))
+            (if (memq (uri-scheme uri) '(http https))
+                (warnings-for-uris (list uri))
+                '())))                            ;TODO: handle svn:// URLs
          (else
           '()))
         '())))
diff --git a/guix/read-print.scm b/guix/read-print.scm
index a9aa57a476..a6aaa149e4 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -286,6 +286,8 @@ expressions and blanks that were read."
    ('define-syntax-rule 2)
    ('define-module 2)
    ('define-gexp-compiler 2)
+   ('define-record-type 2)
+   ('define-record-type* 4)
    ('let 2)
    ('let* 2)
    ('letrec 2)
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 3aabaf5c9c..4de8bc23b3 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -22,7 +22,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix scripts)
-  #:use-module (guix grafts)
   #:use-module (guix utils)
   #:use-module (guix ui)
   #:use-module (guix store)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 1e961c84e6..3b2bdee835 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -26,7 +26,6 @@
                 #:select (fold-archive restore-file))
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
-  #:use-module (guix grafts)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix monads)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 0787dfcc9a..b4437172d7 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -28,10 +28,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix memoization)
-  #:use-module (guix grafts)
-
   #:use-module (guix utils)
-
   #:use-module (guix monads)
   #:use-module (guix gexp)
   #:use-module (guix profiles)
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index f1e5f67dab..620a1762a1 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -22,7 +22,6 @@
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:use-module (guix grafts)
   #:use-module (guix monads)
   #:use-module (guix base32)
   #:use-module (guix packages)
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 40a9374171..ef6f9acc86 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -27,7 +27,6 @@
   #:use-module (guix gexp)
   #:use-module (guix ui)
   #:use-module (guix utils)
-  #:use-module (guix grafts)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index afe255fa4a..de9bc8f98d 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -24,7 +24,6 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module ((guix status) #:select (with-status-verbosity))
-  #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
@@ -448,11 +447,11 @@ and suitable for 'exit'."
 (define* (launch-environment command profile manifest
                              #:key pure? (white-list '())
                              emulate-fhs?)
-  "Run COMMAND in a new environment containing INPUTS, using the native search
-paths defined by the list PATHS.  When PURE?, pre-existing environment
-variables are cleared before setting the new ones, except those matching the
-regexps in WHITE-LIST.  When EMULATE-FHS?, first set up an FHS environment
-with $PATH and generate the LD cache."
+  "Load the environment of PROFILE, which corresponds to MANIFEST, and execute
+COMMAND.  When PURE?, pre-existing environment variables are cleared before
+setting the new ones, except those matching the regexps in WHITE-LIST.  When
+EMULATE-FHS?, first set up an FHS environment with $PATH and generate the LD
+cache."
   ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
   ;; application works.
   (sigaction SIGINT SIG_DFL)
@@ -1016,9 +1015,9 @@ command-line option processing with 'parse-command-line'."
       (when (and (not container?) user)
         (leave (G_ "'--user' cannot be used without '--container'~%")))
       (when (and (not container?) no-cwd?)
-        (leave (G_ "--no-cwd cannot be used without --container~%")))
+        (leave (G_ "--no-cwd cannot be used without '--container'~%")))
       (when (and (not container?) emulate-fhs?)
-        (leave (G_ "'--emulate-fhs' cannot be used without '--container~'%")))
+        (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
 
 
       (with-store/maybe store
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 4add7e7c69..754001a5b8 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -47,7 +47,6 @@
   #:use-module (guix derivations)
   #:use-module (guix ui)
   #:autoload   (guix colors) (supports-hyperlinks? file-hyperlink)
-  #:use-module (guix grafts)
   #:use-module (guix packages)
   #:use-module (guix profiles)
   #:use-module (guix store)
@@ -476,7 +475,7 @@ resulting from command-line parsing."
   (define (ensure-home-environment file-or-exp obj)
     (ensure-profile-directory)
     (unless (home-environment? obj)
-      (leave (G_ "'~a' does not return a home environment ~%")
+      (leave (G_ "'~a' does not return a home environment~%")
              file-or-exp))
     obj)
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 78b6978c92..06849e4761 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -33,7 +33,6 @@
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module ((guix self) #:select (make-config.scm))
-  #:use-module (guix grafts)
   #:autoload   (guix inferior) (inferior-package?
                                 inferior-package-name
                                 inferior-package-version)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7ba2661bbb..b9090307ac 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -33,7 +33,6 @@
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module ((guix build syscalls) #:select (terminal-rows))
   #:use-module (guix store)
-  #:use-module (guix grafts)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 19224cf70b..7b6c58dbc3 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -31,7 +31,6 @@
   #:use-module (guix derivations)
   #:use-module (guix profiles)
   #:use-module (guix gexp)
-  #:use-module (guix grafts)
   #:use-module (guix memoization)
   #:use-module (guix monads)
   #:use-module (guix channels)
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index 5bb970443c..48b8ecc881 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -24,7 +24,6 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix combinators)
-  #:use-module (guix grafts)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (gnu packages)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 560f56408c..6482318168 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -38,7 +38,6 @@
                (sqlite-register store-database-file call-with-database)
   #:autoload   (guix build store-copy) (copy-store-item)
   #:use-module (guix describe)
-  #:use-module (guix grafts)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
   #:use-module (guix diagnostics)
@@ -1046,7 +1045,7 @@ Some ACTIONS support additional ARGS.\n"))
   (newline)
   (display (G_ "
       --graph-backend=BACKEND
-                         use BACKEND for 'extension-graphs' and 'shepherd-graph'"))
+                         use BACKEND for 'extension-graph' and 'shepherd-graph'"))
   (newline)
   (display (G_ "
   -I, --list-installed[=REGEXP]
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index f46c11b1a5..dc27f81984 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -29,7 +29,6 @@
   #:use-module (guix progress)
   #:use-module (guix monads)
   #:use-module (guix store)
-  #:use-module (guix grafts)
   #:use-module (guix gexp)
   #:use-module (guix colors)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
diff --git a/guix/self.scm b/guix/self.scm
index fc80e78804..f46a09be52 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -62,7 +62,7 @@
       ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib))
       ("guile-zstd" (ref '(gnu packages guile) 'guile-zstd))
       ("guile-gcrypt"  (ref '(gnu packages gnupg) 'guile-gcrypt))
-      ("gnutls"     (ref '(gnu packages tls) 'gnutls))
+      ("guile-gnutls"  (ref '(gnu packages tls) 'guile-gnutls))
       ("disarchive" (ref '(gnu packages backup) 'disarchive))
       ("guile-lzma" (ref '(gnu packages guile) 'guile-lzma))
       ("gzip"       (ref '(gnu packages compression) 'gzip))
@@ -787,8 +787,8 @@ itself."
   (define guile-semver
     (specification->package "guile-semver"))
 
-  (define gnutls
-    (specification->package "gnutls"))
+  (define guile-gnutls
+    (specification->package "guile-gnutls"))
 
   (define disarchive
     (specification->package "disarchive"))
@@ -798,7 +798,7 @@ itself."
 
   (define dependencies
     (append-map transitive-package-dependencies
-                (list guile-gcrypt gnutls guile-git guile-avahi
+                (list guile-gcrypt guile-gnutls guile-git guile-avahi
                       guile-json guile-semver guile-ssh guile-sqlite3
                       guile-lib guile-zlib guile-lzlib guile-zstd)))
 
diff --git a/guix/store.scm b/guix/store.scm
index 4d21c5ff1a..a36dce416e 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -182,6 +182,11 @@
             interned-file
             interned-file-tree
 
+            %graft?
+            without-grafting
+            set-grafting
+            grafting?
+
             %store-prefix
             store-path
             output-path
@@ -2173,6 +2178,37 @@ connection, and return the result."
 
 
 ;;;
+;;; Whether to enable grafts.
+;;;
+
+(define %graft?
+  ;; Whether to honor package grafts by default.
+  (make-parameter #t))
+
+(define (call-without-grafting thunk)
+  (lambda (store)
+    (values (parameterize ((%graft? #f))
+              (run-with-store store (thunk)))
+            store)))
+
+(define-syntax-rule (without-grafting mexp ...)
+  "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is
+false."
+  (call-without-grafting (lambda () (mbegin %store-monad mexp ...))))
+
+(define-inlinable (set-grafting enable?)
+  ;; This monadic procedure enables grafting when ENABLE? is true, and
+  ;; disables it otherwise.  It returns the previous setting.
+  (lambda (store)
+    (values (%graft? enable?) store)))
+
+(define-inlinable (grafting?)
+  ;; Return a Boolean indicating whether grafting is enabled.
+  (lambda (store)
+    (values (%graft?) store)))
+
+
+;;;
 ;;; Store paths.
 ;;;
 
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 55ce0d7351..e0a26b73ee 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, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2016, 2019, 2021-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;;
@@ -34,6 +34,8 @@
             svn-reference-url
             svn-reference-revision
             svn-reference-recursive?
+            svn-reference-user-name
+            svn-reference-password
             svn-fetch
             download-svn-to-store
 
@@ -43,6 +45,8 @@
             svn-multi-reference-revision
             svn-multi-reference-locations
             svn-multi-reference-recursive?
+            svn-multi-reference-user-name
+            svn-multi-reference-password
             svn-multi-fetch
             download-multi-svn-to-store))
 
@@ -79,17 +83,42 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
     (with-imported-modules '((guix build svn)
                              (guix build utils))
       #~(begin
-          (use-modules (guix build svn))
-          (svn-fetch '#$(svn-reference-url ref)
-                     '#$(svn-reference-revision ref)
+          (use-modules (guix build svn)
+                       (ice-9 match))
+
+          (svn-fetch (getenv "svn url")
+                     (string->number (getenv "svn revision"))
                      #$output
-                     #:svn-command (string-append #+svn "/bin/svn")
-                     #:recursive? #$(svn-reference-recursive? ref)
-                     #:user-name #$(svn-reference-user-name ref)
-                     #:password #$(svn-reference-password ref)))))
+                     #:svn-command #+(file-append svn "/bin/svn")
+                     #:recursive? (match (getenv "svn recursive?")
+                                    ("yes" #t)
+                                    (_ #f))
+                     #:user-name (getenv "svn user name")
+                     #:password (getenv "svn password")))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "svn-checkout") build
+
+                      ;; Use environment variables and a fixed script name so
+                      ;; there's only one script in store for all the
+                      ;; downloads.
+                      #:script-name "svn-download"
+                      #:env-vars
+                      `(("svn url" . ,(svn-reference-url ref))
+                        ("svn revision"
+                         . ,(number->string (svn-reference-revision ref)))
+                        ,@(if (svn-reference-recursive? ref)
+                              `(("svn recursive?" . "yes"))
+                              '())
+                        ,@(if (svn-reference-user-name ref)
+                              `(("svn user name"
+                                 . ,(svn-reference-user-name ref)))
+                              '())
+                        ,@(if (svn-reference-password ref)
+                              `(("svn password"
+                                 . ,(svn-reference-password ref)))
+                              '()))
+
                       #:system system
                       #:hash-algo hash-algo
                       #:hash hash
@@ -120,27 +149,53 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
       #~(begin
           (use-modules (guix build svn)
                        (guix build utils)
-                       (srfi srfi-1))
-          (every (lambda (location)
-                   ;; The directory must exist if we are to fetch only a
-                   ;; single file.
-                   (unless (string-suffix? "/" location)
-                     (mkdir-p (string-append #$output "/" (dirname location))))
-                   (svn-fetch (string-append '#$(svn-multi-reference-url ref)
-                                             "/" location)
-                              '#$(svn-multi-reference-revision ref)
-                              (if (string-suffix? "/" location)
-                                  (string-append #$output "/" location)
-                                  (string-append #$output "/" (dirname location)))
-                              #:svn-command (string-append #+svn "/bin/svn")
-                              #:recursive?
-                              #$(svn-multi-reference-recursive? ref)
-                              #:user-name #$(svn-multi-reference-user-name ref)
-                              #:password #$(svn-multi-reference-password ref)))
-                 '#$(sexp->gexp (svn-multi-reference-locations ref))))))
+                       (srfi srfi-1)
+                       (ice-9 match))
+
+          (for-each (lambda (location)
+                      ;; The directory must exist if we are to fetch only a
+                      ;; single file.
+                      (unless (string-suffix? "/" location)
+                        (mkdir-p (string-append #$output "/" (dirname location))))
+                      (svn-fetch (string-append (getenv "svn url") "/" location)
+                                 (string->number (getenv "svn revision"))
+                                 (if (string-suffix? "/" location)
+                                     (string-append #$output "/" location)
+                                     (string-append #$output "/" (dirname location)))
+                                 #:svn-command #+(file-append svn "/bin/svn")
+                                 #:recursive? (match (getenv "svn recursive?")
+                                                ("yes" #t)
+                                                (_ #f))
+                                 #:user-name (getenv "svn user name")
+                                 #:password (getenv "svn password")))
+                    (call-with-input-string (getenv "svn locations")
+                      read)))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "svn-checkout") build
+
+                      ;; Use environment variables and a fixed script name so
+                      ;; there's only one script in store for all the
+                      ;; downloads.
+                      #:script-name "svn-multi-download"
+                      #:env-vars
+                      `(("svn url" . ,(svn-multi-reference-url ref))
+                        ("svn locations"
+                         . ,(object->string (svn-multi-reference-locations ref)))
+                        ("svn revision"
+                         . ,(number->string (svn-multi-reference-revision ref)))
+                        ,@(if (svn-multi-reference-recursive? ref)
+                              `(("svn recursive?" . "yes"))
+                              '())
+                        ,@(if (svn-multi-reference-user-name ref)
+                              `(("svn user name"
+                                 . ,(svn-multi-reference-user-name ref)))
+                              '())
+                        ,@(if (svn-multi-reference-password ref)
+                              `(("svn password"
+                                 . ,(svn-multi-reference-password ref)))
+                              '()))
+
                       #:leaked-env-vars '("http_proxy" "https_proxy"
                                           "LC_ALL" "LC_MESSAGES" "LANG"
                                           "COLUMNS")