projects/guix·blob javascript-team · refs

1165 lines · 47.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2010-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2012, 2013 Nikita Karetnikov <[email protected]>
4;;; Copyright © 2021 Simon Tournier <[email protected]>
5;;; Copyright © 2022 Maxime Devos <[email protected]>
6;;; Copyright © 2023, 2025 Maxim Cournoyer <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;;
25;;; Code for dealing with the maintenance of GNU packages, such as
26;;; auto-updates.
27;;;
28;;; Code:
29
30(define-module (guix gnu-maintenance)
31 #:use-module (web uri)
32 #:use-module (web client)
33 #:use-module (web response)
34 #:use-module (ice-9 regex)
35 #:use-module (ice-9 match)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-2)
38 #:use-module (srfi srfi-11)
39 #:use-module (srfi srfi-26)
40 #:use-module (srfi srfi-34)
41 #:use-module (rnrs io ports)
42 #:use-module ((guix http-client) #:hide (open-socket-for-uri))
43 ;; not required in many cases, so autoloaded to reduce start-up costs.
44 #:autoload (guix download) (%mirrors)
45 #:use-module (guix ftp-client)
46 #:use-module (guix utils)
47 #:use-module (guix diagnostics)
48 #:use-module (guix i18n)
49 #:autoload (guix combinators) (fold2)
50 #:use-module (guix memoization)
51 #:use-module (guix records)
52 #:use-module (guix upstream)
53 #:use-module (guix packages)
54 #:autoload (guix import utils) (false-if-networking-error find-version)
55 #:autoload (zlib) (call-with-gzip-input-port)
56 #:autoload (htmlprag) (html->sxml) ;from Guile-Lib
57 #:export (gnu-package-name
58 gnu-package-mundane-name
59 gnu-package-copyright-holder
60 gnu-package-savannah
61 gnu-package-fsd
62 gnu-package-language
63 gnu-package-logo
64 gnu-package-doc-category
65 gnu-package-doc-summary
66 gnu-package-doc-description
67 gnu-package-doc-urls
68 gnu-package-download-url
69
70 official-gnu-packages
71 official-gnu-packages*
72 find-package
73 gnu-package?
74
75 uri-mirror-rewrite
76 rewrite-url
77
78 release-file?
79 releases
80 import-release
81 gnu-release-archive-types
82 gnu-package-name->name+version
83
84 %gnu-updater
85 %gnu-ftp-updater
86 %savannah-updater
87 %sourceforge-updater
88 %xorg-updater
89 %kernel.org-updater
90 %generic-html-updater))
91
92
93;;;
94;;; List of GNU packages.
95;;;
96
97(define %gnumaint-base-url
98 "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
99
100(define %package-list-url
101 (string->uri
102 (string-append %gnumaint-base-url "rec/gnupackages.rec")))
103
104(define %package-description-url
105 ;; This file contains package descriptions in recutils format.
106 ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
107 ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
108 (string->uri
109 (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
110
111(define-record-type* <gnu-package-descriptor>
112 gnu-package-descriptor
113 make-gnu-package-descriptor
114
115 gnu-package-descriptor?
116
117 (name gnu-package-name)
118 (mundane-name gnu-package-mundane-name)
119 (copyright-holder gnu-package-copyright-holder)
120 (savannah gnu-package-savannah)
121 (fsd gnu-package-fsd)
122 (language gnu-package-language) ; list of strings
123 (logo gnu-package-logo)
124 (doc-category gnu-package-doc-category)
125 (doc-summary gnu-package-doc-summary)
126 (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
127 (doc-urls gnu-package-doc-urls) ; list of strings
128 (download-url gnu-package-download-url))
129
130(define* (official-gnu-packages
131 #:optional (fetch http-fetch/cached))
132 "Return a list of records, which are GNU packages. Use FETCH,
133to fetch the list of GNU packages over HTTP."
134 (define (read-records port)
135 ;; Return a list of alists. Each alist contains fields of a GNU
136 ;; package.
137 (let loop ((alist (recutils->alist port))
138 (result '()))
139 (if (null? alist)
140 (reverse result)
141 (loop (recutils->alist port)
142
143 ;; Ignore things like "%rec" (info "(recutils) Record
144 ;; Descriptors").
145 (if (assoc-ref alist "package")
146 (cons alist result)
147 result)))))
148
149 (define official-description
150 (let ((db (read-records (fetch %package-description-url #:text? #t))))
151 (lambda (name)
152 ;; Return the description found upstream for package NAME, or #f.
153 (and=> (find (lambda (alist)
154 (equal? name (assoc-ref alist "package")))
155 db)
156 (lambda (record)
157 (let ((field (assoc-ref record "blurb")))
158 ;; The upstream description file uses "redirect PACKAGE" as
159 ;; a blurb in cases where the description of the two
160 ;; packages should be considered the same (e.g., GTK+ has
161 ;; "redirect gnome".) This is usually not acceptable for
162 ;; us because we prefer to have distinct descriptions in
163 ;; such cases. Thus, ignore the 'blurb' field when that
164 ;; happens.
165 (and field
166 (not (string-prefix? "redirect " field))
167 field)))))))
168
169 (map (lambda (alist)
170 (let ((name (assoc-ref alist "package")))
171 (alist->record `(("description" . ,(official-description name))
172 ,@alist)
173 make-gnu-package-descriptor
174 (list "package" "mundane_name" "copyright_holder"
175 "savannah" "fsd" "language" "logo"
176 "doc_category" "doc_summary" "description"
177 "doc_url"
178 "download_url")
179 '("doc_url" "language"))))
180 (let* ((port (fetch %package-list-url #:text? #t))
181 (lst (read-records port)))
182 (close-port port)
183 lst)))
184
185(define official-gnu-packages*
186 (mlambda ()
187 "A memoizing version of 'official-gnu-packages' that returns the empty
188list when something goes wrong, such as a networking issue."
189 (let ((gnus (false-if-exception (official-gnu-packages))))
190 (or gnus '()))))
191
192(define (find-package name)
193 "Find GNU package called NAME and return it. Return #f if it was not
194found."
195 (find (lambda (package)
196 (string=? name (gnu-package-name package)))
197 (official-gnu-packages)))
198
199(define gnu-package?
200 (mlambdaq (package)
201 "Return true if PACKAGE is a GNU package. This procedure may access the
202network to check in GNU's database."
203 (define (mirror-type url)
204 (let ((uri (string->uri url)))
205 (and (eq? (uri-scheme uri) 'mirror)
206 (cond
207 ((member (uri-host uri)
208 '("gnu" "gnupg" "gcc" "gnome"))
209 ;; Definitely GNU.
210 'gnu)
211 ((equal? (uri-host uri) "cran")
212 ;; Possibly GNU: mirror://cran could be either GNU R itself
213 ;; or a non-GNU package.
214 #f)
215 (else
216 ;; Definitely non-GNU.
217 'non-gnu)))))
218
219 (define (gnu-home-page? package)
220 (letrec-syntax ((>> (syntax-rules ()
221 ((_ value proc)
222 (and=> value proc))
223 ((_ value proc rest ...)
224 (and=> value
225 (lambda (next)
226 (>> (proc next) rest ...)))))))
227 (>> package package-home-page
228 string->uri uri-host
229 (lambda (host)
230 (member host '("www.gnu.org" "gnu.org"))))))
231
232 (or (gnu-home-page? package)
233 (match (package-source package)
234 ((? origin? origin)
235 (let ((url (origin-uri origin))
236 (name (package-upstream-name package)))
237 (case (and (string? url) (mirror-type url))
238 ((gnu) #t)
239 ((non-gnu) #f)
240 (else
241 (and (member name (map gnu-package-name (official-gnu-packages*)))
242 #t)))))
243 (_ #f)))))
244
245
246;;;
247;;; Latest FTP release.
248;;;
249
250(define (ftp-server/directory package)
251 "Return the FTP server and directory where PACKAGE's tarball are stored."
252 (let ((name (package-upstream-name package)))
253 (values (or (assoc-ref (package-properties package) 'ftp-server)
254 "ftp.gnu.org")
255 (or (assoc-ref (package-properties package) 'ftp-directory)
256 (string-append "/gnu/" name)))))
257
258(define %tarball-rx
259 ;; The .zip extensions is notably used for freefont-ttf.
260 ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
261 ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
262 ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
263 ;; Accept 'v' or 'V' prefix as in 'PKG-v2.3.tgz'.
264 (make-regexp "^([^.]+)[-_][vV]?([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|tgz|zip$)"))
265
266(define %alpha-tarball-rx
267 (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
268
269(define (release-file? project file)
270 "Return true if FILE is a release tarball of PROJECT."
271 (and (not (member (file-extension file)
272 '("sig" "sign" "asc"
273 "md5sum" "sha1sum" "sha256sum")))
274 (and=> (regexp-exec %tarball-rx file)
275 (lambda (match)
276 ;; Filter out unrelated files, like `guile-www-1.1.1'.
277 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
278 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
279 ;; The '-everywhere-src' suffix is for Qt modular components.
280 (and=> (match:substring match 1)
281 (lambda (name)
282 (or (string-ci=? name project)
283 (string-ci=? name (string-append project "-src"))
284 (string-ci=?
285 name (string-append project "-everywhere-src"))
286 ;; For older Qt releases such as version 5.
287 (string-ci=?
288 name (string-append
289 project "-everywhere-opensource-src"))
290 ;; For Qt Creator.
291 (string-ci=?
292 name (string-append
293 project "-opensource-src")))))))
294 (not (regexp-exec %alpha-tarball-rx file))
295 (let ((s (tarball-sans-extension file)))
296 (regexp-exec %package-name-rx s))))
297
298(define (package-release-file? package file)
299 "Return true if FILE, a string like \"NPB2.3.tar.gz\", denotes a release
300file for PACKAGE."
301 (match (assoc-ref (package-properties package) 'release-file-regexp)
302 (#f
303 (release-file? (package-upstream-name package) file))
304 (str
305 (catch #t
306 (lambda ()
307 (string-match str file))
308 (lambda _
309 (warning (package-field-location package 'properties)
310 (G_ "~a: invalid 'release-file-regexp' property~%")
311 (package-full-name package))
312 #f)))))
313
314(define* (tarball->version tarball #:optional regexp)
315 "Return the version TARBALL corresponds to. TARBALL is a file name like
316\"coreutils-8.23.tar.xz\"."
317 (if regexp
318 (let ((match (string-match regexp tarball)))
319 (if (= 2 (match:count match))
320 (match:substring match 1)
321 (begin
322 (warning (N_ "release file regexp ~s has ~a subexpression\
323 (expected one for the version string)~%"
324 "release file regexp ~s has ~a subexpressions\
325 (expected one for the version string)~%"
326 (- (match:count match) 1))
327 regexp (- (match:count match) 1))
328 #f)))
329 (let-values (((name version)
330 (gnu-package-name->name+version
331 (tarball-sans-extension tarball))))
332 version)))
333
334(define* (releases project
335 #:key
336 (server "ftp.gnu.org")
337 (directory (string-append "/gnu/" project)))
338 "Return the list of <upstream-release> of PROJECT as a list of release
339name/directory pairs."
340 ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
341 (define conn (ftp-open server))
342
343 (let loop ((directories (list directory))
344 (result '()))
345 (match directories
346 (()
347 (ftp-close conn)
348 (coalesce-sources result))
349 ((directory rest ...)
350 (let* ((files (ftp-list conn directory))
351 (subdirs (filter-map (match-lambda
352 ((name 'directory . _) name)
353 (_ #f))
354 files)))
355 (define (file->url file)
356 (string-append "ftp://" server directory "/" file))
357
358 (define (file->source file)
359 (let ((url (file->url file)))
360 (upstream-source
361 (package project)
362 (version (tarball->version file))
363 (urls (list url))
364 (signature-urls (list (string-append url ".sig"))))))
365
366 (loop (append (map (cut string-append directory "/" <>)
367 subdirs)
368 rest)
369 (append
370 ;; Filter out signatures, deltas, and files which
371 ;; are potentially not releases of PROJECT--e.g.,
372 ;; in /gnu/guile, filter out guile-oops and
373 ;; guile-www; in mit-scheme, filter out binaries.
374 (filter-map (match-lambda
375 ((file 'file . _)
376 (and (release-file? project file)
377 (file->source file)))
378 (_ #f))
379 files)
380 result)))))))
381
382(define* (import-ftp-release project
383 #:key
384 version
385 partial-version?
386 (server "ftp.gnu.org")
387 (directory (string-append "/gnu/" project))
388 (file->signature (cut string-append <> ".sig")))
389 "Return an <upstream-source> for the latest release of PROJECT on SERVER
390under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
391specific version, which may be marked as partially specified via
392PARTIAL-VERSION?.
393
394Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be
395useful to reuse connections.
396
397FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
398return the corresponding signature URL, or #f it signatures are unavailable."
399 (define (latest a b)
400 (if (version>? a b) a b))
401
402 (define (latest-release a b)
403 (if (version>? (upstream-source-version a) (upstream-source-version b))
404 a b))
405
406 (define patch-directory-name?
407 ;; Return #t for patch directory names such as 'bash-4.2-patches'.
408 (cut string-suffix? "patches" <>))
409
410 (define conn (ftp-open server #:timeout 5))
411
412 (define (file->url directory file)
413 (string-append "ftp://" server directory "/" file))
414
415 (define (file->source directory file)
416 (let ((url (file->url directory file)))
417 (upstream-source
418 (package project)
419 (version (tarball->version file))
420 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
421 ;; URLs during "guix refresh -u".
422 (urls (list (uri-mirror-rewrite url)))
423 (signature-urls (match (file->signature url)
424 (#f #f)
425 (sig (list (uri-mirror-rewrite sig))))))))
426
427 (let loop ((directory directory)
428 (result #f))
429 (let* ((entries (catch 'ftp-error
430 (lambda _ (ftp-list conn directory))
431 (const '())))
432
433 ;; Filter out things like /gnupg/patches. Filter out "w32"
434 ;; directories as found on ftp.gnutls.org.
435 (subdirs (filter-map (match-lambda
436 (((? patch-directory-name? dir)
437 'directory . _)
438 #f)
439 (("w32" 'directory . _)
440 #f)
441 (("unstable" 'directory . _)
442 ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
443 #f)
444 ((directory 'directory . _)
445 directory)
446 (_ #f))
447 entries))
448
449 ;; Whether or not SUBDIRS is empty, compute the latest releases
450 ;; for the current directory. This is necessary for packages
451 ;; such as 'sharutils' that have a sub-directory that contains
452 ;; only an older release.
453 (releases (filter-map (match-lambda
454 ((file 'file . _)
455 (and (release-file? project file)
456 (file->source directory file)))
457 (_ #f))
458 entries))
459 (versions (map upstream-source-version releases))
460 (version (find-version versions version partial-version?)))
461
462 ;; Assume that SUBDIRS correspond to versions, and jump into the
463 ;; one with the highest version number.
464 (let* ((release (if version
465 (find (lambda (upstream)
466 (string=? (upstream-source-version upstream) version))
467 (coalesce-sources releases))
468 (reduce latest-release #f
469 (coalesce-sources releases))))
470 (result (if (and result release)
471 (latest-release release result)
472 (or release result)))
473 (target (reduce latest #f subdirs)))
474 (if target
475 (loop (string-append directory "/" target)
476 result)
477 (begin
478 (ftp-close conn)
479 result))))))
480
481(define* (import-release package
482 #:key
483 version
484 partial-version?
485 (server "ftp.gnu.org")
486 (directory (string-append "/gnu/" package)))
487 "Return the <upstream-source> for the latest version of PACKAGE or #f.
488PACKAGE must be the canonical name of a GNU package. Optionally include a
489VERSION string to fetch a specific version, which may be marked as partially
490specified via PARTIAL-VERSION?."
491 (import-ftp-release package
492 #:version version
493 #:partial-version? partial-version?
494 #:server server
495 #:directory directory))
496
497(define-syntax-rule (false-if-ftp-error exp)
498 "Return #f if an FTP error is raise while evaluating EXP; return the result
499of EXP otherwise."
500 (catch 'ftp-error
501 (lambda ()
502 exp)
503 (lambda (key port . rest)
504 (if (ftp-connection? port)
505 (ftp-close port)
506 (close-port port))
507 #f)))
508
509(define* (import-release* package #:key version partial-version?)
510 "Like 'import-release', but (1) take a <package> object, and (2) ignore FTP
511errors that might occur when PACKAGE is not actually a GNU package, or not
512hosted on ftp.gnu.org, or not under that name (this is the case for
513\"emacs-auctex\", for instance.)"
514 (let-values (((server directory)
515 (ftp-server/directory package)))
516 (false-if-networking-error
517 (false-if-ftp-error
518 (import-release (package-upstream-name package)
519 #:version version
520 #:partial-version? partial-version?
521 #:server server
522 #:directory directory)))))
523
524
525;;;
526;;; Latest HTTP release.
527;;;
528
529(define (html-links sxml)
530 "Return the list of links found in SXML, the SXML tree of an HTML page."
531 (define-values (links base)
532 (let loop ((sxml sxml)
533 (links '())
534 (base #f))
535 (match sxml
536 (('a ('@ attributes ...) body ...)
537 (match (assq 'href attributes)
538 (#f (fold2 loop links base body))
539 (('href url) (fold2 loop (cons url links) base body))))
540 (('base ('@ ('href new-base)))
541 ;; The base against which relative URL paths must be resolved.
542 (values links new-base))
543 ((tag ('@ _ ...) body ...)
544 (fold2 loop links base body))
545 ((tag body ...)
546 (fold2 loop links base body))
547 (_
548 (values links base)))))
549
550 (if base
551 (map (lambda (link)
552 (let ((uri (string->uri link)))
553 (if (or uri (string-prefix? "/" link))
554 link
555 (in-vicinity base link))))
556 links)
557 links))
558
559(define (url->links url)
560 "Return the unique links on the HTML page accessible at URL."
561 (guard (c ((http-get-error? c)
562 (warning (G_ "failed to download '~a': ~a (~a)~%")
563 url (http-get-error-code c)
564 (http-get-error-reason c))
565 '()))
566 (let* ((uri (string->uri url))
567 (port (http-fetch/cached uri #:ttl 3600))
568 (sxml (html->sxml port)))
569 (close-port port)
570 (delete-duplicates (html-links sxml)))))
571
572(define (canonicalize-url url base-url)
573 "Make relative URL absolute, by appending URL to BASE-URL as required. If
574URL is a directory instead of a file, it should be suffixed with a slash (/)."
575 (cond ((and=> (string->uri url) uri-scheme)
576 ;; Fully specified URL.
577 url)
578 ((string-prefix? "//" url)
579 ;; Full URL lacking a URI scheme. Reuse the URI scheme of the
580 ;; document that contains the URL.
581 (string-append (symbol->string (uri-scheme (string->uri base-url)))
582 ":" url))
583 ((string-prefix? "/" url)
584 ;; Absolute URL.
585 (let ((uri (string->uri base-url)))
586 (uri->string
587 (build-uri (uri-scheme uri)
588 #:host (uri-host uri)
589 #:port (uri-port uri)
590 #:path url))))
591 ;; URL is relative to BASE-URL, which is assumed to be a directory.
592 ((string-suffix? "/" base-url)
593 (string-append base-url url))
594 (else
595 ;; URL is relative to BASE-URL, which is assumed to denote a file
596 ;; within a directory.
597 (string-append (dirname base-url) "/" url))))
598
599(define (strip-trailing-slash s)
600 "Strip any trailing slash from S, a string."
601 (if (string-suffix? "/" s)
602 (string-drop-right s 1)
603 s))
604
605;;; TODO: Extend to support the RPM and GNOME version schemes?
606(define %version-rx "[0-9.]+")
607
608(define* (rewrite-url url version #:key to-version partial-version?)
609 "Rewrite URL so that the URL path components matching the current VERSION or
610VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
611by crawling the corresponding URL directories. Alternatively, when TO-VERSION
612is specified, rewrite version matches directly to it without crawling URL. If
613TO-VERSION is provided and PARTIAL-VERSION? set to #t, then crawl URL to find
614the newest compatible release (one that is prefixed by TO-VERSION).
615
616For example, the URL
617\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
618rewritten to something like
619\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\".
620
621With TO-VERSION set to \"1.49\" and PARTIAL-VERSION? set to #t, the URL
622\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
623rewritten to something like
624\"https://dist.libuv.org/dist/v1.49.2/libuv-v1.49.2.tar.gz\"."
625 ;; XXX: major-minor may be #f if version is not a triplet but a single
626 ;; number such as "2".
627 (let* ((major-minor (false-if-exception (version-major+minor version)))
628 (to-major-minor (false-if-exception
629 (and=> to-version version-major+minor)))
630 (uri (string->uri url))
631 (url-prefix (string-drop-right url (string-length (uri-path uri))))
632 (url-prefix-components (string-split url-prefix #\/))
633 (path (uri-path uri))
634 ;; Strip a forward slash on the path to avoid a double slash when
635 ;; string-joining later.
636 (path (if (string-prefix? "/" path)
637 (string-drop path 1)
638 path))
639 (path-components (string-split path #\/)))
640 (string-join
641 (reverse
642 (fold
643 (lambda (s parents)
644 (if (and to-version (not partial-version?))
645 ;; Direct rewrite case; the archive is assumed to exist.
646 (let ((u (string-replace-substring s version to-version)))
647 (cons (if (and major-minor to-major-minor)
648 (string-replace-substring u major-minor to-major-minor)
649 u)
650 parents))
651 ;; More involved HTML crawl case to get the latest version or a
652 ;; partial to-version.
653 (let* ((pattern (if major-minor
654 (format #f "(~a|~a)"
655 (regexp-quote version)
656 (regexp-quote major-minor))
657 (format #f "(~a)" (regexp-quote version))))
658 (m (string-match pattern s)))
659 (if m
660 ;; Crawl parent and rewrite current component.
661 (let* ((parent-url (string-join (reverse parents) "/"))
662 (links (url->links parent-url))
663 ;; The pattern matching the version.
664 (pattern (string-append "^" (regexp-quote
665 (match:prefix m))
666 "(" %version-rx ")"
667 (match:suffix m) "$"))
668 (candidates (filter-map
669 (lambda (l)
670 ;; Links may be followed by a
671 ;; trailing '/' in the case of
672 ;; directories.
673 (and-let*
674 ((l (strip-trailing-slash l))
675 (m (string-match pattern l))
676 (v (match:substring m 1)))
677 (cons v l)))
678 links))
679 (versions (map car candidates))
680 (version (find-version versions to-version
681 partial-version?)))
682 ;; Retrieve the item having the greatest version.
683 (if version
684 (cons (assoc-ref candidates version) parents)
685 parents)) ;XXX: bogus case; throw an error?
686 ;; No version found in path component; continue.
687 (cons s parents)))))
688 (reverse url-prefix-components)
689 path-components))
690 "/")))
691
692(define* (import-html-release base-url package
693 #:key
694 rewrite-url?
695 version
696 partial-version?
697 (directory (string-append
698 "/" (package-upstream-name package)))
699 file->signature)
700 "Return an <upstream-source> for the latest release of PACKAGE under
701DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to fetch a
702specific version, which may be marked as partially specified via
703PARTIAL-VERSION?.
704
705BASE-URL should be the URL of an HTML page, typically a directory listing as
706found on 'https://kernel.org/pub'.
707
708When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
709if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
710file URL and must return the corresponding signature URL, or #f it signatures
711are unavailable.
712
713When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
714also updated to the latest version, as explained in the doc of the
715\"rewrite-url\" procedure used."
716 (let* ((current-version (package-version package))
717 (name (package-upstream-name package))
718 (url (if (string-null? directory)
719 base-url
720 (string-append base-url directory
721 ;; Ensure URL ends with a trailing slash.
722 (if (string-suffix? "/" directory)
723 ""
724 "/"))))
725 (url (if rewrite-url?
726 (rewrite-url url current-version #:to-version version
727 #:partial-version? partial-version?)
728 url))
729 (links (map (cut canonicalize-url <> url) (url->links url))))
730
731 (define (file->signature/guess url)
732 "Return the first link that matches a signature extension, else #f."
733 (let ((base (basename url)))
734 (any (lambda (link)
735 (any (lambda (extension)
736 (and (string=? (string-append base extension)
737 (basename link))
738 (string-append url extension)))
739 '(".asc" ".sig" ".sign")))
740 links)))
741
742 (define (url->release url)
743 "Return an <upstream-source> object if a release file was found at URL,
744else #f. URL is assumed to fully specified."
745 (let ((base (basename url)))
746 (and (package-release-file? package base)
747 (let ((version (tarball->version
748 base
749 (assoc-ref (package-properties package)
750 'release-file-regexp))))
751 (upstream-source
752 (package name)
753 (version version)
754 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
755 ;; URLs during "guix refresh -u".
756 (urls (list (uri-mirror-rewrite url)))
757 (signature-urls
758 (and=> ((or file->signature file->signature/guess) url)
759 (lambda (url) (list (uri-mirror-rewrite url))))))))))
760
761 (define candidates
762 (coalesce-sources (filter-map url->release links)))
763
764 (define versions
765 (map upstream-source-version candidates))
766
767 (define new-version
768 (find-version versions version partial-version?))
769
770 (and new-version
771 (find (compose (cut string=? new-version <>)
772 upstream-source-version)
773 candidates))))
774
775
776;;;
777;;; Updaters.
778;;;
779
780(define %gnu-file-list-uri
781 ;; URI of the file list for ftp.gnu.org.
782 (string->uri "https://ftp.gnu.org/find.txt.gz"))
783
784(define ftp.gnu.org-files
785 (mlambda ()
786 "Return the list of files available at ftp.gnu.org."
787
788 ;; XXX: Memoize the whole procedure to work around the fact that
789 ;; 'http-fetch/cached' caches the gzipped version.
790
791 (define (trim-leading-components str)
792 ;; Trim the leading ".", if any, in "./gnu/foo".
793 (string-trim str (char-set #\.)))
794
795 (define (string->lines str)
796 (string-tokenize str (char-set-complement (char-set #\newline))))
797
798 ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
799 ;; TTL can be relatively short.
800 (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
801 (map trim-leading-components
802 (call-with-gzip-input-port port
803 (compose string->lines get-string-all))))))
804
805(define* (import-gnu-release package #:key version partial-version?)
806 "Return the latest release of PACKAGE, a GNU package available via
807ftp.gnu.org. Optionally include a VERSION string to fetch a specific version.
808
809This method does not rely on FTP access at all; instead, it browses the file
810list available from %GNU-FILE-LIST-URI over HTTP(S)."
811 (define archive-type
812 (package-archive-type package))
813
814 (define (better-tarball? tarball1 tarball2)
815 (string=? (file-extension tarball1) archive-type))
816
817 (define (find-latest-tarball-version tarballs)
818 (fold (lambda (file1 file2)
819 (if (and file2
820 (version>? (tarball-sans-extension (basename file2))
821 (tarball-sans-extension (basename file1))))
822 file2
823 file1))
824 #f
825 tarballs))
826
827 (let-values (((server directory)
828 (ftp-server/directory package))
829 ((name)
830 (package-upstream-name package)))
831 (let* ((files (ftp.gnu.org-files))
832 ;; select tarballs for this package
833 (relevant (filter (lambda (file)
834 (and (string-prefix? "/gnu" file)
835 (string-contains file directory)
836 (release-file? name (basename file))))
837 files))
838 (versions (delay (sort (delete-duplicates
839 (map tarball->version relevant))
840 version>?)))
841 (version (or (and version partial-version?
842 (find (cut version-prefix? version <>)
843 (force versions)))
844 version
845 (match (force versions)
846 ((? null?) #f)
847 (lst (first lst)))))
848 ;; Find tarballs matching this version.
849 (tarballs (filter (lambda (file)
850 (string=? version (tarball->version file)))
851 relevant)))
852 (match tarballs
853 (() #f)
854 (_
855 (upstream-source
856 (package name)
857 (version version)
858 (urls (map (lambda (file)
859 (string-append "mirror://gnu/"
860 (string-drop file
861 (string-length "/gnu/"))))
862 ;; Sort so that the tarball with the same compression
863 ;; format as currently used in PACKAGE comes first.
864 (sort tarballs better-tarball?)))
865 (signature-urls (map (cut string-append <> ".sig") urls))))))))
866
867(define %package-name-rx
868 ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
869 ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
870 (make-regexp "^(.*)[-_][vV]?(([0-9]|\\.)+)(-src|\\.src|\\.orig)?"))
871
872(define (gnu-package-name->name+version name+version)
873 "Return the package name and version number extracted from NAME+VERSION."
874 (let ((match (regexp-exec %package-name-rx name+version)))
875 (if (not match)
876 (values name+version #f)
877 (values (match:substring match 1) (match:substring match 2)))))
878
879(define gnome-package?
880 (url-prefix-predicate "mirror://gnome/"))
881
882(define (pure-gnu-package? package)
883 "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
884excludes AucTeX, for instance, whose releases are now uploaded to
885elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
886GNOME packages; EMMS is included though, because its releases are on gnu.org."
887 (and (or (not (string-prefix? "emacs-" (package-name package)))
888 (gnu-hosted? package))
889 (not (gnome-package? package))
890 (not (string-prefix? "gnuradio" (package-name package)))
891 (gnu-package? package)))
892
893(define gnu-hosted?
894 (url-prefix-predicate "mirror://gnu/"))
895
896(define (uri-mirror-rewrite uri)
897 "Rewrite URI to a mirror:// URI if possible, or return URI unmodified."
898 (if (string-prefix? "mirror://" uri)
899 uri ;nothing to do, it's already a mirror URI
900 (let loop ((mirrors %mirrors))
901 (match mirrors
902 (()
903 uri)
904 (((mirror-id mirror-urls ...) rest ...)
905 (match (find (cut string-prefix? <> uri) mirror-urls)
906 (#f
907 (loop rest))
908 (prefix
909 (format #f "mirror://~a/~a"
910 mirror-id
911 (string-drop uri (string-length prefix))))))))))
912
913(define %savannah-base
914 ;; Primary Savannah release page.
915 "https://download.savannah.gnu.org/releases")
916
917(define* (import-savannah-release package #:key version partial-version?)
918 "Return the latest release of PACKAGE. Optionally include a VERSION string
919to fetch a specific version, which may be partially provided when
920PARTIAL-VERSION? is #t."
921 (let* ((uri (string->uri
922 (match (origin-uri (package-source package))
923 ((? string? uri) uri)
924 ((uri mirrors ...) uri))))
925 (directory (dirname (uri-path uri))))
926 ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
927 ;; or whichever detached signature naming scheme PACKAGE uses.
928 (import-html-release %savannah-base package
929 #:version version
930 #:partial-version? partial-version?
931 #:directory directory)))
932
933(define* (latest-sourceforge-release package #:key version partial-version?)
934 "Return the latest release of PACKAGE. Optionally include a VERSION string
935to fetch a specific version."
936 (define (uri-append uri extension)
937 ;; Return URI with EXTENSION appended.
938 (build-uri (uri-scheme uri)
939 #:host (uri-host uri)
940 #:path (string-append (uri-path uri) extension)))
941
942 (define (valid-uri? uri port)
943 ;; Return true if URI is reachable.
944 (false-if-exception
945 (case (response-code (http-head uri #:port port #:keep-alive? #t))
946 ((200 302) #t)
947 (else #f))))
948
949 (when version
950 (leave
951 (G_ "updating to a specific version is not yet implemented for SourceForge~%")))
952
953 (when partial-version?
954 (leave
955 (G_ "updating to a partial version is not yet implemented for SourceForge~%")))
956
957 (let* ((name (package-upstream-name package))
958 (base (string-append "https://sourceforge.net/projects/"
959 name "/files"))
960 (url (string-append base "/latest/download"))
961 (uri (string->uri url))
962 (port (false-if-exception (open-socket-for-uri uri)))
963 (response (and port
964 (http-head uri #:port port #:keep-alive? #t))))
965 (dynamic-wind
966 (const #t)
967 (lambda ()
968 (and response
969 (= 302 (response-code response))
970 (response-location response)
971 (match (string-tokenize (uri-path (response-location response))
972 (char-set-complement (char-set #\/)))
973 ((_ components ...)
974 (let* ((path (string-join components "/"))
975 (url (string-append "mirror://sourceforge/" path)))
976 (and (release-file? name (basename path))
977
978 ;; Take the heavy-handed approach of probing 3 additional
979 ;; URLs. XXX: Would be nicer if this could be avoided.
980 (let* ((loc (response-location response))
981 (sig (any (lambda (extension)
982 (let ((uri (uri-append loc extension)))
983 (and (valid-uri? uri port)
984 (string-append url extension))))
985 '(".asc" ".sig" ".sign"))))
986 (upstream-source
987 (package name)
988 (version (tarball->version (basename path)))
989 (urls (list url))
990 (signature-urls (and sig (list sig)))))))))))
991 (lambda ()
992 (when port
993 (close-port port))))))
994
995(define* (import-xorg-release package #:key version partial-version?)
996 "Return the latest release of PACKAGE. Optionally include a VERSION string
997to fetch a specific version, which may be partially provided when
998PARTIAL-VERSION? is #t."
999 (let ((uri (string->uri (origin-uri (package-source package)))))
1000 (false-if-networking-error
1001 (false-if-ftp-error
1002 (import-ftp-release
1003 (package-name package)
1004 #:version version
1005 #:partial-version? partial-version?
1006 #:server "ftp.freedesktop.org"
1007 #:directory
1008 (string-append "/pub/xorg/" (dirname (uri-path uri))))))))
1009
1010(define* (import-kernel.org-release package #:key version partial-version?)
1011 "Return the latest release of PACKAGE, a Linux kernel package.
1012Optionally include a VERSION string to fetch a specific version, which may be
1013partially provided when PARTIAL-VERSION? is #t."
1014 (define %kernel.org-base
1015 ;; This URL and sub-directories thereof are nginx-generated directory
1016 ;; listings suitable for 'import-html-release'.
1017 "https://mirrors.edge.kernel.org/pub")
1018
1019 (define (file->signature file)
1020 (string-append (file-sans-extension file) ".sign"))
1021
1022 (let* ((uri (string->uri
1023 (match (origin-uri (package-source package))
1024 ((? string? uri) uri)
1025 ((uri mirrors ...) uri))))
1026 (directory (dirname (uri-path uri))))
1027 (import-html-release %kernel.org-base package
1028 #:version version
1029 #:partial-version? partial-version?
1030 #:directory directory
1031 #:file->signature file->signature)))
1032
1033;;; These sites are disallowed for the generic HTML updater as there are
1034;;; better means to query them.
1035(define %disallowed-hosting-sites
1036 '("github.com" "github.io" "gitlab.com"
1037 "notabug.org" "sr.ht" "gitlab.inria.fr"
1038 "ftp.gnu.org" "download.savannah.gnu.org"
1039 "pypi.org" "crates.io" "rubygems.org"
1040 "bioconductor.org"))
1041
1042(define (http-url? url)
1043 "Return URL if URL has HTTP or HTTPS as its protocol. If URL uses the
1044special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
1045prefix from its set."
1046 (match (string->uri url)
1047 (#f #f)
1048 (uri
1049 (let ((scheme (uri-scheme uri))
1050 (host (uri-host uri)))
1051 (or (and (memq scheme '(http https))
1052 ;; HOST may contain prefixes, e.g. "profanity-im.github.io",
1053 ;; hence the suffix-based test below.
1054 (not (any (cut string-suffix? <> host)
1055 %disallowed-hosting-sites))
1056 url)
1057 (and (eq? scheme 'mirror)
1058 (and=> (find http-url?
1059 (assoc-ref %mirrors
1060 (string->symbol host)))
1061 (lambda (url)
1062 (string-append (strip-trailing-slash url)
1063 (uri-path uri))))))))))
1064
1065(define (html-updatable-package? package)
1066 "Return true if the given package may be handled by the generic HTML
1067updater."
1068 (or (assoc-ref (package-properties package) 'release-monitoring-url)
1069 ((url-predicate http-url?) package)))
1070
1071(define* (import-html-updatable-release package #:key version partial-version?)
1072 "Return the latest release of PACKAGE else #f. Do that by crawling the HTML
1073page of the directory containing its source tarball. Optionally include a
1074VERSION string to fetch a specific version; which may be partially provided
1075when PARTIAL-VERSION? is #t."
1076 (define (expand-uri uri)
1077 (match uri
1078 ((and (? string?) (? (cut string-prefix? "mirror://" <>) url))
1079 ;; Retrieve the authoritative HTTP URL from a mirror.
1080 (http-url? url))
1081 ((? string? url)
1082 url)
1083 ((url _ ...)
1084 ;; This case is for when the URI is a list of possibly
1085 ;; mirror URLs as well as HTTP URLs.
1086 (expand-uri url))))
1087
1088 (let* ((uri (string->uri
1089 (expand-uri (origin-uri (package-source package)))))
1090 (custom (assoc-ref (package-properties package)
1091 'release-monitoring-url))
1092 (base (or custom
1093 (string-append (symbol->string (uri-scheme uri))
1094 "://" (uri-host uri))))
1095 (directory (if custom
1096 ""
1097 (dirname (uri-path uri)))))
1098 (false-if-networking-error
1099 (import-html-release base package
1100 #:rewrite-url? #t
1101 #:version version
1102 #:partial-version? partial-version?
1103 #:directory directory))))
1104
1105(define %gnu-updater
1106 ;; This is for everything at ftp.gnu.org.
1107 (upstream-updater
1108 (name 'gnu)
1109 (description "Updater for GNU packages")
1110 (pred (lambda (package)
1111 (false-if-networking-error (gnu-hosted? package))))
1112 (import import-gnu-release)))
1113
1114(define gnupg-hosted?
1115 (url-prefix-predicate "mirror://gnupg/"))
1116
1117(define %gnu-ftp-updater
1118 ;; This is for GNU packages taken from alternate locations, such as
1119 ;; alpha.gnu.org (ftp.gnupg.org is no longer available). It is obsolescent.
1120 (upstream-updater
1121 (name 'gnu-ftp)
1122 (description "Updater for GNU packages only available via FTP")
1123 (pred (lambda (package)
1124 (false-if-networking-error
1125 (and (not (gnu-hosted? package))
1126 (not (gnupg-hosted? package))
1127 (pure-gnu-package? package)))))
1128 (import import-release*)))
1129
1130(define %savannah-updater
1131 (upstream-updater
1132 (name 'savannah)
1133 (description "Updater for packages hosted on savannah.gnu.org")
1134 (pred (url-prefix-predicate "mirror://savannah/"))
1135 (import import-savannah-release)))
1136
1137(define %sourceforge-updater
1138 (upstream-updater
1139 (name 'sourceforge)
1140 (description "Updater for packages hosted on sourceforge.net")
1141 (pred (url-prefix-predicate "mirror://sourceforge/"))
1142 (import latest-sourceforge-release)))
1143
1144(define %xorg-updater
1145 (upstream-updater
1146 (name 'xorg)
1147 (description "Updater for X.org packages")
1148 (pred (url-prefix-predicate "mirror://xorg/"))
1149 (import import-xorg-release)))
1150
1151(define %kernel.org-updater
1152 (upstream-updater
1153 (name 'kernel.org)
1154 (description "Updater for packages hosted on kernel.org")
1155 (pred (url-prefix-predicate "mirror://kernel.org/"))
1156 (import import-kernel.org-release)))
1157
1158(define %generic-html-updater
1159 (upstream-updater
1160 (name 'generic-html)
1161 (description "Updater that crawls HTML pages.")
1162 (pred html-updatable-package?)
1163 (import import-html-updatable-release)))
1164
1165;;; gnu-maintenance.scm ends here