From 3b1a12c5bff5a0c108284d19a6982bdf663bbceb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 15 Nov 2021 16:38:05 +0000 Subject: import: Replace texlive importer. * guix/import/texlive.scm (fetch-sxml, sxml->package): Remove procedures. (tlpdb-file, tlpdb, files->directories, tlpdb->package): New procedures. (string->license): Add case for lpplgpl license combination. (guix-name): Remove COMPONENT argument. (texlive->guix-package): Use new procedures. (texlive-recursive-import): New procedure. * guix/scripts/import/texlive.scm (show-help, %options): Remove --archive option. (guix-import-texlive): Adjust call of texlive->guix-package. * doc/guix.texi (Invoking guix import): Update documentation. --- guix/import/texlive.scm | 254 +++++++++++++++++++++++++--------------- guix/scripts/import/texlive.scm | 16 +-- 2 files changed, 162 insertions(+), 108 deletions(-) (limited to 'guix') diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 18d8b95ee0..8677caee59 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 +;;; Copyright © 2017, 2021 Ricardo Wurmus ;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; 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,16 @@ (define-module (guix import texlive) #:use-module (guix utils) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) #:use-module (guix build-system texlive) + #:use-module (gnu packages tex) #: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 +69,8 @@ (define string->license ("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 +99,161 @@ (define string->license ("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)))) + (x `(error unknown-license ,x)))) -(define (guix-name component name) +(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) (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) + (pk 'f->d + (map (cut string-join <> "/" 'suffix) + (delete-duplicates (map (lambda (file) + (drop-right (string-split file #\/) 1)) + files) + equal?)))) + +(define (tlpdb->package name) + (and-let* ((data (assoc-ref (tlpdb) 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 ,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) + "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)))) + +(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/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 +;;; Copyright © 2017, 2021 Ricardo Wurmus ;;; Copyright © 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. @@ -42,8 +42,6 @@ (define %default-options (define (show-help) (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_ " @@ -60,10 +58,6 @@ (define %options (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 @@ (define (parse-options) (_ #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~%"))) -- cgit v1.2.3