Merge branch 'master' into core-updates-frozen

11 files changed, 287 insertions, 134 deletions

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index f043e6a7a2..a0f4634db0 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -151,7 +151,8 @@ set up using CL source package conventions."
         name))
 
   (define (has-from-build-system? pkg)
-    (eq? from-build-system (package-build-system pkg)))
+    (and (package? pkg)
+         (eq? from-build-system (package-build-system pkg))))
 
   (define (find-input-package pkg)
     (let* ((name (package-name pkg))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 15b2ea6ff3..45f95c509d 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -71,6 +71,11 @@
             mounts
             mount-points
 
+            SWAP_FLAG_PREFER
+            SWAP_FLAG_PRIO_MASK
+            SWAP_FLAG_PRIO_SHIFT
+            SWAP_FLAG_DISCARD
+
             swapon
             swapoff
 
@@ -687,6 +692,13 @@ current process."
   "Return the mounts points for currently mounted file systems."
   (map mount-point (mounts)))
 
+;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h
+
+(define SWAP_FLAG_PREFER     #x8000) ;; Set if swap priority is specified.
+(define SWAP_FLAG_PRIO_MASK  #x7fff)
+(define SWAP_FLAG_PRIO_SHIFT 0)
+(define SWAP_FLAG_DISCARD    #x10000) ;; Discard swap cluster after use.
+
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
     (lambda* (device #:optional (flags 0))
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 6a792febd4..337a73c1a2 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -54,7 +54,9 @@
             condition-fix-hint
 
             guix-warning-port
-            program-name))
+            program-name
+
+            define-with-syntax-properties))
 
 ;;; Commentary:
 ;;;
@@ -331,3 +333,37 @@ number of arguments in ARGS matches the escapes in FORMAT."
 (define program-name
   ;; Name of the command-line program currently executing, or #f.
   (make-parameter #f))
+
+
+(define-syntax define-with-syntax-properties
+  (lambda (x)
+    "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and
+SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties,
+respectively, of each ensuing syntax object."
+    (syntax-case x ()
+      ((_ (binding (value-identifier syntax-properties-identifier)
+                   ...)
+          body ...)
+       (and (and-map identifier? #'(value-identifier ...))
+            (and-map identifier? #'(syntax-properties-identifier ...)))
+       #'(define-syntax binding
+           (lambda (y)
+             (with-ellipsis :::
+               (syntax-case y ()
+                 ((_ value-identifier ...)
+                  (with-syntax ((syntax-properties-identifier
+                                 #`'#,(datum->syntax y
+                                                     (syntax-source
+                                                      #'value-identifier)))
+                                ...)
+                    #'(begin body ...)))
+                 (_
+                  (syntax-violation #f (format #f
+                                               "Expected (~a~{ ~a~})"
+                                               'binding
+                                               '(value-identifier ...))
+                                    y)))))))
+      (_
+       (syntax-violation #f "Expected a definition of the form \
+(define-with-syntax-properties (binding (value syntax-properties) \
+...) body ...)" x)))))
diff --git a/guix/docker.scm b/guix/docker.scm
index a6f73d423c..5e6460f43f 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -214,10 +214,11 @@ SRFI-19 time-utc object, as the creation time in metadata."
                                             (else
                                              (error "unsupported system"
                                                     system)))))))
-                 (cond* ("x86_64" "amd64")
-                        ("i686"   "386")
-                        ("arm"    "arm")
-                        ("mips64" "mips64le")))))
+                 (cond* ("x86_64"  "amd64")
+                        ("i686"    "386")
+                        ("arm"     "arm")
+                        ("aarch64" "arm64")
+                        ("mips64"  "mips64le")))))
     ;; Make sure we start with a fresh, empty working directory.
     (mkdir directory)
     (with-directory-excursion directory
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
index 5fae24b325..088bebc0de 100644
--- a/guix/gnupg.scm
+++ b/guix/gnupg.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,9 +57,9 @@
                                  "/gpg/trustedkeys.kbx")))
 
 (define %openpgp-key-server
-  ;; The default key server.  Note that keys.gnupg.net appears to be
-  ;; unreliable.
-  (make-parameter "pool.sks-keyservers.net"))
+  ;; The default key server.  It defaults to #f, which causes GnuPG to use the
+  ;; one it is configured with.
+  (make-parameter #f))
 
 ;; Regexps for status lines.  See file `doc/DETAILS' in GnuPG.
 
@@ -182,22 +183,26 @@ missing key or its key id if the fingerprint is unavailable."
            (_ #f)))
        status))
 
-(define* (gnupg-receive-keys fingerprint/key-id server
-                             #:optional (keyring (current-keyring)))
-  "Download FINGERPRINT/KEY-ID from SERVER, a key server, and add it to
-KEYRING."
+(define* (gnupg-receive-keys fingerprint/key-id
+                             #:key server (keyring (current-keyring)))
+  "Download FINGERPRINT/KEY-ID from SERVER if specified, otherwise from
+GnuPG's default/configured one.  The key is added to KEYRING."
   (unless (file-exists? keyring)
     (mkdir-p (dirname keyring))
-    (call-with-output-file keyring (const #t)))   ;create an empty keybox
+    (call-with-output-file keyring (const #t))) ;create an empty keybox
 
-  (zero? (system* (%gpg-command) "--keyserver" server
-                  "--no-default-keyring" "--keyring" keyring
-                  "--recv-keys" fingerprint/key-id)))
+  (zero? (apply system*
+                `(,(%gpg-command)
+                  ,@(if server
+                        (list "--keyserver" server)
+                        '())
+                  "--no-default-keyring" "--keyring" ,keyring
+                  "--recv-keys" ,fingerprint/key-id))))
 
 (define* (gnupg-verify* sig file
                         #:key
                         (key-download 'interactive)
-                        (server (%openpgp-key-server))
+                        server
                         (keyring (current-keyring)))
   "Like `gnupg-verify', but try downloading the public key if it's missing.
 Return two values: 'valid-signature and a fingerprint/name pair upon success,
@@ -215,7 +220,7 @@ fingerprint/user name pair on success and #f otherwise."
        (let ((missing (gnupg-status-missing-key? status)))
          (define (download-and-try-again)
            ;; Download the missing key and try again.
-           (if (gnupg-receive-keys missing server keyring)
+           (if (gnupg-receive-keys missing #:server server #:keyring keyring)
                (match (gnupg-status-good-signature?
                        (gnupg-verify sig file keyring))
                  (#f
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index f8402ff5ba..d9fdf4527a 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -231,7 +231,8 @@ path to the repository."
                  (('list-pat . stuff) stuff)
                  (('string-pat stuff) stuff)
                  (('multiline-string stuff) stuff)
-                 (('dict records ...) records))
+                 (('dict records ...) records)
+                 (_ #f))
                acc))))
         #f file))
 
@@ -317,7 +318,7 @@ path to the repository."
                 (_ others)))
             #f
             (filter-map get-opam-repository repositories-specs))
-      (leave (G_ "package '~a' not found~%") name)))
+      (warning (G_ "opam: package '~a' not found~%") name)))
 
 (define* (opam->guix-package name #:key (repo 'opam) version)
   "Import OPAM package NAME from REPOSITORY (a directory name) or, if
diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index 18d8b95ee0..bdef9f58b0 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -19,18 +19,16 @@
 
 (define-module (guix import texlive)
   #:use-module (ice-9 match)
-  #:use-module (sxml simple)
-  #:use-module (sxml xpath)
-  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-34)
-  #:use-module (web uri)
-  #:use-module (guix diagnostics)
-  #:use-module (guix i18n)
-  #:use-module (guix http-client)
   #:use-module (gcrypt hash)
+  #:use-module (guix derivations)
   #:use-module (guix memoization)
+  #:use-module (guix monads)
+  #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix serialization)
@@ -39,24 +37,15 @@
   #:use-module (guix utils)
   #:use-module (guix upstream)
   #:use-module (guix packages)
-  #:use-module (gnu packages)
   #:use-module (guix build-system texlive)
   #:export (texlive->guix-package
-
-            fetch-sxml
-            sxml->package))
+            texlive-recursive-import))
 
 ;;; Commentary:
 ;;;
-;;; Generate a package declaration template for the latest version of a
-;;; package on CTAN, using the XML output produced by the XML API to the CTAN
-;;; database at http://www.ctan.org/xml/1.2/
-;;;
-;;; Instead of taking the packages from CTAN, however, we fetch the sources
-;;; from the SVN repository of the Texlive project.  We do this because CTAN
-;;; only keeps a single version of each package whereas we can access any
-;;; version via SVN.  Unfortunately, this means that the importer is really
-;;; just a Texlive importer, not a generic CTAN importer.
+;;; Generate a package declaration template for corresponding package in the
+;;; Tex Live Package Database (tlpdb).  We fetch all sources from different
+;;; locations in the SVN repository of the Texlive project.
 ;;;
 ;;; Code:
 
@@ -79,6 +68,8 @@
     ("bsd4" 'bsd-4)
     ("opl" 'opl1.0+)
     ("ofl" 'silofl1.1)
+
+    ("lpplgpl" `(list lppl gpl1+))
     ("lppl" 'lppl)
     ("lppl1" 'lppl1.0+) ; usually means "or later"
     ("lppl1.2" 'lppl1.2+) ; usually means "or later"
@@ -107,91 +98,170 @@
     ("cc-by-nc-nd-4" 'non-free)
     ((x) (string->license x))
     ((lst ...) `(list ,@(map string->license lst)))
-    (_ #f)))
-
-(define (fetch-sxml name)
-  "Return an sxml representation of the package information contained in the
-XML description of the CTAN package or #f in case of failure."
-  ;; This API always returns the latest release of the module.
-  (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name)))
-    (guard (c ((http-get-error? c)
-               (format (current-error-port)
-                       "error: failed to retrieve package information \
-from ~s: ~a (~s)~%"
-                       (uri->string (http-get-error-uri c))
-                       (http-get-error-code c)
-                       (http-get-error-reason c))
-               #f))
-      (xml->sxml (http-fetch url)
-                 #:trim-whitespace? #t))))
-
-(define (guix-name component name)
+    (x `(error unknown-license ,x))))
+
+(define (guix-name name)
   "Return a Guix package name for a given Texlive package NAME."
-  (string-append "texlive-" component "-"
+  (string-append "texlive-"
                  (string-map (match-lambda
                                (#\_ #\-)
                                (#\. #\-)
                                (chr (char-downcase chr)))
                              name)))
 
-(define* (sxml->package sxml #:optional (component "latex"))
-  "Return the `package' s-expression for a Texlive package from the SXML
-expression describing it."
-  (define (sxml-value path)
-    (match ((sxpath path) sxml)
-      (() #f)
-      ((val) val)))
+(define (tlpdb-file)
+  (define texlive-bin
+    ;; Resolve this variable lazily so that (gnu packages ...) does not end up
+    ;; in the closure of this module.
+    (module-ref (resolve-interface '(gnu packages tex))
+                'texlive-bin))
+
   (with-store store
-    (let* ((id         (sxml-value '(entry @ id *text*)))
-           (synopsis   (sxml-value '(entry caption *text*)))
-           (version    (or (sxml-value '(entry version @ number *text*))
-                           (sxml-value '(entry version @ date *text*))))
-           (license    (match ((sxpath '(entry license @ type *text*)) sxml)
-                         ((license) (string->license license))
-                         ((lst ...) (map string->license lst))))
-           (home-page  (string-append "http://www.ctan.org/pkg/" id))
-           (ref        (texlive-ref component id))
-           (checkout   (download-svn-to-store store ref)))
-      (unless checkout
-        (warning (G_ "Could not determine source location.  \
-Please manually specify the source field.~%")))
-      `(package
-         (name ,(guix-name component id))
-         (version ,version)
-         (source ,(if checkout
-                      `(origin
-                         (method svn-fetch)
-                         (uri (texlive-ref ,component ,id))
-                         (sha256
-                          (base32
-                           ,(bytevector->nix-base32-string
-                             (let-values (((port get-hash) (open-sha256-port)))
-                               (write-file checkout port)
-                               (force-output port)
-                               (get-hash))))))
-                      #f))
-         (build-system texlive-build-system)
-         (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/"))))
-         (home-page ,home-page)
-         (synopsis ,synopsis)
-         (description ,(string-trim-both
-                        (string-join
-                         (map string-trim-both
-                              (string-split
-                               (beautify-description
-                                (sxml->string (or (sxml-value '(entry description))
-                                                  '())))
-                               #\newline)))))
-         (license ,(match license
-                     ((lst ...) `(list ,@lst))
-                     (license license)))))))
+    (run-with-store store
+      (mlet* %store-monad
+          ((drv (lower-object texlive-bin))
+           (built (built-derivations (list drv))))
+        (match (derivation->output-paths drv)
+          (((names . items) ...)
+           (return (string-append (first items)
+                                  "/share/tlpkg/texlive.tlpdb"))))))))
+
+(define tlpdb
+  (memoize
+   (lambda ()
+     (let ((file (tlpdb-file))
+           (fields
+            '((name     . string)
+              (shortdesc . string)
+              (longdesc . string)
+              (catalogue-license . string)
+              (catalogue-ctan . string)
+              (srcfiles . list)
+              (runfiles . list)
+              (docfiles . list)
+              (depend   . simple-list)))
+           (record
+            (lambda* (key value alist #:optional (type 'string))
+              (let ((new
+                     (or (and=> (assoc-ref alist key)
+                                (lambda (existing)
+                                  (cond
+                                   ((eq? type 'string)
+                                    (string-append existing " " value))
+                                   ((or (eq? type 'list) (eq? type 'simple-list))
+                                    (cons value existing)))))
+                         (cond
+                          ((eq? type 'string)
+                           value)
+                          ((or (eq? type 'list) (eq? type 'simple-list))
+                           (list value))))))
+                (acons key new (alist-delete key alist))))))
+       (call-with-input-file file
+         (lambda (port)
+           (let loop ((all (list))
+                      (current (list))
+                      (last-property #false))
+             (let ((line (read-line port)))
+               (cond
+                ((eof-object? line) all)
+
+                ;; End of record.
+                ((string-null? line)
+                 (loop (cons (cons (assoc-ref current 'name) current)
+                             all)
+                       (list) #false))
+
+                ;; Continuation of a list
+                ((and (zero? (string-index line #\space)) last-property)
+                 ;; Erase optional second part of list values like
+                 ;; "details=Readme" for files
+                 (let ((plain-value (first
+                                     (string-split
+                                      (string-trim-both line) #\space))))
+                   (loop all (record last-property
+                                     plain-value
+                                     current
+                                     'list)
+                         last-property)))
+                (else
+                 (or (and-let* ((space (string-index line #\space))
+                                (key   (string->symbol (string-take line space)))
+                                (value (string-drop line (1+ space)))
+                                (field-type (assoc-ref fields key)))
+                       ;; Erase second part of list keys like "size=29"
+                       (cond
+                        ((eq? field-type 'list)
+                         (loop all current key))
+                        (else
+                         (loop all (record key value current field-type) key))))
+                     (loop all current #false))))))))))))
+
+(define (files->directories files)
+  (map (cut string-join <> "/" 'suffix)
+       (delete-duplicates (map (lambda (file)
+                                 (drop-right (string-split file #\/) 1))
+                               files)
+                          equal?)))
+
+(define (tlpdb->package name package-database)
+  (and-let* ((data (assoc-ref package-database name))
+             (dirs (files->directories
+                    (map (lambda (dir)
+                           (string-drop dir (string-length "texmf-dist/")))
+                         (append (or (assoc-ref data 'docfiles) (list))
+                                 (or (assoc-ref data 'runfiles) (list))
+                                 (or (assoc-ref data 'srcfiles) (list))))))
+             (name (guix-name name))
+             (version (number->string %texlive-revision))
+             (ref (svn-multi-reference
+                   (url (string-append "svn://www.tug.org/texlive/tags/"
+                                       %texlive-tag "/Master/texmf-dist"))
+                   (locations dirs)
+                   (revision %texlive-revision)))
+             (source (with-store store
+                       (download-multi-svn-to-store
+                        store ref (string-append name "-svn-multi-checkout")))))
+    (values
+     `(package
+        (inherit (simple-texlive-package
+                  ,name
+                  (list ,@dirs)
+                  (base32
+                   ,(bytevector->nix-base32-string
+                     (let-values (((port get-hash) (open-sha256-port)))
+                       (write-file source port)
+                       (force-output port)
+                       (get-hash))))
+                  ,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true))))
+        ,@(or (and=> (assoc-ref data 'depend)
+                     (lambda (inputs)
+                       `((propagated-inputs
+                          ,(map (lambda (tex-name)
+                                  (let ((name (guix-name tex-name)))
+                                    (list name (list 'unquote (string->symbol name)))))
+                                inputs)))))
+              '())
+        ,@(or (and=> (assoc-ref data 'catalogue-ctan)
+                     (lambda (url)
+                       `((home-page ,(string-append "https://ctan.org" url)))))
+              '((home-page "https://www.tug.org/texlive/")))
+        (synopsis ,(assoc-ref data 'shortdesc))
+        (description ,(beautify-description
+                       (assoc-ref data 'longdesc)))
+        (license ,(string->license
+                   (assoc-ref data 'catalogue-license))))
+     (or (assoc-ref data 'depend) (list)))))
 
 (define texlive->guix-package
   (memoize
-   (lambda* (package-name #:optional (component "latex"))
-     "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
+   (lambda* (name #:key repo version (package-database tlpdb))
+     "Find the metadata for NAME in the tlpdb and return the `package'
 s-expression corresponding to that package, or #f on failure."
-     (and=> (fetch-sxml package-name)
-            (cut sxml->package <> component)))))
+     (tlpdb->package name (package-database)))))
+
+(define (texlive-recursive-import name)
+  (recursive-import name
+                    #:repo->guix-package texlive->guix-package
+                    #:guix-name guix-name))
 
-;;; ctan.scm ends here
+;;; texlive.scm ends here
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 439fae0b52..8943e87099 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -542,7 +542,7 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
   (display (G_ "
       --list-types       list the available graph types"))
   (display (G_ "
-      --max-depth=DEPTH  limit to nodes within distance DEPTH"))
+  -M, --max-depth=DEPTH  limit to nodes within distance DEPTH"))
   (display (G_ "
       --path             display the shortest path between the given nodes"))
   (display (G_ "
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 3f48b98ed4..afc7d8b39c 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -274,7 +274,15 @@ argument list and OPTS is the option alist."
                            (_ (leave (G_ "wrong number of arguments~%"))))))
        (unless (file-exists? destination)
          (mkdir-p destination))
-       (import-manifest manifest destination (current-output-port))))
+       (call-with-output-file
+           (string-append destination "/home-configuration.scm")
+         (cut import-manifest manifest destination <>))
+       (info (G_ "'~a' populated with all the Home configuration files~%")
+             destination)
+       (display-hint (format #f (G_ "\
+Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively
+deploy the home environment described by these files.\n")
+                             destination))))
     ((describe)
      (match (generation-number %guix-home)
        (0
diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm
index 6f0818e274..4aeaa79eef 100644
--- a/guix/scripts/import/texlive.scm
+++ b/guix/scripts/import/texlive.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -43,8 +43,6 @@
   (display (G_ "Usage: guix import texlive PACKAGE-NAME
 Import and convert the Texlive package for PACKAGE-NAME.\n"))
   (display (G_ "
-  -a, --archive=ARCHIVE  specify the archive repository"))
-  (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
   -V, --version          display version information and exit"))
@@ -60,10 +58,6 @@ Import and convert the Texlive package for PACKAGE-NAME.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix import texlive")))
-         (option '(#\a "archive") #t #f
-                 (lambda (opt name arg result)
-                   (alist-cons 'component arg
-                               (alist-delete 'component result))))
          %standard-import-options))
 
 
@@ -84,13 +78,11 @@ Import and convert the Texlive package for PACKAGE-NAME.\n"))
                             (_ #f))
                            (reverse opts))))
     (match args
-      ((package-name)
-       (let ((sexp (texlive->guix-package package-name
-                                          (or (assoc-ref opts 'component)
-                                              "latex"))))
+      ((name)
+       (let ((sexp (texlive->guix-package name)))
          (unless sexp
            (leave (G_ "failed to download description for package '~a'~%")
-                  package-name))
+                  name))
          sexp))
       (()
        (leave (G_ "too few arguments~%")))
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 28ad49977b..55ce0d7351 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
-;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,7 +26,9 @@
   #:use-module (guix packages)
   #:use-module (guix utils)
   #:use-module ((guix build svn) #:prefix build:)
+  #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (svn-reference
             svn-reference?
             svn-reference-url
@@ -41,7 +43,8 @@
             svn-multi-reference-revision
             svn-multi-reference-locations
             svn-multi-reference-recursive?
-            svn-multi-fetch))
+            svn-multi-fetch
+            download-multi-svn-to-store))
 
 ;;; Commentary:
 ;;;
@@ -166,4 +169,28 @@ reports to LOG."
             (add-to-store store name #t "sha256"
                           (string-append temp "/svn")))))))
 
+(define* (download-multi-svn-to-store store ref
+                                      #:optional (name (basename (svn-multi-reference-url ref)))
+                                      #:key (log (current-error-port)))
+  "Download from REF, a <svn-multi-reference> object to STORE.  Write progress
+reports to LOG."
+  (call-with-temporary-directory
+   (lambda (temp)
+     (and (every (lambda (location)
+                   (let ((dir (string-append temp "/" (dirname location))))
+                     (mkdir-p dir))
+                   (parameterize ((current-output-port log))
+                     (build:svn-fetch (string-append (svn-multi-reference-url ref)
+                                                     "/" location)
+                                      (svn-multi-reference-revision ref)
+                                      (if (string-suffix? "/" location)
+                                          (string-append temp "/" location)
+                                          (string-append temp "/" (dirname location)))
+                                      #:recursive?
+                                      (svn-multi-reference-recursive? ref)
+                                      #:user-name (svn-multi-reference-user-name ref)
+                                      #:password (svn-multi-reference-password ref))))
+                 (svn-multi-reference-locations ref))
+          (add-to-store store name #t "sha256" temp)))))
+
 ;;; svn-download.scm ends here