guix: import texlive: Handle versions.

* guix/import/texlive.scm (texlive-repository):
(texlive-repository-location):
(svn-command):
(version->revision):
(current-day):
(latest-texlive-tag):
(texlive->svn-multi-reference): New variables.
(tlpdb-file) Remove function.
(tlpdb): Add VERSION argument.
* guix/import/texlive.scm (list-upstream-inputs): Add VERSION and DATABASE
arguments.
(tlpdb->package): Do not use fixed version.  Instead, make use of the version
provided as an argument.  Add DATABASE argument for testing.
(texlive->guix-package): Do not memoize.  Allow providing any TeX Live release
tag as version.  Default to latest tag.  Add DATABASE argument for testing.
Improve docstring.

* tests/texlive.scm ("texlive->guix-package, no docfiles"):
("texlive->guix-package"):
("texlive->guix-package, with METAFONT files"):
("texlive->guix-package, with catalogue entry, no inputs"):
("texlive->guix-package, multiple licenses"):
("texlive->guix-package, meta-package"):
("texlive->guix-package, with TeX format"):
("texlive->guix-package, execute but no TeX format"):
("texlive->guix-package, translate dependencies"):
("texlive->guix-package, lonely `hyphen-base' dependency and ARCH"):
("texlive->guix-package, single script, no extension"):
("texlive->guix-package, multiple scripts, with extensions"):
("texlive->guix-package, script with associated input"):
("texlive->guix-package, propagated binaries, no script"):
("texlive->guix-package, propagated binaries and scripts"):
("texlive->guix-package, with skipped propagated binaries"): Update tests.

Change-Id: I7576b6e31e9ec3ff84258b71d0c4dd180d2b5c38

2 files changed, 229 insertions, 171 deletions

diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index 0e0369a416..cbccafb811 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -21,22 +21,28 @@
 (define-module (guix import texlive)
   #:use-module (gcrypt hash)
   #:use-module (guix base32)
-  #:use-module (guix build-system texlive)
+  #:use-module (guix build-system)
   #:use-module (guix derivations)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
   #:use-module (guix import utils)
   #:use-module (guix memoization)
   #:use-module (guix monads)
-  #:use-module (guix serialization)
+  #:use-module (guix packages)
+  #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix store)
   #:use-module (guix svn-download)
   #:use-module (guix upstream)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:export (texlive->guix-package
             texlive-recursive-import))
@@ -49,6 +55,20 @@
 ;;;
 ;;; Code:
 
+(define texlive-repository "svn://www.tug.org/texlive")
+
+(define* (texlive-repository-location version #:optional location)
+  (format #f
+          "~a/tags/texlive-~a/~a"
+          texlive-repository
+          version
+          (cond
+           ((not location) "")
+           ((string-prefix? "/" location)
+            (string-drop location 1))
+           (else
+            location))))
+
 ;; Generic locations are parts of the tree shared by multiple packages.
 ;; Package definitions should single out files stored there, or all files in
 ;; the directory from all involved packages would be downloaded.
@@ -82,6 +102,58 @@
         "tie"
         "web"))
 
