5f51601bd9
* guix/import/texlive.scm (translate-depends): New function.
(tlpdb->package): Use new function.
* tests/texlive.scm (%fake-tlpdb): Add test data.
("texlive->guix-package, translate dependencies"):
("texlive->guix-package, lonely `hyphen-base' dependency and ARCH"): New tests.
418 lines
18 KiB
Scheme
418 lines
18 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net>
|
||
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix import texlive)
|
||
#:use-module (ice-9 ftw)
|
||
#:use-module (ice-9 match)
|
||
#: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 (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)
|
||
#:use-module (guix svn-download)
|
||
#:use-module (guix import utils)
|
||
#:use-module (guix build-system texlive)
|
||
#:export (files-differ?
|
||
texlive->guix-package
|
||
texlive-recursive-import))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; 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:
|
||
|
||
;; 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.
|
||
(define texlive-generic-locations
|
||
(list "doc/generic/hyph-utf8/"
|
||
"doc/info/"
|
||
"doc/man/"
|
||
"doc/web2c/"
|
||
"scripts/texlive/"
|
||
"scripts/texlive-extra/"
|
||
"tex/generic/config/"
|
||
"tex/generic/hyphen/"
|
||
"web2c/"))
|
||
|
||
(define string->license
|
||
(match-lambda
|
||
("artistic2" 'gpl3+)
|
||
("gpl" 'gpl3+)
|
||
("gpl1" 'gpl1)
|
||
("gpl1+" 'gpl1+)
|
||
("gpl2" 'gpl2)
|
||
("gpl2+" 'gpl2+)
|
||
("gpl3" 'gpl3)
|
||
("gpl3+" 'gpl3+)
|
||
("lgpl2.1" 'lgpl2.1)
|
||
("lgpl3" 'lgpl3)
|
||
("knuth" 'knuth)
|
||
("pd" 'public-domain)
|
||
("bsd2" 'bsd-2)
|
||
("bsd3" 'bsd-3)
|
||
("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"
|
||
("lppl1.3" 'lppl1.3+) ; usually means "or later"
|
||
("lppl1.3a" 'lppl1.3a)
|
||
("lppl1.3b" 'lppl1.3b)
|
||
("lppl1.3c" 'lppl1.3c)
|
||
("cc-by-2" 'cc-by2.0)
|
||
("cc-by-3" 'cc-by3.0)
|
||
("cc-by-4" 'cc-by4.0)
|
||
("cc-by-sa-2" 'cc-by-sa2.0)
|
||
("cc-by-sa-3" 'cc-by-sa3.0)
|
||
("cc-by-sa-4" 'cc-by-sa4.0)
|
||
("mit" 'expat)
|
||
("fdl" 'fdl1.3+)
|
||
("gfl" 'gfl1.0)
|
||
|
||
;; These are known non-free licenses
|
||
("noinfo" 'unknown)
|
||
("nosell" 'non-free)
|
||
("shareware" 'non-free)
|
||
("nosource" 'non-free)
|
||
("nocommercial" 'non-free)
|
||
("cc-by-nc-nd-1" 'non-free)
|
||
("cc-by-nc-nd-2" 'non-free)
|
||
("cc-by-nc-nd-2.5" 'non-free)
|
||
("cc-by-nc-nd-3" 'non-free)
|
||
("cc-by-nc-nd-4" 'non-free)
|
||
((? string? x) (string->license (string-split x #\space)))
|
||
((x) `(error unknown-license ,x))
|
||
((lst ...) `(list ,@(map string->license lst)))
|
||
(x `(error unknown-license ,x))))
|
||
|
||
(define (guix-name name)
|
||
"Return a Guix package name for a given Texlive package NAME."
|
||
(string-append "texlive-"
|
||
(string-map (match-lambda
|
||
(#\_ #\-)
|
||
(#\. #\-)
|
||
(chr (char-downcase chr)))
|
||
name)))
|
||
|
||
(define* (translate-depends depends #:optional texlive-only)
|
||
"Translate TeX Live packages DEPENDS into their equivalent Guix names
|
||
in `(gnu packages tex)' module, without \"texlive-\" prefix. The function
|
||
also removes packages not necessary in Guix.
|
||
|
||
When TEXLIVE-ONLY is true, only TeX Live packages are returned."
|
||
(delete-duplicates
|
||
(filter-map (match-lambda
|
||
;; Hyphenation. Every TeX Live package is replaced with
|
||
;; "hyphen-complete", unless "hyphen-base" is the sole
|
||
;; dependency.
|
||
("hyphen-base"
|
||
(and (not (member "hyph-utf8" depends))
|
||
"hyphen-base"))
|
||
((or (? (cut string-prefix? "hyphen-" <>))
|
||
"hyph-utf8" "dehyph" "dehyph-exptl" "ruhyphen" "ukrhyph")
|
||
(and (not texlive-only) "hyphen-complete"))
|
||
;; Binaries placeholders are ignored.
|
||
((? (cut string-suffix? ".ARCH" <>)) #f)
|
||
;; So are TeX Live specific packages.
|
||
((or (? (cut string-prefix? "texlive-" <>))
|
||
"tlshell" "texlive.infra")
|
||
#f)
|
||
;; Others.
|
||
(name name))
|
||
depends)))
|
||
|
||
(define (tlpdb-file)
|
||
(define texlive-bin
|
||
;; 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-bin))
|
||
|
||
(with-store store
|
||
(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 . string)
|
||
(catalogue-license . string)
|
||
(catalogue-ctan . string)
|
||
(srcfiles . list)
|
||
(runfiles . list)
|
||
(docfiles . 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)
|
||
|
||
;; 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-differ? directory package-name
|
||
#:key
|
||
(package-database tlpdb)
|
||
(type #false)
|
||
(direction 'missing))
|
||
"Return a list of files in DIRECTORY that differ from the expected installed
|
||
files for PACKAGE-NAME according to the PACKAGE-DATABASE. By default all
|
||
files considered, but this can be restricted by setting TYPE to 'runfiles,
|
||
'docfiles, or 'srcfiles. The names of files that are missing from DIRECTORY
|
||
are returned; by setting DIRECTION to anything other than 'missing, the names
|
||
of those files are returned that are unexpectedly installed."
|
||
(define (strip-directory-prefix file-name)
|
||
(string-drop file-name (1+ (string-length directory))))
|
||
(let* ((data (or (assoc-ref (package-database) package-name)
|
||
(error (format #false
|
||
"~a is not a valid package name in the TeX Live package database."
|
||
package-name))))
|
||
(files (if type
|
||
(or (assoc-ref data type) (list))
|
||
(append (or (assoc-ref data 'runfiles) (list))
|
||
(or (assoc-ref data 'docfiles) (list))
|
||
(or (assoc-ref data 'srcfiles) (list)))))
|
||
(existing (file-system-fold
|
||
(const #true) ;enter?
|
||
(lambda (path stat result) (cons path result)) ;leaf
|
||
(lambda (path stat result) result) ;down
|
||
(lambda (path stat result) result) ;up
|
||
(lambda (path stat result) result) ;skip
|
||
(lambda (path stat errno result) result) ;error
|
||
(list)
|
||
directory)))
|
||
(if (eq? direction 'missing)
|
||
(lset-difference string=?
|
||
files (map strip-directory-prefix existing))
|
||
;; List files that are installed but should not be.
|
||
(lset-difference string=?
|
||
(map strip-directory-prefix existing) files))))
|
||
|
||
(define (files->locations files)
|
||
(define name->parts (cut string-split <> #\/))
|
||
;; Generic locations are shared by multiple packages. Provide the full file
|
||
;; name to make so as to extract only the files related to the package being
|
||
;; imported.
|
||
(let-values (((generic specific)
|
||
(partition (lambda (f)
|
||
(any (cut string-prefix? <> f)
|
||
texlive-generic-locations))
|
||
files)))
|
||
(append generic
|
||
(map (cut string-join <> "/" 'suffix)
|
||
(delete-duplicates (map (lambda (file)
|
||
(drop-right (name->parts file) 1))
|
||
(sort specific string<))
|
||
;; Remove sub-directories, i.e. more
|
||
;; specific entries with the same prefix.
|
||
(lambda (x y) (every equal? x y)))))))
|
||
|
||
(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))))))
|
||
(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) '()))
|
||
(source (with-store store
|
||
(download-multi-svn-to-store
|
||
store ref (string-append name "-svn-multi-checkout")))))
|
||
(let ((meta-package? (null? locs)))
|
||
(values
|
||
`(package
|
||
(name ,name)
|
||
(version (number->string %texlive-revision))
|
||
(source ,(and (not meta-package?)
|
||
`(texlive-origin
|
||
name version
|
||
(list ,@(sort locs string<))
|
||
(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 'docfiles)
|
||
'((outputs '("out" "doc")))
|
||
'())
|
||
(build-system texlive-build-system)
|
||
;; Translate AddFormat execute actions into a `#:create-formats'
|
||
;; argument.
|
||
,@(or (and-let*
|
||
((actions (assoc-ref data 'execute))
|
||
(formats
|
||
(delete-duplicates
|
||
(filter-map (lambda (action)
|
||
(match (string-split action #\space)
|
||
(("AddFormat" name . _)
|
||
(string-drop name
|
||
(string-length "name=")))
|
||
( #f)))
|
||
actions)))
|
||
((not (null? formats))))
|
||
`((arguments
|
||
(list #:create-formats #~(list ,@(reverse formats))))))
|
||
'())
|
||
;; Texlive build system generates font metrics whenever a font
|
||
;; metrics file has the same base name as a Metafont file.
|
||
,@(or (and-let* ((runfiles (assoc-ref data 'runfiles))
|
||
(metrics
|
||
(filter-map (lambda (f)
|
||
(and (string-suffix? ".tfm" f)
|
||
(basename f ".tfm")))
|
||
runfiles))
|
||
((not (null? metrics)))
|
||
((any (lambda (f)
|
||
(and (string-suffix? ".mf" f)
|
||
(member (basename f ".mf") metrics)))
|
||
runfiles)))
|
||
'((native-inputs (list texlive-metafont))))
|
||
'())
|
||
,@(match (translate-depends depends)
|
||
(() '())
|
||
(inputs
|
||
`((propagated-inputs
|
||
(list ,@(map (compose string->symbol guix-name)
|
||
(sort inputs string<?)))))))
|
||
(home-page
|
||
,(cond
|
||
(meta-package? "https://www.tug.org/texlive/")
|
||
((or (assoc-ref data 'catalogue) (assoc-ref data 'name)) =>
|
||
(cut string-append "https://ctan.org/pkg/" <>))
|
||
(else "https://www.tug.org/texlive/")))
|
||
(synopsis ,(assoc-ref data 'shortdesc))
|
||
(description ,(and=> (assoc-ref data 'longdesc) beautify-description))
|
||
(license
|
||
,(cond
|
||
(meta-package?
|
||
'(license:fsf-free "https://www.tug.org/texlive/copying.html"))
|
||
((assoc-ref data 'catalogue-license) => string->license)
|
||
(else #f))))
|
||
(translate-depends depends #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)))))
|
||
|
||
(define* (texlive-recursive-import name #:key repo version)
|
||
(recursive-import name
|
||
#:repo repo
|
||
#:version version
|
||
#:repo->guix-package texlive->guix-package
|
||
#:guix-name guix-name))
|
||
|
||
;;; texlive.scm ends here
|