From c15b66ac673d7a43db90165e97ee229319716125 Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Sun, 16 Jun 2024 22:53:14 +0200 Subject: [PATCH] guix: import texlive: Implement auto-updates. * guix/import/texlive.scm (package-from-texlive-repository?): (latest-release): (tlpdb-guix-packages): (%texlive-updater): New variables. (tlpdb): Include Guix-specific package TEXLIVE-HYPHEN-COMPLETE. * guix/upstream.scm (package-update/svn-multi-fetch): New variable. (%method-updates): Extend it to support SVN-MULTI-FETCH. (update-package-source): Also update revisions and locations from svn-multi-reference sources. Change-Id: I6d7f2cfe1e2f78887f410233bfd2799ffab80f3c --- guix/import/texlive.scm | 71 +++++++++++++++- guix/upstream.scm | 182 ++++++++++++++++++++++++++-------------- 2 files changed, 190 insertions(+), 63 deletions(-) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index cbccafb811..b743495008 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -45,7 +45,8 @@ (define-module (guix import texlive) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:export (texlive->guix-package - texlive-recursive-import)) + texlive-recursive-import + %texlive-updater)) ;;; Commentary: ;;; @@ -102,6 +103,42 @@ (define no-bin-propagation-packages "tie" "web")) +;; Guix introduces two specific packages based on TEXLIVE-BUILD-SYSTEM. Add +;; an entry for them in the package database, so they can be imported, and +;; updated, like any other regular TeX Live package. +(define tlpdb-guix-packages + '(("hyphen-complete" + (docfiles "texmf-dist/doc/generic/dehyph-exptl/" + "texmf-dist/doc/generic/elhyphen/" + "texmf-dist/doc/generic/huhyphen/" + "texmf-dist/doc/generic/hyph-utf8/" + "texmf-dist/doc/luatex/hyph-utf8/" + "texmf-dist/doc/generic/ukrhyph/") + (runfiles "texmf-dist/tex/generic/config/" + "texmf-dist/tex/generic/dehyph/" + "texmf-dist/tex/generic/dehyph-exptl/" + "texmf-dist/tex/generic/hyph-utf8/" + "texmf-dist/tex/generic/hyphen/" + "texmf-dist/tex/generic/ruhyphen/" + "texmf-dist/tex/generic/ukrhyph/" + "texmf-dist/tex/luatex/hyph-utf8/") + (srcfiles "texmf-dist/source/generic/hyph-utf8/" + "texmf-dist/source/luatex/hyph-utf8/" + "texmf-dist/source/generic/ruhyphen/") + (shortdesc . "Hyphenation patterns expressed in UTF-8") + (longdesc . "Modern native UTF-8 engines such as XeTeX and LuaTeX +need hyphenation patterns in UTF-8 format, whereas older systems require +hyphenation patterns in the 8-bit encoding of the font in use (such encodings +are codified in the LaTeX scheme with names like OT1, T2A, TS1, OML, LY1, +etc). The present package offers a collection of conversions of existing +patterns to UTF-8 format, together with converters for use with 8-bit fonts in +older systems. + +This Guix-specific package provides hyphenation patterns for all languages +supported in TeX Live. It is a strict super-set of code{hyphen-base} package +and should be preferred to it whenever a package would otherwise depend on +@code{hyph-utf8}.")))) + (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 @@ -301,7 +338,8 @@ (define (tlpdb version) (last-property #false)) (let ((line (read-line port))) (cond - ((eof-object? line) (values all)) + ;; End of file. Don't forget to include Guix-specific package. + ((eof-object? line) (values (append tlpdb-guix-packages all))) ;; End of record. ((string-null? line) @@ -617,4 +655,33 @@ (define* (texlive-recursive-import name #:key repo version) #:repo->guix-package texlive->guix-package #:guix-name guix-name)) +;;; +;;; Updates. +;;; + +(define (package-from-texlive-repository? package) + (and (string-prefix? "texlive-" (package-name package)) + (eq? 'texlive (build-system-name (package-build-system package))))) + +(define* (latest-release package #:key version) + "Return an for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version." + (let* ((version (or version (latest-texlive-tag))) + (database (tlpdb/cached version)) + (upstream-name (package-upstream-name* package))) + (upstream-source + (package upstream-name) + (version version) + (urls (texlive->svn-multi-reference upstream-name version database)) + (inputs (list-upstream-inputs upstream-name version database))))) + +(define %texlive-updater + ;; The TeX Live updater. It is restricted to TeX Live releases (2023.0, + ;; 2024.2, ...); it doesn't include revision bumps for individual packages. + (upstream-updater + (name 'texlive) + (description "Updater for TeX Live packages") + (pred package-from-texlive-repository?) + (import latest-release))) + ;;; texlive.scm ends here diff --git a/guix/upstream.scm b/guix/upstream.scm index 180ae21dcf..753916be64 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -28,6 +28,7 @@ (define-module (guix upstream) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module (guix git-download) + #:use-module (guix svn-download) #:use-module (guix gnupg) #:use-module (guix packages) #:use-module (guix diagnostics) @@ -49,6 +50,7 @@ (define-module (guix upstream) #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:export (upstream-source upstream-source? upstream-source-package @@ -107,7 +109,7 @@ (define-record-type* upstream-source? (package upstream-source-package) ;string (version upstream-source-version) ;string - (urls upstream-source-urls) ;list of strings|git-reference + (urls upstream-source-urls) ;list of strings|git-references... (signature-urls upstream-source-signature-urls ;#f | list of strings (default #f)) (inputs upstream-source-inputs ;#f | list of @@ -463,10 +465,19 @@ (define ref (upstream-source-urls source)) ; a #:recursive? (git-reference-recursive? ref)) source)) +(define* (package-update/svn-multi-fetch store package source + #:key key-download key-server) + "Return the version, checkout, and SOURCE, to update PACKAGE to +SOURCE, an ." + (values (upstream-source-version source) + (download-multi-svn-to-store store (upstream-source-urls source)) + source)) + (define %method-updates ;; Mapping of origin methods to source update procedures. `((,url-fetch . ,package-update/url-fetch) - (,git-fetch . ,package-update/git-fetch))) + (,git-fetch . ,package-update/git-fetch) + (,svn-multi-fetch . ,package-update/svn-multi-fetch))) (define* (package-update store package #:optional (updaters (force %updaters)) @@ -608,9 +619,9 @@ (define* (update-package-source package source hash) "Modify the source file that defines PACKAGE to refer to SOURCE, an whose tarball has SHA256 HASH (a bytevector). Return the new version string if an update was made, and #f otherwise." - (define (update-expression expr replacements) + (define (replace-atom expr replacements) ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS - ;; must be a list of replacement pairs, either bytevectors or strings. + ;; must be a list of replacement pairs, either of byte-vectors or strings. (fold (lambda (replacement str) (match replacement (((? bytevector? old-bv) . (? bytevector? new-bv)) @@ -623,62 +634,111 @@ (define (update-expression expr replacements) expr replacements)) - (let ((name (package-name package)) - (version (upstream-source-version source)) - (version-loc (package-field-location package 'version))) - (if version-loc - (let* ((loc (package-location package)) - (old-version (package-version package)) - (old-hash (content-hash-value - (origin-hash (package-source package)))) - (old-url (match (origin-uri (package-source package)) - ((? string? url) url) - ((? git-reference? ref) - (git-reference-url ref)) - (_ #f))) - (new-url (match (upstream-source-urls source) - ((first _ ...) first) - ((? git-reference? ref) - (git-reference-url ref)) - (_ #f))) - (old-commit (match (origin-uri (package-source package)) - ((? git-reference? ref) - (git-reference-commit ref)) - (_ #f))) - (new-commit (match (upstream-source-urls source) - ((? git-reference? ref) - (git-reference-commit ref)) - (_ #f))) - (file (and=> (location-file loc) - (cut search-path %load-path <>)))) - (if file - ;; Be sure to use absolute filename. Replace the URL directory - ;; when OLD-URL is available; this is useful notably for - ;; mirror://cpan/ URLs where the directory may change as a - ;; function of the person who uploads the package. Note that - ;; package definitions usually concatenate fragments of the URL, - ;; which is why we only attempt to replace a subset of the URL. - (let ((replacements `((,old-version . ,version) - (,old-hash . ,hash) - ,@(if (and old-commit new-commit) - `((,old-commit . ,new-commit)) - '()) - ,@(if (and old-url new-url) - `((,(dirname old-url) . - ,(dirname new-url))) - '())))) - (and (edit-expression (location->source-properties - (absolute-location loc)) - (cut update-expression <> replacements)) - (or (not (upstream-source-inputs source)) - (update-package-inputs package source)) - version)) - (begin - (warning (G_ "~a: could not locate source file") - (location-file loc)) - #f))) - (warning (package-location package) - (G_ "~a: no `version' field in source; skipping~%") - name)))) + (define (replace-commit old new expr) + ;; Replace OLD commit or revision with NEW commit or revision in package + ;; expression EXPR. Special care is given to ensure the commit or + ;; revision does not inadvertently match a part of a bigger item. + (let ((regexp (make-regexp (format #f " ~s($|[ )])" old) + regexp/newline))) + (regexp-substitute/global + #f regexp expr 'pre (lambda (m) (format #f " ~s" new)) 1 'post))) + + (define (replace-list old new expr) + ;; Replace list OLD with list NEW in package expression EXPR. Elements in + ;; NEW are aligned vertically, at the same column as the first element in + ;; OLD. + (if (equal? old new) + expr + (let ((regexp + (make-regexp + (string-append + "(^[^\"]*)" ;initial indentation in group 1 + (string-join (map (compose regexp-quote object->string) old) + "[ \t\n]*")) + regexp/newline)) + (f + (lambda (m) + (let* ((lead (match:substring m 1)) + (indent (make-string (string-length lead) #\space))) + (string-append + lead + (string-join (map object->string new) + (string-append "\n" indent))))))) + (regexp-substitute/global #f regexp expr 'pre f 'post)))) + + (let* ((name (package-name package)) + (loc (package-location package)) + (version (upstream-source-version source)) + (old-version (package-version package)) + (old-hash (content-hash-value + (origin-hash (package-source package)))) + (old-url (match (origin-uri (package-source package)) + ((? string? url) url) + ((? git-reference? ref) + (git-reference-url ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-url ref)) + (_ #f))) + (old-commit (match (origin-uri (package-source package)) + ((? git-reference? ref) + (git-reference-commit ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-revision ref)) + (_ #f))) + (old-locations (match (origin-uri (package-source package)) + ((? svn-multi-reference? ref) + (svn-multi-reference-locations ref)) + (_ #f))) + (new-url (match (upstream-source-urls source) + ((first _ ...) first) + ((? git-reference? ref) + (git-reference-url ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-url ref)) + (_ #f))) + (new-commit (match (upstream-source-urls source) + ((? git-reference? ref) + (git-reference-commit ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-revision ref)) + (_ #f))) + (new-locations (match (upstream-source-urls source) + ((? svn-multi-reference? ref) + (svn-multi-reference-locations ref)) + (_ #f)))) + (cond + ;; Ensure package exists, has a version field, and is stored in a file + ;; with an absolute file name. + ((not (package-field-location package 'version)) + (warning (package-location package) + (G_ "~a: no `version' field in source; skipping~%") + name)) + ((not (and=> (location-file loc) + (cut search-path %load-path <>))) + (warning (G_ "~a: could not locate source file") + (location-file loc)) + #f) + ;; Proceed with replacements. + (else + (let ((replacement-pairs + `((,old-version . ,version) + (,old-hash . ,hash) + ;; Replace the URL directory when OLD-URL is available; this is + ;; useful notably for mirror://cpan/ URLs where the directory + ;; may change as a function of the person who uploads the + ;; package. Note that package definitions usually concatenate + ;; fragments of the URL, which is why we only attempt to + ;; replace a subset of the URL. + ,@(if (and old-url new-url) + `((,(dirname old-url) . ,(dirname new-url))) + '())))) + (and (edit-expression + (location->source-properties (absolute-location loc)) + (compose (cut replace-atom <> replacement-pairs) + (cut replace-commit old-commit new-commit <>) + (cut replace-list old-locations new-locations <>))) + (or (not (upstream-source-inputs source)) + (update-package-inputs package source)) + version)))))) ;;; upstream.scm ends here