summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/asdf.scm3
-rw-r--r--guix/build/syscalls.scm12
-rw-r--r--guix/diagnostics.scm38
-rw-r--r--guix/docker.scm9
-rw-r--r--guix/gnupg.scm31
-rw-r--r--guix/import/opam.scm5
-rw-r--r--guix/import/texlive.scm264
-rw-r--r--guix/scripts/graph.scm2
-rw-r--r--guix/scripts/home.scm10
-rw-r--r--guix/scripts/import/texlive.scm16
-rw-r--r--guix/svn-download.scm31
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