6f918d69b4
* guix/import/texlive.scm (fetch-sxml, sxml->package): Export.
* tests/texlive.scm <top level>: Call '%http-server-port'.
("fetch-sxml: returns SXML for valid XML"): Use 'with-http-server' and
set 'current-http-proxy' instead of using 'mock'.
("sxml->package"): Remove use of '@@'.
190 lines
6.9 KiB
Scheme
190 lines
6.9 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
|
|
;;;
|
|
;;; 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 match)
|
|
#:use-module (sxml simple)
|
|
#:use-module (sxml xpath)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (srfi srfi-34)
|
|
#:use-module (web uri)
|
|
#:use-module (guix http-client)
|
|
#:use-module (gcrypt hash)
|
|
#:use-module (guix memoization)
|
|
#: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 utils)
|
|
#:use-module (guix upstream)
|
|
#:use-module (guix packages)
|
|
#:use-module (gnu packages)
|
|
#:use-module (guix build-system texlive)
|
|
#:export (texlive->guix-package
|
|
|
|
fetch-sxml
|
|
sxml->package))
|
|
|
|
;;; 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.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(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)
|
|
("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-by-2.0)
|
|
("cc-by-3" 'cc-by-3.0)
|
|
("cc-by-sa-2" 'cc-by-sa2.0)
|
|
("cc-by-sa-3" 'cc-by-sa3.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)
|
|
((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))))
|
|
|
|
(define (guix-name component name)
|
|
"Return a Guix package name for a given Texlive package NAME."
|
|
(string-append "texlive-" component "-"
|
|
(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)))
|
|
(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)))
|
|
`(package
|
|
(name ,(guix-name component id))
|
|
(version ,version)
|
|
(source (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)))))))
|
|
(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)))))))
|
|
|
|
(define texlive->guix-package
|
|
(memoize
|
|
(lambda* (package-name #:optional (component "latex"))
|
|
"Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
|
|
s-expression corresponding to that package, or #f on failure."
|
|
(and=> (fetch-sxml package-name)
|
|
(cut sxml->package <> component)))))
|
|
|
|
;;; ctan.scm ends here
|