Commit | Line | Data |
---|---|---|
afbc9419 RW |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix import texlive) | |
20 | #:use-module (ice-9 match) | |
21 | #:use-module (sxml simple) | |
22 | #:use-module (sxml xpath) | |
23 | #:use-module (srfi srfi-11) | |
24 | #:use-module (srfi srfi-1) | |
25 | #:use-module (srfi srfi-26) | |
26 | #:use-module (srfi srfi-34) | |
27 | #:use-module (web uri) | |
28 | #:use-module (guix http-client) | |
ca719424 | 29 | #:use-module (gcrypt hash) |
afbc9419 RW |
30 | #:use-module (guix memoization) |
31 | #:use-module (guix store) | |
32 | #:use-module (guix base32) | |
33 | #:use-module (guix serialization) | |
34 | #:use-module (guix svn-download) | |
35 | #:use-module (guix import utils) | |
36 | #:use-module (guix utils) | |
37 | #:use-module (guix upstream) | |
38 | #:use-module (guix packages) | |
39 | #:use-module (gnu packages) | |
40 | #:use-module (guix build-system texlive) | |
6f918d69 LC |
41 | #:export (texlive->guix-package |
42 | ||
43 | fetch-sxml | |
44 | sxml->package)) | |
afbc9419 RW |
45 | |
46 | ;;; Commentary: | |
47 | ;;; | |
48 | ;;; Generate a package declaration template for the latest version of a | |
49 | ;;; package on CTAN, using the XML output produced by the XML API to the CTAN | |
50 | ;;; database at http://www.ctan.org/xml/1.2/ | |
51 | ;;; | |
52 | ;;; Instead of taking the packages from CTAN, however, we fetch the sources | |
53 | ;;; from the SVN repository of the Texlive project. We do this because CTAN | |
54 | ;;; only keeps a single version of each package whereas we can access any | |
55 | ;;; version via SVN. Unfortunately, this means that the importer is really | |
56 | ;;; just a Texlive importer, not a generic CTAN importer. | |
57 | ;;; | |
58 | ;;; Code: | |
59 | ||
60 | (define string->license | |
61 | (match-lambda | |
62 | ("artistic2" 'gpl3+) | |
63 | ("gpl" 'gpl3+) | |
64 | ("gpl1" 'gpl1) | |
65 | ("gpl1+" 'gpl1+) | |
66 | ("gpl2" 'gpl2) | |
67 | ("gpl2+" 'gpl2+) | |
68 | ("gpl3" 'gpl3) | |
69 | ("gpl3+" 'gpl3+) | |
70 | ("lgpl2.1" 'lgpl2.1) | |
71 | ("lgpl3" 'lgpl3) | |
72 | ("knuth" 'knuth) | |
73 | ("pd" 'public-domain) | |
74 | ("bsd2" 'bsd-2) | |
75 | ("bsd3" 'bsd-3) | |
76 | ("bsd4" 'bsd-4) | |
77 | ("opl" 'opl1.0+) | |
78 | ("ofl" 'silofl1.1) | |
79 | ("lppl" 'lppl) | |
80 | ("lppl1" 'lppl1.0+) ; usually means "or later" | |
81 | ("lppl1.2" 'lppl1.2+) ; usually means "or later" | |
82 | ("lppl1.3" 'lppl1.3+) ; usually means "or later" | |
83 | ("lppl1.3a" 'lppl1.3a) | |
84 | ("lppl1.3b" 'lppl1.3b) | |
85 | ("lppl1.3c" 'lppl1.3c) | |
86 | ("cc-by-2" 'cc-by-2.0) | |
87 | ("cc-by-3" 'cc-by-3.0) | |
88 | ("cc-by-sa-2" 'cc-by-sa2.0) | |
89 | ("cc-by-sa-3" 'cc-by-sa3.0) | |
90 | ("mit" 'expat) | |
91 | ("fdl" 'fdl1.3+) | |
92 | ("gfl" 'gfl1.0) | |
93 | ||
94 | ;; These are known non-free licenses | |
95 | ("noinfo" 'unknown) | |
96 | ("nosell" 'non-free) | |
97 | ("shareware" 'non-free) | |
98 | ("nosource" 'non-free) | |
99 | ("nocommercial" 'non-free) | |
100 | ("cc-by-nc-nd-1" 'non-free) | |
101 | ("cc-by-nc-nd-2" 'non-free) | |
102 | ("cc-by-nc-nd-2.5" 'non-free) | |
103 | ("cc-by-nc-nd-3" 'non-free) | |
104 | ("cc-by-nc-nd-4" 'non-free) | |
105 | ((x) (string->license x)) | |
106 | ((lst ...) `(list ,@(map string->license lst))) | |
107 | (_ #f))) | |
108 | ||
109 | (define (fetch-sxml name) | |
110 | "Return an sxml representation of the package information contained in the | |
111 | XML description of the CTAN package or #f in case of failure." | |
112 | ;; This API always returns the latest release of the module. | |
113 | (let ((url (string-append "http://www.ctan.org/xml/1.2/pkg/" name))) | |
114 | (guard (c ((http-get-error? c) | |
115 | (format (current-error-port) | |
116 | "error: failed to retrieve package information \ | |
117 | from ~s: ~a (~s)~%" | |
118 | (uri->string (http-get-error-uri c)) | |
119 | (http-get-error-code c) | |
120 | (http-get-error-reason c)) | |
121 | #f)) | |
122 | (xml->sxml (http-fetch url) | |
123 | #:trim-whitespace? #t)))) | |
124 | ||
125 | (define (guix-name component name) | |
126 | "Return a Guix package name for a given Texlive package NAME." | |
127 | (string-append "texlive-" component "-" | |
128 | (string-map (match-lambda | |
129 | (#\_ #\-) | |
130 | (#\. #\-) | |
131 | (chr (char-downcase chr))) | |
132 | name))) | |
133 | ||
134 | (define* (sxml->package sxml #:optional (component "latex")) | |
135 | "Return the `package' s-expression for a Texlive package from the SXML | |
136 | expression describing it." | |
137 | (define (sxml-value path) | |
138 | (match ((sxpath path) sxml) | |
139 | (() #f) | |
140 | ((val) val))) | |
141 | (with-store store | |
142 | (let* ((id (sxml-value '(entry @ id *text*))) | |
143 | (synopsis (sxml-value '(entry caption *text*))) | |
144 | (version (or (sxml-value '(entry version @ number *text*)) | |
145 | (sxml-value '(entry version @ date *text*)))) | |
c0e9d470 LC |
146 | (license (match ((sxpath '(entry license @ type *text*)) sxml) |
147 | ((license) (string->license license)) | |
148 | ((lst ...) (map string->license lst)))) | |
afbc9419 RW |
149 | (home-page (string-append "http://www.ctan.org/pkg/" id)) |
150 | (ref (texlive-ref component id)) | |
151 | (checkout (download-svn-to-store store ref))) | |
152 | `(package | |
153 | (name ,(guix-name component id)) | |
154 | (version ,version) | |
155 | (source (origin | |
156 | (method svn-fetch) | |
157 | (uri (texlive-ref ,component ,id)) | |
158 | (sha256 | |
159 | (base32 | |
160 | ,(bytevector->nix-base32-string | |
161 | (let-values (((port get-hash) (open-sha256-port))) | |
162 | (write-file checkout port) | |
163 | (force-output port) | |
164 | (get-hash))))))) | |
165 | (build-system texlive-build-system) | |
166 | (arguments ,`(,'quote (#:tex-directory ,(string-join (list component id) "/")))) | |
167 | (home-page ,home-page) | |
168 | (synopsis ,synopsis) | |
169 | (description ,(string-trim-both | |
170 | (string-join | |
171 | (map string-trim-both | |
172 | (string-split | |
173 | (beautify-description | |
174 | (sxml->string (or (sxml-value '(entry description)) | |
175 | '()))) | |
176 | #\newline))))) | |
c0e9d470 LC |
177 | (license ,(match license |
178 | ((lst ...) `(list ,@lst)) | |
179 | (license license))))))) | |
afbc9419 RW |
180 | |
181 | (define texlive->guix-package | |
182 | (memoize | |
183 | (lambda* (package-name #:optional (component "latex")) | |
184 | "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' | |
185 | s-expression corresponding to that package, or #f on failure." | |
186 | (and=> (fetch-sxml package-name) | |
187 | (cut sxml->package <> component))))) | |
188 | ||
189 | ;;; ctan.scm ends here |