diff options
author | Ricardo Wurmus <rekado@elephly.net> | 2021-11-15 16:38:05 +0000 |
---|---|---|
committer | Ricardo Wurmus <rekado@elephly.net> | 2021-11-17 11:00:01 +0000 |
commit | 3b1a12c5bff5a0c108284d19a6982bdf663bbceb (patch) | |
tree | 0fdbc65fb2076280cdf070d9e5219a0bbbbbb77d /guix/import/texlive.scm | |
parent | 3e5749fc331243e9d29baa73a569dc6b6de25f33 (diff) |
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.
Diffstat (limited to 'guix/import/texlive.scm')
-rw-r--r-- | guix/import/texlive.scm | 254 |
1 files changed, 158 insertions, 96 deletions
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 <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,16 @@ #: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 @@ ("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 @@ ("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 |