Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
db69ebb9 | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
f9bbf2a8 | 3 | ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> |
be84fc60 | 4 | ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> |
22189ed1 | 5 | ;;; |
233e7676 | 6 | ;;; This file is part of GNU Guix. |
22189ed1 | 7 | ;;; |
233e7676 | 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
22189ed1 NK |
9 | ;;; under the terms of the GNU General Public License as published by |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
233e7676 | 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
22189ed1 NK |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
22189ed1 NK |
20 | |
21 | (define-module (guix gnu-maintenance) | |
22 | #:use-module (web uri) | |
23 | #:use-module (web client) | |
24 | #:use-module (web response) | |
5230dce1 | 25 | #:use-module (sxml simple) |
22189ed1 | 26 | #:use-module (ice-9 regex) |
98fefb21 | 27 | #:use-module (ice-9 match) |
22189ed1 NK |
28 | #:use-module (srfi srfi-1) |
29 | #:use-module (srfi srfi-11) | |
30 | #:use-module (srfi srfi-26) | |
af9af218 | 31 | #:use-module (srfi srfi-34) |
100b216d | 32 | #:use-module (rnrs io ports) |
98fefb21 | 33 | #:use-module (system foreign) |
eb6ac483 | 34 | #:use-module ((guix http-client) #:hide (open-socket-for-uri)) |
98fefb21 | 35 | #:use-module (guix ftp-client) |
0d1e6ce4 | 36 | #:use-module (guix utils) |
f9704f17 | 37 | #:use-module (guix memoization) |
c0cd1b3e | 38 | #:use-module (guix records) |
0a7c5a09 | 39 | #:use-module (guix upstream) |
ef010c0f | 40 | #:use-module (guix packages) |
8ff958f5 | 41 | #:autoload (zlib) (call-with-gzip-input-port) |
71f6acd2 | 42 | #:autoload (htmlprag) (html->sxml) ;from Guile-Lib |
f9bbf2a8 NK |
43 | #:export (gnu-package-name |
44 | gnu-package-mundane-name | |
45 | gnu-package-copyright-holder | |
46 | gnu-package-savannah | |
47 | gnu-package-fsd | |
48 | gnu-package-language | |
49 | gnu-package-logo | |
50 | gnu-package-doc-category | |
51 | gnu-package-doc-summary | |
c4ca9411 | 52 | gnu-package-doc-description |
f9bbf2a8 NK |
53 | gnu-package-doc-urls |
54 | gnu-package-download-url | |
55 | ||
56 | official-gnu-packages | |
dc794a72 | 57 | find-package |
ef010c0f | 58 | gnu-package? |
f9bbf2a8 | 59 | |
202440e0 | 60 | release-file? |
98fefb21 LC |
61 | releases |
62 | latest-release | |
7047133f | 63 | gnu-release-archive-types |
0fdd3bea | 64 | gnu-package-name->name+version |
7047133f | 65 | |
e80c0f85 | 66 | %gnu-updater |
100b216d | 67 | %gnu-ftp-updater |
7a6bb2fe | 68 | %savannah-updater |
b92cfc32 | 69 | %sourceforge-updater |
2fd370e8 | 70 | %xorg-updater |
af9af218 LC |
71 | %kernel.org-updater |
72 | %generic-html-updater)) | |
98fefb21 LC |
73 | |
74 | ;;; Commentary: | |
75 | ;;; | |
76 | ;;; Code for dealing with the maintenance of GNU packages, such as | |
77 | ;;; auto-updates. | |
78 | ;;; | |
79 | ;;; Code: | |
80 | ||
81 | \f | |
82 | ;;; | |
83 | ;;; List of GNU packages. | |
84 | ;;; | |
22189ed1 | 85 | |
129f9e11 | 86 | (define %gnumaint-base-url |
637a2a23 | 87 | "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/") |
129f9e11 | 88 | |
22189ed1 | 89 | (define %package-list-url |
1c9e7d65 | 90 | (string->uri |
daf76c7c | 91 | (string-append %gnumaint-base-url "rec/gnupackages.rec"))) |
22189ed1 | 92 | |
129f9e11 LC |
93 | (define %package-description-url |
94 | ;; This file contains package descriptions in recutils format. | |
daf76c7c LC |
95 | ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html> |
96 | ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>. | |
129f9e11 | 97 | (string->uri |
daf76c7c | 98 | (string-append %gnumaint-base-url "rec/pkgblurbs.rec"))) |
c4ca9411 | 99 | |
f9bbf2a8 NK |
100 | (define-record-type* <gnu-package-descriptor> |
101 | gnu-package-descriptor | |
102 | make-gnu-package-descriptor | |
103 | ||
104 | gnu-package-descriptor? | |
105 | ||
106 | (name gnu-package-name) | |
107 | (mundane-name gnu-package-mundane-name) | |
108 | (copyright-holder gnu-package-copyright-holder) | |
109 | (savannah gnu-package-savannah) | |
110 | (fsd gnu-package-fsd) | |
b0efe83a | 111 | (language gnu-package-language) ; list of strings |
f9bbf2a8 NK |
112 | (logo gnu-package-logo) |
113 | (doc-category gnu-package-doc-category) | |
114 | (doc-summary gnu-package-doc-summary) | |
129f9e11 | 115 | (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt' |
b0efe83a | 116 | (doc-urls gnu-package-doc-urls) ; list of strings |
f9bbf2a8 NK |
117 | (download-url gnu-package-download-url)) |
118 | ||
9aec35d2 LC |
119 | (define* (official-gnu-packages |
120 | #:optional (fetch http-fetch/cached)) | |
121 | "Return a list of records, which are GNU packages. Use FETCH, | |
122 | to fetch the list of GNU packages over HTTP." | |
c4ca9411 | 123 | (define (read-records port) |
f9bbf2a8 NK |
124 | ;; Return a list of alists. Each alist contains fields of a GNU |
125 | ;; package. | |
b0efe83a LC |
126 | (let loop ((alist (recutils->alist port)) |
127 | (result '())) | |
128 | (if (null? alist) | |
c4ca9411 | 129 | (reverse result) |
b0efe83a | 130 | (loop (recutils->alist port) |
daf76c7c LC |
131 | |
132 | ;; Ignore things like "%rec" (info "(recutils) Record | |
133 | ;; Descriptors"). | |
134 | (if (assoc-ref alist "package") | |
135 | (cons alist result) | |
136 | result))))) | |
f9bbf2a8 | 137 | |
129f9e11 | 138 | (define official-description |
9aec35d2 | 139 | (let ((db (read-records (fetch %package-description-url #:text? #t)))) |
c4ca9411 | 140 | (lambda (name) |
129f9e11 | 141 | ;; Return the description found upstream for package NAME, or #f. |
c4ca9411 | 142 | (and=> (find (lambda (alist) |
129f9e11 LC |
143 | (equal? name (assoc-ref alist "package"))) |
144 | db) | |
4d5f0bae LC |
145 | (lambda (record) |
146 | (let ((field (assoc-ref record "blurb"))) | |
147 | ;; The upstream description file uses "redirect PACKAGE" as | |
148 | ;; a blurb in cases where the description of the two | |
149 | ;; packages should be considered the same (e.g., GTK+ has | |
150 | ;; "redirect gnome".) This is usually not acceptable for | |
151 | ;; us because we prefer to have distinct descriptions in | |
152 | ;; such cases. Thus, ignore the 'blurb' field when that | |
153 | ;; happens. | |
154 | (and field | |
155 | (not (string-prefix? "redirect " field)) | |
156 | field))))))) | |
c4ca9411 LC |
157 | |
158 | (map (lambda (alist) | |
159 | (let ((name (assoc-ref alist "package"))) | |
129f9e11 | 160 | (alist->record `(("description" . ,(official-description name)) |
c4ca9411 LC |
161 | ,@alist) |
162 | make-gnu-package-descriptor | |
daf76c7c | 163 | (list "package" "mundane_name" "copyright_holder" |
c4ca9411 | 164 | "savannah" "fsd" "language" "logo" |
daf76c7c LC |
165 | "doc_category" "doc_summary" "description" |
166 | "doc_url" | |
167 | "download_url") | |
168 | '("doc_url" "language")))) | |
2134228a LC |
169 | (let* ((port (fetch %package-list-url #:text? #t)) |
170 | (lst (read-records port))) | |
171 | (close-port port) | |
172 | lst))) | |
22189ed1 | 173 | |
dc794a72 LC |
174 | (define (find-package name) |
175 | "Find GNU package called NAME and return it. Return #f if it was not | |
176 | found." | |
177 | (find (lambda (package) | |
178 | (string=? name (gnu-package-name package))) | |
179 | (official-gnu-packages))) | |
ef010c0f LC |
180 | |
181 | (define gnu-package? | |
55b2d921 | 182 | (let ((official-gnu-packages (memoize official-gnu-packages))) |
3d520b54 | 183 | (mlambdaq (package) |
55b2d921 | 184 | "Return true if PACKAGE is a GNU package. This procedure may access the |
ef010c0f | 185 | network to check in GNU's database." |
55b2d921 LC |
186 | (define (mirror-type url) |
187 | (let ((uri (string->uri url))) | |
188 | (and (eq? (uri-scheme uri) 'mirror) | |
189 | (cond | |
190 | ((member (uri-host uri) | |
191 | '("gnu" "gnupg" "gcc" "gnome")) | |
192 | ;; Definitely GNU. | |
193 | 'gnu) | |
194 | ((equal? (uri-host uri) "cran") | |
195 | ;; Possibly GNU: mirror://cran could be either GNU R itself | |
196 | ;; or a non-GNU package. | |
197 | #f) | |
198 | (else | |
199 | ;; Definitely non-GNU. | |
200 | 'non-gnu))))) | |
201 | ||
202 | (define (gnu-home-page? package) | |
203 | (letrec-syntax ((>> (syntax-rules () | |
204 | ((_ value proc) | |
205 | (and=> value proc)) | |
206 | ((_ value proc rest ...) | |
207 | (and=> value | |
208 | (lambda (next) | |
209 | (>> (proc next) rest ...))))))) | |
210 | (>> package package-home-page | |
211 | string->uri uri-host | |
212 | (lambda (host) | |
213 | (member host '("www.gnu.org" "gnu.org")))))) | |
214 | ||
215 | (or (gnu-home-page? package) | |
f54cbc0e LC |
216 | (match (package-source package) |
217 | ((? origin? origin) | |
218 | (let ((url (origin-uri origin)) | |
219 | (name (package-upstream-name package))) | |
220 | (case (and (string? url) (mirror-type url)) | |
221 | ((gnu) #t) | |
222 | ((non-gnu) #f) | |
223 | (else | |
224 | (and (member name (map gnu-package-name (official-gnu-packages))) | |
225 | #t))))) | |
226 | (_ #f)))))) | |
ef010c0f | 227 | |
98fefb21 LC |
228 | \f |
229 | ;;; | |
5230dce1 | 230 | ;;; Latest FTP release. |
98fefb21 LC |
231 | ;;; |
232 | ||
63e8bb12 LC |
233 | (define (ftp-server/directory package) |
234 | "Return the FTP server and directory where PACKAGE's tarball are stored." | |
3b0fcc67 | 235 | (let ((name (package-upstream-name package))) |
b03218d5 LC |
236 | (values (or (assoc-ref (package-properties package) 'ftp-server) |
237 | "ftp.gnu.org") | |
238 | (or (assoc-ref (package-properties package) 'ftp-directory) | |
239 | (string-append "/gnu/" name))))) | |
98fefb21 | 240 | |
d55a99fe | 241 | (define %tarball-rx |
f00dccf4 LC |
242 | ;; The .zip extensions is notably used for freefont-ttf. |
243 | ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". | |
244 | ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2". | |
1710e8cb | 245 | ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages. |
1575da60 | 246 | (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|zip$)")) |
d55a99fe LC |
247 | |
248 | (define %alpha-tarball-rx | |
07a0be80 | 249 | (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) |
d55a99fe | 250 | |
501d7647 | 251 | (define (release-file? project file) |
cac137aa | 252 | "Return #f if FILE is not a release tarball of PROJECT, otherwise return |
501d7647 | 253 | true." |
9e75b31b LC |
254 | (and (not (member (file-extension file) |
255 | '("sig" "sign" "asc" | |
256 | "md5sum" "sha1sum" "sha256sum"))) | |
d55a99fe LC |
257 | (and=> (regexp-exec %tarball-rx file) |
258 | (lambda (match) | |
259 | ;; Filter out unrelated files, like `guile-www-1.1.1'. | |
fa04a04f | 260 | ;; Case-insensitive for things like "TeXmacs" vs. "texmacs". |
444bb0d8 | 261 | ;; The "-src" suffix is for "freefont-src-20120503.tar.gz". |
fa04a04f LC |
262 | (and=> (match:substring match 1) |
263 | (lambda (name) | |
444bb0d8 LC |
264 | (or (string-ci=? name project) |
265 | (string-ci=? name | |
266 | (string-append project | |
267 | "-src"))))))) | |
cac137aa | 268 | (not (regexp-exec %alpha-tarball-rx file)) |
da1027a7 | 269 | (let ((s (tarball-sans-extension file))) |
501d7647 LC |
270 | (regexp-exec %package-name-rx s)))) |
271 | ||
272 | (define (tarball->version tarball) | |
273 | "Return the version TARBALL corresponds to. TARBALL is a file name like | |
274 | \"coreutils-8.23.tar.xz\"." | |
275 | (let-values (((name version) | |
da1027a7 HG |
276 | (gnu-package-name->name+version |
277 | (tarball-sans-extension tarball)))) | |
501d7647 LC |
278 | version)) |
279 | ||
63e8bb12 LC |
280 | (define* (releases project |
281 | #:key | |
282 | (server "ftp.gnu.org") | |
283 | (directory (string-append "/gnu/" project))) | |
284 | "Return the list of <upstream-release> of PROJECT as a list of release | |
285 | name/directory pairs." | |
cac137aa | 286 | ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. |
63e8bb12 LC |
287 | (define conn (ftp-open server)) |
288 | ||
289 | (let loop ((directories (list directory)) | |
290 | (result '())) | |
291 | (match directories | |
292 | (() | |
293 | (ftp-close conn) | |
294 | (coalesce-sources result)) | |
295 | ((directory rest ...) | |
296 | (let* ((files (ftp-list conn directory)) | |
297 | (subdirs (filter-map (match-lambda | |
298 | ((name 'directory . _) name) | |
299 | (_ #f)) | |
300 | files))) | |
301 | (define (file->url file) | |
302 | (string-append "ftp://" server directory "/" file)) | |
303 | ||
304 | (define (file->source file) | |
305 | (let ((url (file->url file))) | |
306 | (upstream-source | |
307 | (package project) | |
308 | (version (tarball->version file)) | |
309 | (urls (list url)) | |
310 | (signature-urls (list (string-append url ".sig")))))) | |
311 | ||
312 | (loop (append (map (cut string-append directory "/" <>) | |
313 | subdirs) | |
314 | rest) | |
315 | (append | |
316 | ;; Filter out signatures, deltas, and files which | |
317 | ;; are potentially not releases of PROJECT--e.g., | |
318 | ;; in /gnu/guile, filter out guile-oops and | |
319 | ;; guile-www; in mit-scheme, filter out binaries. | |
320 | (filter-map (match-lambda | |
321 | ((file 'file . _) | |
322 | (and (release-file? project file) | |
323 | (file->source file))) | |
324 | (_ #f)) | |
325 | files) | |
326 | result))))))) | |
98fefb21 | 327 | |
e946f2ec LC |
328 | (define* (latest-ftp-release project |
329 | #:key | |
330 | (server "ftp.gnu.org") | |
331 | (directory (string-append "/gnu/" project)) | |
29330b57 | 332 | (file->signature (cut string-append <> ".sig"))) |
e946f2ec LC |
333 | "Return an <upstream-source> for the latest release of PROJECT on SERVER |
334 | under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP | |
c4991257 LC |
335 | connections; this can be useful to reuse connections. |
336 | ||
c4991257 LC |
337 | FILE->SIGNATURE must be a procedure; it is passed a source file URL and must |
338 | return the corresponding signature URL, or #f it signatures are unavailable." | |
cac137aa LC |
339 | (define (latest a b) |
340 | (if (version>? a b) a b)) | |
341 | ||
501d7647 | 342 | (define (latest-release a b) |
0a7c5a09 | 343 | (if (version>? (upstream-source-version a) (upstream-source-version b)) |
501d7647 LC |
344 | a b)) |
345 | ||
a74da6b0 LC |
346 | (define patch-directory-name? |
347 | ;; Return #t for patch directory names such as 'bash-4.2-patches'. | |
348 | (cut string-suffix? "patches" <>)) | |
349 | ||
728c9086 | 350 | (define conn (ftp-open server #:timeout 5)) |
e946f2ec LC |
351 | |
352 | (define (file->url directory file) | |
353 | (string-append "ftp://" server directory "/" file)) | |
354 | ||
355 | (define (file->source directory file) | |
356 | (let ((url (file->url directory file))) | |
357 | (upstream-source | |
358 | (package project) | |
359 | (version (tarball->version file)) | |
360 | (urls (list url)) | |
6efa6f76 LC |
361 | (signature-urls (match (file->signature url) |
362 | (#f #f) | |
363 | (sig (list sig))))))) | |
e946f2ec LC |
364 | |
365 | (let loop ((directory directory) | |
366 | (result #f)) | |
be84fc60 | 367 | (let* ((entries (catch 'ftp-error |
368 | (lambda _ (ftp-list conn directory)) | |
369 | (const '()))) | |
e946f2ec | 370 | |
026f6a42 | 371 | ;; Filter out things like /gnupg/patches. Filter out "w32" |
e946f2ec LC |
372 | ;; directories as found on ftp.gnutls.org. |
373 | (subdirs (filter-map (match-lambda | |
374 | (((? patch-directory-name? dir) | |
375 | 'directory . _) | |
376 | #f) | |
377 | (("w32" 'directory . _) | |
378 | #f) | |
58d9e71b LC |
379 | (("unstable" 'directory . _) |
380 | ;; As seen at ftp.gnupg.org/gcrypt/pinentry. | |
381 | #f) | |
026f6a42 LC |
382 | ((directory 'directory . _) |
383 | directory) | |
e946f2ec LC |
384 | (_ #f)) |
385 | entries)) | |
386 | ||
387 | ;; Whether or not SUBDIRS is empty, compute the latest releases | |
388 | ;; for the current directory. This is necessary for packages | |
389 | ;; such as 'sharutils' that have a sub-directory that contains | |
390 | ;; only an older release. | |
391 | (releases (filter-map (match-lambda | |
392 | ((file 'file . _) | |
393 | (and (release-file? project file) | |
394 | (file->source directory file))) | |
395 | (_ #f)) | |
396 | entries))) | |
397 | ||
398 | ;; Assume that SUBDIRS correspond to versions, and jump into the | |
399 | ;; one with the highest version number. | |
400 | (let* ((release (reduce latest-release #f | |
401 | (coalesce-sources releases))) | |
402 | (result (if (and result release) | |
403 | (latest-release release result) | |
404 | (or release result))) | |
405 | (target (reduce latest #f subdirs))) | |
406 | (if target | |
407 | (loop (string-append directory "/" target) | |
408 | result) | |
409 | (begin | |
410 | (ftp-close conn) | |
411 | result)))))) | |
412 | ||
63e8bb12 LC |
413 | (define* (latest-release package |
414 | #:key | |
415 | (server "ftp.gnu.org") | |
416 | (directory (string-append "/gnu/" package))) | |
e946f2ec | 417 | "Return the <upstream-source> for the latest version of PACKAGE or #f. |
63e8bb12 LC |
418 | PACKAGE must be the canonical name of a GNU package." |
419 | (latest-ftp-release package | |
420 | #:server server | |
421 | #:directory directory)) | |
98fefb21 | 422 | |
e80c0f85 LC |
423 | (define-syntax-rule (false-if-ftp-error exp) |
424 | "Return #f if an FTP error is raise while evaluating EXP; return the result | |
425 | of EXP otherwise." | |
0a7c5a09 LC |
426 | (catch 'ftp-error |
427 | (lambda () | |
e80c0f85 | 428 | exp) |
0a7c5a09 LC |
429 | (lambda (key port . rest) |
430 | (if (ftp-connection? port) | |
431 | (ftp-close port) | |
432 | (close-port port)) | |
433 | #f))) | |
7047133f | 434 | |
e80c0f85 | 435 | (define (latest-release* package) |
63e8bb12 LC |
436 | "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP |
437 | errors that might occur when PACKAGE is not actually a GNU package, or not | |
438 | hosted on ftp.gnu.org, or not under that name (this is the case for | |
439 | \"emacs-auctex\", for instance.)" | |
440 | (let-values (((server directory) | |
441 | (ftp-server/directory package))) | |
3b0fcc67 LC |
442 | (false-if-ftp-error (latest-release (package-upstream-name package) |
443 | #:server server | |
444 | #:directory directory)))) | |
e80c0f85 | 445 | |
5230dce1 LC |
446 | \f |
447 | ;;; | |
448 | ;;; Latest HTTP release. | |
449 | ;;; | |
450 | ||
5230dce1 LC |
451 | (define (html-links sxml) |
452 | "Return the list of links found in SXML, the SXML tree of an HTML page." | |
453 | (let loop ((sxml sxml) | |
454 | (links '())) | |
455 | (match sxml | |
456 | (('a ('@ attributes ...) body ...) | |
457 | (match (assq 'href attributes) | |
458 | (#f (fold loop links body)) | |
459 | (('href url) (fold loop (cons url links) body)))) | |
460 | ((tag ('@ _ ...) body ...) | |
461 | (fold loop links body)) | |
462 | ((tag body ...) | |
463 | (fold loop links body)) | |
464 | (_ | |
465 | links)))) | |
466 | ||
467 | (define* (latest-html-release package | |
468 | #:key | |
469 | (base-url "https://kernel.org/pub") | |
470 | (directory (string-append "/" package)) | |
99f42e14 | 471 | file->signature) |
5230dce1 LC |
472 | "Return an <upstream-source> for the latest release of PACKAGE (a string) on |
473 | SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page, | |
474 | typically a directory listing as found on 'https://kernel.org/pub'. | |
475 | ||
99f42e14 LC |
476 | When FILE->SIGNATURE is omitted or #f, guess the detached signature file name, |
477 | if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source | |
478 | file URL and must return the corresponding signature URL, or #f it signatures | |
479 | are unavailable." | |
a0f83602 LC |
480 | (let* ((uri (string->uri (if (string-null? directory) |
481 | base-url | |
482 | (string-append base-url directory "/")))) | |
99f42e14 LC |
483 | (port (http-fetch/cached uri #:ttl 3600)) |
484 | (sxml (html->sxml port)) | |
485 | (links (delete-duplicates (html-links sxml)))) | |
486 | (define (file->signature/guess url) | |
487 | (let ((base (basename url))) | |
488 | (any (lambda (link) | |
489 | (any (lambda (extension) | |
490 | (and (string=? (string-append base extension) | |
491 | (basename link)) | |
492 | (string-append url extension))) | |
493 | '(".asc" ".sig" ".sign"))) | |
494 | links))) | |
495 | ||
5230dce1 | 496 | (define (url->release url) |
db69ebb9 LC |
497 | (let* ((base (basename url)) |
498 | (url (if (string=? base url) | |
499 | (string-append base-url directory "/" url) | |
500 | url))) | |
501 | (and (release-file? package base) | |
1d5a946c | 502 | (let ((version (tarball->version base))) |
db69ebb9 | 503 | (upstream-source |
1d5a946c | 504 | (package package) |
db69ebb9 LC |
505 | (version version) |
506 | (urls (list url)) | |
507 | (signature-urls | |
99f42e14 | 508 | (list ((or file->signature file->signature/guess) url)))))))) |
5230dce1 LC |
509 | |
510 | (define candidates | |
99f42e14 | 511 | (filter-map url->release links)) |
5230dce1 LC |
512 | |
513 | (close-port port) | |
514 | (match candidates | |
515 | (() #f) | |
516 | ((first . _) | |
517 | ;; Select the most recent release and return it. | |
518 | (reduce (lambda (r1 r2) | |
519 | (if (version>? (upstream-source-version r1) | |
520 | (upstream-source-version r2)) | |
521 | r1 r2)) | |
522 | first | |
523 | (coalesce-sources candidates)))))) | |
524 | ||
525 | \f | |
526 | ;;; | |
527 | ;;; Updaters. | |
528 | ;;; | |
529 | ||
100b216d LC |
530 | (define %gnu-file-list-uri |
531 | ;; URI of the file list for ftp.gnu.org. | |
532 | (string->uri "https://ftp.gnu.org/find.txt.gz")) | |
533 | ||
534 | (define ftp.gnu.org-files | |
535 | (mlambda () | |
536 | "Return the list of files available at ftp.gnu.org." | |
537 | ||
538 | ;; XXX: Memoize the whole procedure to work around the fact that | |
539 | ;; 'http-fetch/cached' caches the gzipped version. | |
540 | ||
541 | (define (trim-leading-components str) | |
542 | ;; Trim the leading ".", if any, in "./gnu/foo". | |
543 | (string-trim str (char-set #\.))) | |
544 | ||
545 | (define (string->lines str) | |
546 | (string-tokenize str (char-set-complement (char-set #\newline)))) | |
547 | ||
3ce1b902 LC |
548 | ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded |
549 | ;; TTL can be relatively short. | |
550 | (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60)))) | |
100b216d LC |
551 | (map trim-leading-components |
552 | (call-with-gzip-input-port port | |
553 | (compose string->lines get-string-all)))))) | |
554 | ||
555 | (define (latest-gnu-release package) | |
556 | "Return the latest release of PACKAGE, a GNU package available via | |
557 | ftp.gnu.org. | |
558 | ||
559 | This method does not rely on FTP access at all; instead, it browses the file | |
560 | list available from %GNU-FILE-LIST-URI over HTTP(S)." | |
561 | (let-values (((server directory) | |
562 | (ftp-server/directory package)) | |
563 | ((name) | |
564 | (package-upstream-name package))) | |
565 | (let* ((files (ftp.gnu.org-files)) | |
566 | (relevant (filter (lambda (file) | |
1b3ebae4 LC |
567 | (and (string-prefix? "/gnu" file) |
568 | (string-contains file directory) | |
e9f38113 | 569 | (release-file? name (basename file)))) |
100b216d LC |
570 | files))) |
571 | (match (sort relevant (lambda (file1 file2) | |
da1027a7 HG |
572 | (version>? (tarball-sans-extension |
573 | (basename file1)) | |
574 | (tarball-sans-extension | |
575 | (basename file2))))) | |
1b3ebae4 LC |
576 | ((and tarballs (reference _ ...)) |
577 | (let* ((version (tarball->version reference)) | |
578 | (tarballs (filter (lambda (file) | |
da1027a7 | 579 | (string=? (tarball-sans-extension |
1b3ebae4 | 580 | (basename file)) |
da1027a7 | 581 | (tarball-sans-extension |
1b3ebae4 LC |
582 | (basename reference)))) |
583 | tarballs))) | |
584 | (upstream-source | |
585 | (package name) | |
586 | (version version) | |
587 | (urls (map (lambda (file) | |
588 | (string-append "mirror://gnu/" | |
589 | (string-drop file | |
590 | (string-length "/gnu/")))) | |
591 | tarballs)) | |
592 | (signature-urls (map (cut string-append <> ".sig") urls))))) | |
100b216d LC |
593 | (() |
594 | #f))))) | |
595 | ||
98fefb21 LC |
596 | (define %package-name-rx |
597 | ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses | |
598 | ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. | |
ceeea60b | 599 | (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src|\\.src|\\.orig)?")) |
98fefb21 LC |
600 | |
601 | (define (gnu-package-name->name+version name+version) | |
602 | "Return the package name and version number extracted from NAME+VERSION." | |
603 | (let ((match (regexp-exec %package-name-rx name+version))) | |
604 | (if (not match) | |
605 | (values name+version #f) | |
606 | (values (match:substring match 1) (match:substring match 2))))) | |
607 | ||
c1d8b3b3 LC |
608 | (define gnome-package? |
609 | (url-prefix-predicate "mirror://gnome/")) | |
610 | ||
e80c0f85 LC |
611 | (define (pure-gnu-package? package) |
612 | "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This | |
613 | excludes AucTeX, for instance, whose releases are now uploaded to | |
cab18315 LC |
614 | elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the |
615 | GNOME packages; EMMS is included though, because its releases are on gnu.org." | |
2e2cf9a3 LC |
616 | (and (or (not (string-prefix? "emacs-" (package-name package))) |
617 | (gnu-hosted? package)) | |
e80c0f85 | 618 | (not (gnome-package? package)) |
cab18315 | 619 | (not (string-prefix? "gnuradio" (package-name package))) |
0a7c5a09 | 620 | (gnu-package? package))) |
0fdd3bea | 621 | |
2e2cf9a3 LC |
622 | (define gnu-hosted? |
623 | (url-prefix-predicate "mirror://gnu/")) | |
624 | ||
59a47fb6 LC |
625 | (define (url-prefix-rewrite old new) |
626 | "Return a one-argument procedure that rewrites URL prefix OLD to NEW." | |
627 | (lambda (url) | |
99f42e14 | 628 | (if (and url (string-prefix? old url)) |
59a47fb6 LC |
629 | (string-append new (string-drop url (string-length old))) |
630 | url))) | |
631 | ||
632 | (define (adjusted-upstream-source source rewrite-url) | |
633 | "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them." | |
634 | (upstream-source | |
635 | (inherit source) | |
636 | (urls (map rewrite-url (upstream-source-urls source))) | |
637 | (signature-urls (and=> (upstream-source-signature-urls source) | |
638 | (lambda (urls) | |
639 | (map rewrite-url urls)))))) | |
640 | ||
7a6bb2fe LC |
641 | (define %savannah-base |
642 | ;; One of the Savannah mirrors listed at | |
643 | ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid | |
644 | ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.) | |
645 | "https://nongnu.freemirror.org/nongnu") | |
646 | ||
647 | (define (latest-savannah-release package) | |
648 | "Return the latest release of PACKAGE." | |
b579b1c1 LC |
649 | (let* ((uri (string->uri |
650 | (match (origin-uri (package-source package)) | |
651 | ((? string? uri) uri) | |
652 | ((uri mirrors ...) uri)))) | |
7a6bb2fe | 653 | (package (package-upstream-name package)) |
59a47fb6 LC |
654 | (directory (dirname (uri-path uri))) |
655 | (rewrite (url-prefix-rewrite %savannah-base | |
656 | "mirror://savannah"))) | |
99f42e14 LC |
657 | ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", |
658 | ;; or whichever detached signature naming scheme PACKAGE uses. | |
a022f5a4 LC |
659 | (and=> (latest-html-release package |
660 | #:base-url %savannah-base | |
661 | #:directory directory) | |
662 | (cut adjusted-upstream-source <> rewrite)))) | |
7a6bb2fe | 663 | |
b92cfc32 LC |
664 | (define (latest-sourceforge-release package) |
665 | "Return the latest release of PACKAGE." | |
666 | (define (uri-append uri extension) | |
667 | ;; Return URI with EXTENSION appended. | |
668 | (build-uri (uri-scheme uri) | |
669 | #:host (uri-host uri) | |
670 | #:path (string-append (uri-path uri) extension))) | |
671 | ||
eb6ac483 | 672 | (define (valid-uri? uri port) |
b92cfc32 LC |
673 | ;; Return true if URI is reachable. |
674 | (false-if-exception | |
eb6ac483 | 675 | (case (response-code (http-head uri #:port port #:keep-alive? #t)) |
b92cfc32 LC |
676 | ((200 302) #t) |
677 | (else #f)))) | |
678 | ||
679 | (let* ((name (package-upstream-name package)) | |
680 | (base (string-append "https://sourceforge.net/projects/" | |
681 | name "/files")) | |
682 | (url (string-append base "/latest/download")) | |
eb6ac483 LC |
683 | (uri (string->uri url)) |
684 | (port (false-if-exception (open-socket-for-uri uri))) | |
685 | (response (and port | |
686 | (http-head uri #:port port #:keep-alive? #t)))) | |
687 | (dynamic-wind | |
688 | (const #t) | |
689 | (lambda () | |
690 | (and response | |
691 | (= 302 (response-code response)) | |
692 | (response-location response) | |
693 | (match (string-tokenize (uri-path (response-location response)) | |
694 | (char-set-complement (char-set #\/))) | |
695 | ((_ components ...) | |
696 | (let* ((path (string-join components "/")) | |
697 | (url (string-append "mirror://sourceforge/" path))) | |
698 | (and (release-file? name (basename path)) | |
699 | ||
700 | ;; Take the heavy-handed approach of probing 3 additional | |
701 | ;; URLs. XXX: Would be nicer if this could be avoided. | |
702 | (let* ((loc (response-location response)) | |
703 | (sig (any (lambda (extension) | |
704 | (let ((uri (uri-append loc extension))) | |
705 | (and (valid-uri? uri port) | |
706 | (string-append url extension)))) | |
707 | '(".asc" ".sig" ".sign")))) | |
708 | (upstream-source | |
709 | (package name) | |
710 | (version (tarball->version (basename path))) | |
711 | (urls (list url)) | |
712 | (signature-urls (and sig (list sig))))))))))) | |
713 | (lambda () | |
714 | (when port | |
715 | (close-port port)))))) | |
b92cfc32 | 716 | |
62061d6b | 717 | (define (latest-xorg-release package) |
7a6bb2fe | 718 | "Return the latest release of PACKAGE." |
7d27a025 | 719 | (let ((uri (string->uri (origin-uri (package-source package))))) |
62061d6b AW |
720 | (false-if-ftp-error |
721 | (latest-ftp-release | |
7d27a025 | 722 | (package-name package) |
62061d6b AW |
723 | #:server "ftp.freedesktop.org" |
724 | #:directory | |
725 | (string-append "/pub/xorg/" (dirname (uri-path uri))))))) | |
726 | ||
2fd370e8 LC |
727 | (define (latest-kernel.org-release package) |
728 | "Return the latest release of PACKAGE, the name of a kernel.org package." | |
5230dce1 LC |
729 | (define %kernel.org-base |
730 | ;; This URL and sub-directories thereof are nginx-generated directory | |
731 | ;; listings suitable for 'latest-html-release'. | |
732 | "https://mirrors.edge.kernel.org/pub") | |
733 | ||
734 | (define (file->signature file) | |
735 | (string-append (file-sans-extension file) ".sign")) | |
736 | ||
b579b1c1 LC |
737 | (let* ((uri (string->uri |
738 | (match (origin-uri (package-source package)) | |
739 | ((? string? uri) uri) | |
740 | ((uri mirrors ...) uri)))) | |
5230dce1 | 741 | (package (package-upstream-name package)) |
59a47fb6 LC |
742 | (directory (dirname (uri-path uri))) |
743 | (rewrite (url-prefix-rewrite %kernel.org-base | |
744 | "mirror://kernel.org"))) | |
a022f5a4 LC |
745 | (and=> (latest-html-release package |
746 | #:base-url %kernel.org-base | |
747 | #:directory directory | |
748 | #:file->signature file->signature) | |
749 | (cut adjusted-upstream-source <> rewrite)))) | |
2fd370e8 | 750 | |
af9af218 LC |
751 | (define html-updatable-package? |
752 | ;; Return true if the given package may be handled by the generic HTML | |
753 | ;; updater. | |
754 | (let ((hosting-sites '("github.com" "github.io" "gitlab.com" | |
755 | "notabug.org" "sr.ht" | |
756 | "gforge.inria.fr" "gitlab.inria.fr" | |
757 | "ftp.gnu.org" "download.savannah.gnu.org" | |
758 | "pypi.org" "crates.io" "rubygems.org" | |
759 | "bioconductor.org"))) | |
b3679f2d LC |
760 | (define http-url? |
761 | (url-predicate (lambda (url) | |
762 | (match (string->uri url) | |
763 | (#f #f) | |
764 | (uri | |
765 | (let ((scheme (uri-scheme uri)) | |
766 | (host (uri-host uri))) | |
767 | (and (memq scheme '(http https)) | |
768 | (not (member host hosting-sites))))))))) | |
769 | ||
770 | (lambda (package) | |
771 | (or (assoc-ref (package-properties package) 'release-monitoring-url) | |
772 | (http-url? package))))) | |
af9af218 LC |
773 | |
774 | (define (latest-html-updatable-release package) | |
775 | "Return the latest release of PACKAGE. Do that by crawling the HTML page of | |
776 | the directory containing its source tarball." | |
777 | (let* ((uri (string->uri | |
778 | (match (origin-uri (package-source package)) | |
779 | ((? string? url) url) | |
780 | ((url _ ...) url)))) | |
781 | (custom (assoc-ref (package-properties package) | |
782 | 'release-monitoring-url)) | |
783 | (base (or custom | |
784 | (string-append (symbol->string (uri-scheme uri)) | |
785 | "://" (uri-host uri)))) | |
786 | (directory (if custom | |
787 | "" | |
788 | (dirname (uri-path uri)))) | |
789 | (package (package-upstream-name package))) | |
790 | (catch #t | |
791 | (lambda () | |
792 | (guard (c ((http-get-error? c) #f)) | |
793 | (latest-html-release package | |
794 | #:base-url base | |
795 | #:directory directory))) | |
796 | (lambda (key . args) | |
797 | ;; Return false and move on upon connection failures and bogus HTTP | |
798 | ;; servers. | |
799 | (unless (memq key '(gnutls-error tls-certificate-error | |
800 | system-error | |
801 | bad-header bad-header-component)) | |
802 | (apply throw key args)) | |
803 | #f)))) | |
804 | ||
0a7c5a09 | 805 | (define %gnu-updater |
100b216d | 806 | ;; This is for everything at ftp.gnu.org. |
7e6b490d AK |
807 | (upstream-updater |
808 | (name 'gnu) | |
809 | (description "Updater for GNU packages") | |
100b216d LC |
810 | (pred gnu-hosted?) |
811 | (latest latest-gnu-release))) | |
812 | ||
813 | (define %gnu-ftp-updater | |
814 | ;; This is for GNU packages taken from alternate locations, such as | |
815 | ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent. | |
816 | (upstream-updater | |
817 | (name 'gnu-ftp) | |
818 | (description "Updater for GNU packages only available via FTP") | |
819 | (pred (lambda (package) | |
820 | (and (not (gnu-hosted? package)) | |
821 | (pure-gnu-package? package)))) | |
7e6b490d | 822 | (latest latest-release*))) |
0fdd3bea | 823 | |
7a6bb2fe LC |
824 | (define %savannah-updater |
825 | (upstream-updater | |
826 | (name 'savannah) | |
827 | (description "Updater for packages hosted on savannah.gnu.org") | |
828 | (pred (url-prefix-predicate "mirror://savannah/")) | |
829 | (latest latest-savannah-release))) | |
830 | ||
b92cfc32 LC |
831 | (define %sourceforge-updater |
832 | (upstream-updater | |
833 | (name 'sourceforge) | |
834 | (description "Updater for packages hosted on sourceforge.net") | |
835 | (pred (url-prefix-predicate "mirror://sourceforge/")) | |
836 | (latest latest-sourceforge-release))) | |
837 | ||
62061d6b AW |
838 | (define %xorg-updater |
839 | (upstream-updater | |
840 | (name 'xorg) | |
841 | (description "Updater for X.org packages") | |
7632f7bc | 842 | (pred (url-prefix-predicate "mirror://xorg/")) |
62061d6b AW |
843 | (latest latest-xorg-release))) |
844 | ||
2fd370e8 LC |
845 | (define %kernel.org-updater |
846 | (upstream-updater | |
847 | (name 'kernel.org) | |
848 | (description "Updater for packages hosted on kernel.org") | |
849 | (pred (url-prefix-predicate "mirror://kernel.org/")) | |
850 | (latest latest-kernel.org-release))) | |
851 | ||
af9af218 LC |
852 | (define %generic-html-updater |
853 | (upstream-updater | |
854 | (name 'generic-html) | |
855 | (description "Updater that crawls HTML pages.") | |
856 | (pred html-updatable-package?) | |
857 | (latest latest-html-updatable-release))) | |
858 | ||
98fefb21 | 859 | ;;; gnu-maintenance.scm ends here |