[bug#73921] [PATCH] svn-download: Add support for partial checkout.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* guix/svn-download.scm (<svn-reference>)
[subdirectories]: New field.
(svn-fetch): Set "svn subdirectories" environment variable when subdirectories
are provided.
(svn-fetch-builder): Pass subdirectories to svn-fetch.
* guix/build/svn.scm (svn-fetch) [subdirectories]: New keyword argument.
Implement alternative code path when it's provided.
* doc/guix.texi (svn-reference): Document the new field.

Change-Id: I21ca96bc48d26dafca82b26daccef0d324f79dc5
---

Note: At first I was planning to use this to checkout exactly one
subdirectory of a game data SVN repository, but later I realized SVN
allows for checking out any subdirectory, which made this addition
unnecessary.

I guess it could still be useful when wanting to select more than one
subdirectory, but the perhaps svn-multi-fetch could be used instead,
to combine multiple SVN checkouts into one (IIUC).

Anyway, I'm sending this to guix-devel; if anyone find it useful it
could be considered for guix-patches.

 doc/guix.texi         |  3 ++
 guix/build/svn.scm    | 74 ++++++++++++++++++++++++++++---------------
 guix/svn-download.scm | 20 +++++++++---
 3 files changed, 68 insertions(+), 29 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b9f71527a3..2d1e5bdd2c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8312,6 +8312,9 @@ origin Reference
 
 @item @code{password} (default: @code{#f})
 Password to access the Subversion repository, if required.
+
+@item @code{subdirectories} (default: @code{#f})
+Only recurse into subdirectories, resulting in a partial checkout.
 @end table
 @end deftp
 
diff --git a/guix/build/svn.scm b/guix/build/svn.scm
index 875d3c50ca..1b1c9b1b5c 100644
--- a/guix/build/svn.scm
+++ b/guix/build/svn.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,6 +22,9 @@
 
 (define-module (guix build svn)
   #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:export (svn-fetch))
 
@@ -33,35 +37,55 @@ (define-module (guix build svn)
 
 (define* (svn-fetch url revision directory
                     #:key (svn-command "svn")
-                    (recursive? #t)
-                    (user-name #f)
-                    (password #f))
+                    recursive?
+                    user-name
+                    password
+                    subdirectories)
   "Fetch REVISION from URL into DIRECTORY.  REVISION must be an integer, and a
-valid Subversion revision.  Return #t on success, #f otherwise."
+valid Subversion revision.  If SUBDIRECTORIES is provided, only these
+subdirectories will be fully fetched (partial checkout).  Return #t on
+success, #f otherwise."
+  (define base-options
+    `("--non-interactive"
+      ;; Trust the server certificate.  This is OK as we
+      ;; verify the checksum later.  This can be removed when
+      ;; ca-certificates package is added.
+      "--trust-server-cert"
+      "-r" ,(number->string revision)
+      ,@(if (and user-name password)
+            (list (string-append "--username=" user-name)
+                  (string-append "--password=" password))
+            '())
+      ,@(if recursive?
+            '()
+            (list "--ignore-externals"))))
+
   (guard (c ((invoke-error? c)
              (report-invoke-error c)
              #f))
-    (apply invoke svn-command
-           "export" "--non-interactive"
-           ;; Trust the server certificate.  This is OK as we
-           ;; verify the checksum later.  This can be removed when
-           ;; ca-certificates package is added.
-           "--trust-server-cert" "-r" (number->string revision)
-
-           ;; Disable keyword substitutions (keywords are CVS-like strings
-           ;; like "$Date$", "$Id$", and so on) for two reasons: (1) some
-           ;; expansions depend on the local time zone, and (2) SWH disables
-           ;; it in its archive for this very reason.
-           "--ignore-keywords"
-
-           `(,@(if (and user-name password)
-                   (list (string-append "--username=" user-name)
-                         (string-append "--password=" password))
-                   '())
-             ,@(if recursive?
-                   '()
-                   (list "--ignore-externals"))
-             ,url ,directory))
+    (match subdirectories
+      (#f
+       (apply invoke svn-command "export"
+              (append base-options
+                      `(;; Disable keyword substitutions (keywords are CVS-like strings
+                        ;; like "$Date$", "$Id$", and so on) for two reasons: (1) some
+                        ;; expansions depend on the local time zone, and (2) SWH disables
+                        ;; it in its archive for this very reason.
+                        "--ignore-keywords"
+                        ,url ,directory))))
+      (_
+       (apply invoke svn-command "checkout"
+              (append base-options
+                      `(,@(if subdirectories
+                              (list "--depth" "immediates")
+                              '())
+                        ,url ,directory)))
+       (with-directory-excursion directory
+         (apply invoke svn-command "update"
+                (append base-options
+                        (append-map (cut list "--set-depth" "infinity" <>)
+                                    subdirectories)))
+         (delete-file-recursively ".svn"))))
     #t))
 
 ;;; svn.scm ends here
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index b20cdc79d1..e263498f30 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014-2016, 2019, 2021-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,6 +36,7 @@ (define-module (guix svn-download)
             svn-reference?
             svn-reference-url
             svn-reference-revision
+            svn-reference-subdirectories
             svn-reference-recursive?
             svn-reference-user-name
             svn-reference-password
@@ -65,6 +67,8 @@ (define-record-type* <svn-reference>
   svn-reference?
   (url        svn-reference-url)                    ; string
   (revision   svn-reference-revision)               ; number
+  (subdirectories svn-reference-subdirectories      ;list or #f
+                  (default #f))
   (recursive? svn-reference-recursive? (default #f))
   (user-name  svn-reference-user-name (default #f))
   (password   svn-reference-password (default #f)))
@@ -84,7 +88,7 @@ (define (svn-fetch-builder svn hash-algo)
   (define guile-gnutls
     (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls))
 
-  (define tar+gzip                                ;for (guix swh)
+  (define tar+gzip                      ;for (guix swh)
     (list (module-ref (resolve-interface '(gnu packages compression))
                       'gzip)
           (module-ref (resolve-interface '(gnu packages base))
@@ -96,7 +100,7 @@ (define (svn-fetch-builder svn hash-algo)
                                (guix build download-nar)
                                (guix build utils)
                                (guix swh)))
-    (with-extensions (list guile-json guile-gnutls   ;for (guix swh)
+    (with-extensions (list guile-json guile-gnutls ;for (guix swh)
                            guile-lzlib)
       #~(begin
           (use-modules (guix build svn)
@@ -105,7 +109,8 @@ (define (svn-fetch-builder svn hash-algo)
                        (guix build download-nar)
                        (guix build utils)
                        (guix swh)
-                       (ice-9 match))
+                       (ice-9 match)
+                       (srfi srfi-26))
 
           ;; Add tar and gzip to $PATH so
           ;; 'swh-download-directory-by-nar-hash' can invoke them.
@@ -120,7 +125,9 @@ (define (svn-fetch-builder svn hash-algo)
                                              ("yes" #t)
                                              (_ #f))
                               #:user-name (getenv "svn user name")
-                              #:password (getenv "svn password")))
+                              #:password (getenv "svn password")
+                              #:subdirectories (and=> (getenv "svn subdirectories")
+                                                      (cut string-split <> #\:))))
               (and (download-method-enabled? 'nar)
                    (download-nar #$output))
               (and (download-method-enabled? 'swh)
@@ -164,6 +171,11 @@ (define* (svn-fetch ref hash-algo hash
                               `(("svn password"
                                  . ,(svn-reference-password ref)))
                               '())
+                        ,@(if (svn-reference-subdirectories ref)
+                              `(("svn subdirectories"
+                                 . ,(string-join
+                                     (svn-reference-subdirectories ref) ":")))
+                              '())
                         ,@(match (getenv "GUIX_DOWNLOAD_METHODS")
                             (#f '())
                             (value

base-commit: 503919fcf01d7eb8d550df5c3993aee9a966ba9b
-- 
2.46.0