summaryrefslogtreecommitdiff
path: root/guix/import/texlive.scm
blob: 7e79c778849bae2bf26123665ed239754b8fdc28 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
;;; 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/info/"
        "doc/man/man1/"
        "doc/man/man5/"
        "doc/web2c/"
        "scripts/context/lua/"
        "scripts/context/perl/"
        "scripts/texlive/"
        "scripts/texlive-extra/"
        "tex/generic/config/"
        "tex/generic/hyphen/"
        "web2c/"))

(define string->license
  (match-lambda
    ("artistic2" 'artistic2.0)
    ("apache2" 'asl2.0)
    ("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)
    ("cc0" 'cc0)
    ("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)
    ("x11" 'x11)
    ("fdl" 'fdl1.3+)
    ;; The GUST Font Nosource License, which is legally equivalent to
    ;; lppl1.3c+, is no longer in use (per
    ;; <https://www.gust.org.pl/projects/e-foundry/licenses>).  It has de
    ;; facto become GUST Font License 1.0.
    ((or "gfl" "gfsl") 'gfl1.0)
    ("isc" 'isc)

    ;; 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)
                 ;; And also development packages, which should inherit from
                 ;; the current package anyway.
                 ((? (cut string-suffix? "-dev" <>)) #f)
                 ;; Guix does not use Asymptote from TeX Live.  Ignore it.
                 ("asymptote" #f)
                 ;; TeXworks in TeX Live is only for Windows.  Don't bother.
                 ((or "texworks" "collection-texworks") #f)
                 ;; Others.
                 (name name))
               depends)))

(define (tlpdb-file)
  (define texlive-scripts
    ;; 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-scripts))

  (with-store store
    (run-with-store store
      (mlet* %store-monad
          ((drv (lower-object texlive-scripts))
           (built (built-derivations (list drv))))
        (match (derivation->output-paths drv)
          (((names . items) ...)
           (return (string-append (second items) ;"out"
                                  "/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)
              (binfiles . 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))))))))))))

;; Packages listed below are used to build "latex-bin" package, and therefore
;; cannot provide it automatically as a native input.  Consequently, the
;; importer sets TEXLIVE-LATEX-BIN? argument to #F for all of them.
(define latex-bin-dependency-tree
  (memoize
   (lambda (package-database)
     ;; Start out with "latex-bin", but also provide native inputs, which do
     ;; not appear as dependents, as roots for the search.
     (let loop ((packages
                 (list "latex-bin" "metafont" "modes" "tex"))
                (deps '()))
       (if (null? packages)
           ;; `translate-depends' will always translate "hyphen-base" into
           ;; "hyphen-complete".  Make sure plain hyphen-base appears in the
           ;; dependency tree.
           (cons "hyphen-base" (translate-depends deps))
           (loop (append-map (lambda (name)
                               (let ((data (assoc-ref package-database name)))
                                 (or (assoc-ref data 'depend)
                                     '())))
                             packages)
                 (append packages deps)))))))

(define (formats package-data)
  "Return a list of formats to build according to PACKAGE-DATA."
  (and=> (assoc-ref package-data 'execute)
         (lambda (actions)
           (delete-duplicates
            (filter-map
             (lambda (action)
               (match (string-split action #\space)
                 (("AddFormat" fmt . _)
                  (string-drop fmt (string-length "name=")))
                 (_ #f)))
             ;; Get the right (alphabetic) order.
             (reverse actions))))))

(define (linked-scripts name package-database)
  "Return a list of script names to symlink from \"bin/\" directory for
package NAME according to PACKAGE-DATABASE.  Consider as scripts files with
\".lua\", \".pl\", \".py\", \".rb\", \".sh\", \".tcl\", \".texlua\", \".tlu\"
extensions, and files without extension."
  (and-let* ((data (assoc-ref package-database name))
             ;; Check if binaries are associated to the package.
             (depend (assoc-ref data 'depend))
             ((member (string-append name ".ARCH") depend))
             ;; List those binaries.
             (bin-data (assoc-ref package-database
                                  ;; Any *nix-like architecture will do.
                                  (string-append name ".x86_64-linux")))
             (binaries (map basename (assoc-ref bin-data 'binfiles)))
             ;; List scripts candidates.  Bail out if there are none.
             (runfiles (assoc-ref data 'runfiles))
             (scripts (filter (cut string-prefix? "texmf-dist/scripts/" <>)
                              runfiles))
             ((pair? scripts)))
    (filter-map (lambda (script)
                  (and (any (lambda (ext)
                              (member (basename script ext) binaries))
                            '(".lua" ".pl" ".py" ".rb" ".sh" ".tcl" ".texlua"
                              ".tlu"))
                       (basename script)))
                ;; Get the right (alphabetic) order.
                (reverse scripts))))

(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 (trim-filename entry)
    (string-join (drop-right (string-split entry #\/) 1) "/" 'suffix))
  ;; 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)
                             ;; Only grab files from generic locations, not
                             ;; sub-directories.
                             (any (cut string=? <> (trim-filename f))
                                  texlive-generic-locations))
                           files)))
    (append generic
            ;; Remove sub-directories, i.e., more specific entries with the
            ;; same prefix.
            (delete-duplicates (sort (map trim-filename specific) string<)
                               string-prefix?))))

(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))))))
             (texlive-name name)
             (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* ((scripts (linked-scripts texlive-name package-database))
           (tex-formats (formats data))
           (meta-package? (null? locs))
           (empty-package? (and meta-package? (not (pair? tex-formats)))))
      (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")))
                '())
          ;; Set build-system.
          ;;
          ;; Use trivial build system only when the package contains no files,
          ;; and no TeX format file is expected to be built.
          (build-system ,(if empty-package?
                             'trivial-build-system
                             'texlive-build-system))
          ;; Generate arguments field.
          ,@(let* ((latex-bin-dependency?
                    (member texlive-name
                            (latex-bin-dependency-tree package-database)))
                   (arguments
                    (append (if empty-package?
                                '(#:builder #~(mkdir #$output))
                                '())
                            (if latex-bin-dependency?
                                '(#:texlive-latex-bin? #f)
                                '())
                            (if (pair? scripts)
                                `(#:link-scripts #~(list ,@scripts))
                                '())
                            (if (pair? tex-formats)
                                `(#:create-formats #~(list ,@tex-formats))
                                '()))))
              (if (pair? arguments)
                  `((arguments (list ,@arguments)))
                  '()))
          ;; Native inputs.
          ;;
          ;; Texlive build system generates font metrics whenever a font
          ;; metrics file has the same base name as a Metafont file.  In this
          ;; case, provide `texlive-metafont'.
          ,@(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))))
                '())
          ;; Inputs.
          ,@(match (append-map (lambda (s)
                                 (cond ((string-suffix? ".pl" s) '(perl))
                                       ((string-suffix? ".py" s) '(python))
                                       ((string-suffix? ".rb" s) '(ruby))
                                       ((string-suffix? ".tcl" s) '(tcl tk))
                                       (else '())))
                               (or scripts '()))
              (() '())
              (inputs `((inputs (list ,@(delete-duplicates inputs eq?))))))
          ;; Propagated inputs.
          ,@(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?
              '(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