+(define (svn-command . args)
+  "Execute \"svn\" command with arguments ARGS, provided as strings, and
+return its output as a string.  Raise an error if the command execution did
+not succeed."
+  (define subversion
+    ;; Resolve this variable lazily so that (gnu packages ...) does not end up
+    ;; in the closure of this module.
+    (module-ref (resolve-interface '(gnu packages version-control))
+                'subversion))
+  (let* ((svn
+          (with-store store
+            (run-with-store store
+              (mlet* %store-monad
+                  ((drv (lower-object subversion))
+                   (built (built-derivations (list drv))))
+                (match (derivation->output-paths drv)
+                  (((names . locations) ...)
+                   (return (string-append (first locations) "/bin/svn"))))))))
+         (command (string-append svn (string-join args " " 'prefix)))
+         (pipe (open-input-pipe command))
+         (output (read-string pipe)))
+    ;; Output from these commands is memoized.  Raising an error prevent from
+    ;; storing bogus values in memory.
+    (unless (zero? (status:exit-val (close-pipe pipe)))
+      (report-error (G_ "failed to run command: '~a'") command))
+    output))
+
+(define version->revision
+  ;; Return revision, as a number, associated to string VERSION.
+  (lambda (version)
+    (let ((output (svn-command "info"
+                               (texlive-repository-location version)
+                               "--show-item 'last-changed-revision'"
+                               "--no-newline")))
+      (string->number output))))
+
+(define (current-day)
+  "Return number of days since Epoch."
+  (floor (/ (time-second (current-time)) (* 24 60 60))))
+
+(define latest-texlive-tag
+  ;; Return the latest TeX Live tag in repository.  The argument refers to
+  ;; current day, so memoization is only active a single day, as the
+  ;; repository may have been updated between two calls.
+  (memoize
+   (lambda* (#:key (day (current-day)))
+     (let ((output
+            (svn-command "ls" (string-append texlive-repository "/tags") "-v")))
+       ;; E.g. "70951 karl april 15 18:11 texlive-2024.2/\n\n"
+       (and=> (string-match "texlive-([^/]+)/\n*$" output)
+              (cut match:substring <> 1))))))
+
 (define string->license
   (match-lambda
     ("artistic2" 'artistic2.0)
@@ -185,95 +257,81 @@ Guix-specific packages."
                  (name name))
                depends)))
 
-(define (tlpdb-file)
-  (define texlive-scripts
-    ;; 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-scripts))
-
-  (with-store store
-    (run-with-store store
-      (mlet* %store-monad
-          ((drv (lower-object texlive-scripts))
-           (built (built-derivations (list drv))))
-        (match (derivation->output-paths drv)
-          (((names . items) ...)
-           (return (string-append (second items) ;"out"
-                                  "/share/tlpkg/texlive.tlpdb"))))))))
-
-(define tlpdb
-  (memoize
-   (lambda ()
-     (let ((file (tlpdb-file))
-           (fields
-            '((name     . string)
-              (shortdesc . string)
-              (longdesc . string)
-              (catalogue . string)
-              (catalogue-license . string)
-              (catalogue-ctan . string)
-              (srcfiles . list)
-              (runfiles . list)
-              (docfiles . list)
-              (binfiles . list)
-              (depend   . simple-list)
-              (execute  . 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)
+(define (tlpdb version)
+  "Return the TeX Live database associated to VERSION repository tag.  The
+function fetches the requested \"texlive.tlpdb\" file and parses it as
+association list."
+  (let* ((fields
+          '((name     . string)
+            (shortdesc . string)
+            (longdesc . string)
+            (catalogue . string)
+            (catalogue-license . string)
+            (catalogue-ctan . string)
+            (srcfiles . list)
+            (runfiles . list)
+            (docfiles . list)
+            (binfiles . list)
+            (depend   . simple-list)
+            (execute  . 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)))))
+         (database-url
+          (texlive-repository-location version "Master/tlpkg/texlive.tlpdb")))
+    (call-with-input-string (svn-command "cat" database-url)
+      (lambda (port)
+        (let loop
+            ;; Store the SVN revision of the packages database.
+            ((all (list (cons 'database-revision (version->revision version))))
+             (current (list))
+             (last-property #false))
+          (let ((line (read-line port)))
+            (cond
+             ((eof-object? line) (values all))
 
-                ;; End of record.
-                ((string-null? line)
-                 (loop (cons (cons (assoc-ref current 'name) current)
-                             all)
-                       (list) #false))
+             ;; 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))))))))))
 
-                ;; 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 tlpdb/cached (memoize tlpdb))
 
 (define latex-bin-dependency-tree
   ;; Return a list of packages used to build "latex-bin" package.  Those
@@ -346,12 +404,11 @@ extensions, and files without extension."
                     (reverse scripts)))
       '()))
 
-(define (list-upstream-inputs upstream-name)
+(define (list-upstream-inputs upstream-name version database)
   "Return the list of <upstream-input> corresponding to all the dependencies
-of package with UPSTREAM-NAME."
-  (let* ((database (tlpdb))
-         (package-data (assoc-ref database upstream-name))
-         (scripts (list-linked-scripts upstream-name database)))
+of package with UPSTREAM-NAME in VERSION."
+  (let ((package-data (assoc-ref database upstream-name))
+        (scripts (list-linked-scripts upstream-name database)))
     (append
      ;; Native inputs.
      ;;
@@ -438,46 +495,48 @@ of package with UPSTREAM-NAME."
             (delete-duplicates (sort (map trim-filename specific) string<)
                                string-prefix?))))
 
-(define (tlpdb->package name version package-database)
-  (and-let* ((data (assoc-ref package-database name))
-             (locs (files->locations
-                    (filter-map (lambda (file)
-                                  ;; Ignore any file not starting with the
-                                  ;; expected prefix.  Nothing good can come
-                                  ;; from this.
-                                  (and (string-prefix? "texmf-dist/" file)
-                                       (string-drop file (string-length "texmf-dist/"))))
-                                (append (or (assoc-ref data 'docfiles) (list))
-                                        (or (assoc-ref data 'runfiles) (list))
-                                        (or (assoc-ref data 'srcfiles) (list))))))
-             (texlive-name name)
-             (name (guix-name name))
-             ;; TODO: we're ignoring the VERSION argument because that
-             ;; information is distributed across %texlive-tag and
-             ;; %texlive-revision.
-             (ref (svn-multi-reference
-                   (url (string-append "svn://www.tug.org/texlive/tags/"
-                                       %texlive-tag "/Master/texmf-dist"))
-                   (locations locs)
-                   (revision %texlive-revision)))
-             ;; Ignore arch-dependent packages.
-             (depends (or (assoc-ref data 'depend) '()))
+(define (texlive->svn-multi-reference upstream-name version database)
+  "Return <svn-multi-reference> object for TeX Live package with UPSTREAM-NAME
+at VERSION."
+  (let* ((data (assoc-ref database upstream-name))
+         (locations
+          (files->locations
+           (filter-map (lambda (file)
+                         ;; Ignore any file not starting with the expected
+                         ;; prefix.  Nothing good can come from this.
+                         (and (string-prefix? "texmf-dist/" file)
+                              (string-drop file (string-length "texmf-dist/"))))
+                       (append (or (assoc-ref data 'docfiles) (list))
+                               (or (assoc-ref data 'runfiles) (list))
+                               (or (assoc-ref data 'srcfiles) (list)))))))
+    (svn-multi-reference
+     (url (texlive-repository-location version "Master/texmf-dist"))
+     (locations (sort locations string<))
+     (revision (assoc-ref database 'database-revision)))))
+
+(define (tlpdb->package upstream-name version database)
+  (and-let* ((data (assoc-ref database upstream-name))
+             (name (guix-name upstream-name))
+             (reference
+              (texlive->svn-multi-reference upstream-name version database))
              (source (with-store store
                        (download-multi-svn-to-store
-                        store ref (string-append name "-svn-multi-checkout")))))
-    (let* ((scripts (list-linked-scripts texlive-name package-database))
-           (upstream-inputs (list-upstream-inputs texlive-name))
+                        store reference
+                        (format #f "~a-~a-svn-multi-checkout" name version)))))
+    (let* ((scripts (list-linked-scripts upstream-name database))
+           (upstream-inputs
+            (list-upstream-inputs upstream-name version database))
            (tex-formats (list-formats data))
-           (meta-package? (null? locs))
+           (meta-package? (null? (svn-multi-reference-locations reference)))
            (empty-package? (and meta-package? (not (pair? tex-formats)))))
       (values
        `(package
           (name ,name)
-          (version (number->string %texlive-revision))
+          (version ,version)
           (source ,(and (not meta-package?)
                         `(texlive-origin
                           name version
-                          (list ,@(sort locs string<))
+                          (list ,@(svn-multi-reference-locations reference))
                           (base32
                            ,(bytevector->nix-base32-string
                              (let-values (((port get-hash) (open-sha256-port)))
@@ -487,17 +546,16 @@ of package with UPSTREAM-NAME."
           ,@(if (assoc-ref data 'docfiles)
                 '((outputs '("out" "doc")))
                 '())
-          ;; Set build-system.
+          ;; Build system.
           ;;
           ;; Use trivial build system only when the package contains no files,
           ;; and no TeX format file is expected to be built.
           (build-system ,(if empty-package?
                              'trivial-build-system
                              'texlive-build-system))
-          ;; Generate arguments field.
+          ;; Arguments.
           ,@(let* ((latex-bin-dependency?
-                    (member texlive-name
-                            (latex-bin-dependency-tree package-database)))
+                    (member upstream-name (latex-bin-dependency-tree database)))
                    (arguments
                     (append (if empty-package?
                                 '(#:builder #~(mkdir #$output))
@@ -521,7 +579,7 @@ of package with UPSTREAM-NAME."
           ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'regular)
               (() '())
               (inputs `((inputs (list ,@inputs)))))
-          ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'regular)
+          ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'propagated)
               (() '())
               (inputs `((propagated-inputs (list ,@inputs)))))
           ;; Home page, synopsis, description and license.
@@ -540,17 +598,17 @@ of package with UPSTREAM-NAME."
              ((assoc-ref data 'catalogue-license) => string->license)
              (else #f))))
        ;; List of pure TeX Live dependencies for recursive calls.
-       (filter-depends depends #t)))))
+       (filter-depends (or (assoc-ref data 'depend) '()) #t)))))
 
 (define texlive->guix-package
-  (memoize
-   (lambda* (name #:key
-                  (version (number->string %texlive-revision))
-                  (package-database tlpdb)
-                  #:allow-other-keys)
-     "Find the metadata for NAME in the tlpdb and return the `package'
-s-expression corresponding to that package, or #f on failure."
-     (tlpdb->package name version (package-database)))))
+  (lambda* (name #:key version database #:allow-other-keys)
+    "Find the metadata for NAME in the TeX Live database and return the
+associated Guix package, or #f on failure.  Fetch metadata for a specific
+version whenever VERSION keyword is specified.  Otherwise, grab package latest
+release.  When DATABASE is provided, fetch metadata from there, ignoring
+VERSION."
+    (let ((version (or version (latest-texlive-tag))))
+      (tlpdb->package name version (or database (tlpdb/cached version))))))
 
 (define* (texlive-recursive-import name #:key repo version)
   (recursive-import name
diff --git a/tests/texlive.scm b/tests/texlive.scm
index bfd3f57f20..427d4b2cf7 100644
--- a/tests/texlive.scm
+++ b/tests/texlive.scm
@@ -369,8 +369,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "example"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-example")
@@ -403,8 +403,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "texsis"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-texsis")
@@ -449,8 +449,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "trsym"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name _)
@@ -483,8 +483,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "12many"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-12many")
@@ -520,8 +520,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "chs-physics-report"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-chs-physics-report")
@@ -556,8 +556,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "collection-texworks"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-collection-texworks")
@@ -592,8 +592,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "lollipop"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-lollipop")
@@ -629,8 +629,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "adforn"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-adforn")
@@ -661,8 +661,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "collection-basic"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-collection-basic")
@@ -696,8 +696,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "tex"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-tex")
@@ -731,8 +731,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "authorindex"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-authorindex")
@@ -765,8 +765,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "cyrillic-bin"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-cyrillic-bin")
@@ -800,8 +800,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "pax"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-pax")
@@ -836,8 +836,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "vlna"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-vlna")
@@ -870,8 +870,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "m-tx"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-m-tx")
@@ -905,8 +905,8 @@ completely compatible with Plain TeX.")
              (lambda ()
                (display "source")))))
         (let ((result (texlive->guix-package "web"
-                                             #:package-database
-                                             (lambda _ %fake-tlpdb))))
+                                             #:version "0"
+                                             #:database %fake-tlpdb)))
           (match result
             (('package
                ('name "texlive-web")