Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
fef494d2 | 2 | ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
f9bbf2a8 | 3 | ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> |
22189ed1 | 4 | ;;; |
233e7676 | 5 | ;;; This file is part of GNU Guix. |
22189ed1 | 6 | ;;; |
233e7676 | 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
22189ed1 NK |
8 | ;;; under the terms of the GNU General Public License as published by |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
233e7676 | 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
22189ed1 NK |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
22189ed1 NK |
19 | |
20 | (define-module (guix gnu-maintenance) | |
21 | #:use-module (web uri) | |
22 | #:use-module (web client) | |
23 | #:use-module (web response) | |
24 | #:use-module (ice-9 regex) | |
98fefb21 | 25 | #:use-module (ice-9 match) |
22189ed1 NK |
26 | #:use-module (srfi srfi-1) |
27 | #:use-module (srfi srfi-11) | |
28 | #:use-module (srfi srfi-26) | |
100b216d | 29 | #:use-module (rnrs io ports) |
98fefb21 | 30 | #:use-module (system foreign) |
3b8258c5 | 31 | #:use-module (guix http-client) |
98fefb21 | 32 | #:use-module (guix ftp-client) |
0d1e6ce4 | 33 | #:use-module (guix utils) |
f9704f17 | 34 | #:use-module (guix memoization) |
c0cd1b3e | 35 | #:use-module (guix records) |
0a7c5a09 | 36 | #:use-module (guix upstream) |
ef010c0f | 37 | #:use-module (guix packages) |
100b216d | 38 | #:use-module (guix zlib) |
f9bbf2a8 NK |
39 | #:export (gnu-package-name |
40 | gnu-package-mundane-name | |
41 | gnu-package-copyright-holder | |
42 | gnu-package-savannah | |
43 | gnu-package-fsd | |
44 | gnu-package-language | |
45 | gnu-package-logo | |
46 | gnu-package-doc-category | |
47 | gnu-package-doc-summary | |
c4ca9411 | 48 | gnu-package-doc-description |
f9bbf2a8 NK |
49 | gnu-package-doc-urls |
50 | gnu-package-download-url | |
51 | ||
52 | official-gnu-packages | |
dc794a72 | 53 | find-package |
ef010c0f | 54 | gnu-package? |
f9bbf2a8 | 55 | |
202440e0 | 56 | release-file? |
98fefb21 LC |
57 | releases |
58 | latest-release | |
7047133f | 59 | gnu-release-archive-types |
0fdd3bea | 60 | gnu-package-name->name+version |
7047133f | 61 | |
e80c0f85 | 62 | %gnu-updater |
100b216d | 63 | %gnu-ftp-updater |
62061d6b | 64 | %gnome-updater |
9c97afe8 | 65 | %kde-updater |
2fd370e8 LC |
66 | %xorg-updater |
67 | %kernel.org-updater)) | |
98fefb21 LC |
68 | |
69 | ;;; Commentary: | |
70 | ;;; | |
71 | ;;; Code for dealing with the maintenance of GNU packages, such as | |
72 | ;;; auto-updates. | |
73 | ;;; | |
74 | ;;; Code: | |
75 | ||
76 | \f | |
77 | ;;; | |
78 | ;;; List of GNU packages. | |
79 | ;;; | |
22189ed1 | 80 | |
129f9e11 | 81 | (define %gnumaint-base-url |
fef494d2 | 82 | "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/") |
129f9e11 | 83 | |
22189ed1 | 84 | (define %package-list-url |
1c9e7d65 | 85 | (string->uri |
fef494d2 | 86 | (string-append %gnumaint-base-url "gnupackages.txt"))) |
22189ed1 | 87 | |
129f9e11 LC |
88 | (define %package-description-url |
89 | ;; This file contains package descriptions in recutils format. | |
90 | ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>. | |
91 | (string->uri | |
fef494d2 | 92 | (string-append %gnumaint-base-url "pkgblurbs.txt"))) |
c4ca9411 | 93 | |
f9bbf2a8 NK |
94 | (define-record-type* <gnu-package-descriptor> |
95 | gnu-package-descriptor | |
96 | make-gnu-package-descriptor | |
97 | ||
98 | gnu-package-descriptor? | |
99 | ||
100 | (name gnu-package-name) | |
101 | (mundane-name gnu-package-mundane-name) | |
102 | (copyright-holder gnu-package-copyright-holder) | |
103 | (savannah gnu-package-savannah) | |
104 | (fsd gnu-package-fsd) | |
b0efe83a | 105 | (language gnu-package-language) ; list of strings |
f9bbf2a8 NK |
106 | (logo gnu-package-logo) |
107 | (doc-category gnu-package-doc-category) | |
108 | (doc-summary gnu-package-doc-summary) | |
129f9e11 | 109 | (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt' |
b0efe83a | 110 | (doc-urls gnu-package-doc-urls) ; list of strings |
f9bbf2a8 NK |
111 | (download-url gnu-package-download-url)) |
112 | ||
9aec35d2 LC |
113 | (define* (official-gnu-packages |
114 | #:optional (fetch http-fetch/cached)) | |
115 | "Return a list of records, which are GNU packages. Use FETCH, | |
116 | to fetch the list of GNU packages over HTTP." | |
c4ca9411 | 117 | (define (read-records port) |
f9bbf2a8 NK |
118 | ;; Return a list of alists. Each alist contains fields of a GNU |
119 | ;; package. | |
b0efe83a LC |
120 | (let loop ((alist (recutils->alist port)) |
121 | (result '())) | |
122 | (if (null? alist) | |
c4ca9411 | 123 | (reverse result) |
b0efe83a LC |
124 | (loop (recutils->alist port) |
125 | (cons alist result))))) | |
f9bbf2a8 | 126 | |
129f9e11 | 127 | (define official-description |
9aec35d2 | 128 | (let ((db (read-records (fetch %package-description-url #:text? #t)))) |
c4ca9411 | 129 | (lambda (name) |
129f9e11 | 130 | ;; Return the description found upstream for package NAME, or #f. |
c4ca9411 | 131 | (and=> (find (lambda (alist) |
129f9e11 LC |
132 | (equal? name (assoc-ref alist "package"))) |
133 | db) | |
4d5f0bae LC |
134 | (lambda (record) |
135 | (let ((field (assoc-ref record "blurb"))) | |
136 | ;; The upstream description file uses "redirect PACKAGE" as | |
137 | ;; a blurb in cases where the description of the two | |
138 | ;; packages should be considered the same (e.g., GTK+ has | |
139 | ;; "redirect gnome".) This is usually not acceptable for | |
140 | ;; us because we prefer to have distinct descriptions in | |
141 | ;; such cases. Thus, ignore the 'blurb' field when that | |
142 | ;; happens. | |
143 | (and field | |
144 | (not (string-prefix? "redirect " field)) | |
145 | field))))))) | |
c4ca9411 LC |
146 | |
147 | (map (lambda (alist) | |
148 | (let ((name (assoc-ref alist "package"))) | |
129f9e11 | 149 | (alist->record `(("description" . ,(official-description name)) |
c4ca9411 LC |
150 | ,@alist) |
151 | make-gnu-package-descriptor | |
152 | (list "package" "mundane-name" "copyright-holder" | |
153 | "savannah" "fsd" "language" "logo" | |
154 | "doc-category" "doc-summary" "description" | |
155 | "doc-url" | |
156 | "download-url") | |
157 | '("doc-url" "language")))) | |
2134228a LC |
158 | (let* ((port (fetch %package-list-url #:text? #t)) |
159 | (lst (read-records port))) | |
160 | (close-port port) | |
161 | lst))) | |
22189ed1 | 162 | |
dc794a72 LC |
163 | (define (find-package name) |
164 | "Find GNU package called NAME and return it. Return #f if it was not | |
165 | found." | |
166 | (find (lambda (package) | |
167 | (string=? name (gnu-package-name package))) | |
168 | (official-gnu-packages))) | |
ef010c0f LC |
169 | |
170 | (define gnu-package? | |
55b2d921 | 171 | (let ((official-gnu-packages (memoize official-gnu-packages))) |
3d520b54 | 172 | (mlambdaq (package) |
55b2d921 | 173 | "Return true if PACKAGE is a GNU package. This procedure may access the |
ef010c0f | 174 | network to check in GNU's database." |
55b2d921 LC |
175 | (define (mirror-type url) |
176 | (let ((uri (string->uri url))) | |
177 | (and (eq? (uri-scheme uri) 'mirror) | |
178 | (cond | |
179 | ((member (uri-host uri) | |
180 | '("gnu" "gnupg" "gcc" "gnome")) | |
181 | ;; Definitely GNU. | |
182 | 'gnu) | |
183 | ((equal? (uri-host uri) "cran") | |
184 | ;; Possibly GNU: mirror://cran could be either GNU R itself | |
185 | ;; or a non-GNU package. | |
186 | #f) | |
187 | (else | |
188 | ;; Definitely non-GNU. | |
189 | 'non-gnu))))) | |
190 | ||
191 | (define (gnu-home-page? package) | |
192 | (letrec-syntax ((>> (syntax-rules () | |
193 | ((_ value proc) | |
194 | (and=> value proc)) | |
195 | ((_ value proc rest ...) | |
196 | (and=> value | |
197 | (lambda (next) | |
198 | (>> (proc next) rest ...))))))) | |
199 | (>> package package-home-page | |
200 | string->uri uri-host | |
201 | (lambda (host) | |
202 | (member host '("www.gnu.org" "gnu.org")))))) | |
203 | ||
204 | (or (gnu-home-page? package) | |
205 | (let ((url (and=> (package-source package) origin-uri)) | |
206 | (name (package-upstream-name package))) | |
207 | (case (and (string? url) (mirror-type url)) | |
208 | ((gnu) #t) | |
209 | ((non-gnu) #f) | |
210 | (else | |
211 | (and (member name (map gnu-package-name (official-gnu-packages))) | |
212 | #t)))))))) | |
ef010c0f | 213 | |
98fefb21 LC |
214 | \f |
215 | ;;; | |
216 | ;;; Latest release. | |
217 | ;;; | |
218 | ||
63e8bb12 LC |
219 | (define (ftp-server/directory package) |
220 | "Return the FTP server and directory where PACKAGE's tarball are stored." | |
3b0fcc67 | 221 | (let ((name (package-upstream-name package))) |
b03218d5 LC |
222 | (values (or (assoc-ref (package-properties package) 'ftp-server) |
223 | "ftp.gnu.org") | |
224 | (or (assoc-ref (package-properties package) 'ftp-directory) | |
225 | (string-append "/gnu/" name))))) | |
98fefb21 | 226 | |
cac137aa | 227 | (define (sans-extension tarball) |
f5d9604f LC |
228 | "Return TARBALL without its .tar.* or .zip extension." |
229 | (let ((end (or (string-contains tarball ".tar") | |
230 | (string-contains tarball ".zip")))) | |
cac137aa | 231 | (substring tarball 0 end))) |
98fefb21 | 232 | |
d55a99fe | 233 | (define %tarball-rx |
f00dccf4 LC |
234 | ;; The .zip extensions is notably used for freefont-ttf. |
235 | ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". | |
236 | ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2". | |
237 | (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)")) | |
d55a99fe LC |
238 | |
239 | (define %alpha-tarball-rx | |
240 | (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) | |
241 | ||
501d7647 | 242 | (define (release-file? project file) |
cac137aa | 243 | "Return #f if FILE is not a release tarball of PROJECT, otherwise return |
501d7647 | 244 | true." |
cac137aa | 245 | (and (not (string-suffix? ".sig" file)) |
d55a99fe LC |
246 | (and=> (regexp-exec %tarball-rx file) |
247 | (lambda (match) | |
248 | ;; Filter out unrelated files, like `guile-www-1.1.1'. | |
fa04a04f | 249 | ;; Case-insensitive for things like "TeXmacs" vs. "texmacs". |
444bb0d8 | 250 | ;; The "-src" suffix is for "freefont-src-20120503.tar.gz". |
fa04a04f LC |
251 | (and=> (match:substring match 1) |
252 | (lambda (name) | |
444bb0d8 LC |
253 | (or (string-ci=? name project) |
254 | (string-ci=? name | |
255 | (string-append project | |
256 | "-src"))))))) | |
cac137aa LC |
257 | (not (regexp-exec %alpha-tarball-rx file)) |
258 | (let ((s (sans-extension file))) | |
501d7647 LC |
259 | (regexp-exec %package-name-rx s)))) |
260 | ||
261 | (define (tarball->version tarball) | |
262 | "Return the version TARBALL corresponds to. TARBALL is a file name like | |
263 | \"coreutils-8.23.tar.xz\"." | |
264 | (let-values (((name version) | |
265 | (gnu-package-name->name+version (sans-extension tarball)))) | |
266 | version)) | |
267 | ||
63e8bb12 LC |
268 | (define* (releases project |
269 | #:key | |
270 | (server "ftp.gnu.org") | |
271 | (directory (string-append "/gnu/" project))) | |
272 | "Return the list of <upstream-release> of PROJECT as a list of release | |
273 | name/directory pairs." | |
cac137aa | 274 | ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. |
63e8bb12 LC |
275 | (define conn (ftp-open server)) |
276 | ||
277 | (let loop ((directories (list directory)) | |
278 | (result '())) | |
279 | (match directories | |
280 | (() | |
281 | (ftp-close conn) | |
282 | (coalesce-sources result)) | |
283 | ((directory rest ...) | |
284 | (let* ((files (ftp-list conn directory)) | |
285 | (subdirs (filter-map (match-lambda | |
286 | ((name 'directory . _) name) | |
287 | (_ #f)) | |
288 | files))) | |
289 | (define (file->url file) | |
290 | (string-append "ftp://" server directory "/" file)) | |
291 | ||
292 | (define (file->source file) | |
293 | (let ((url (file->url file))) | |
294 | (upstream-source | |
295 | (package project) | |
296 | (version (tarball->version file)) | |
297 | (urls (list url)) | |
298 | (signature-urls (list (string-append url ".sig")))))) | |
299 | ||
300 | (loop (append (map (cut string-append directory "/" <>) | |
301 | subdirs) | |
302 | rest) | |
303 | (append | |
304 | ;; Filter out signatures, deltas, and files which | |
305 | ;; are potentially not releases of PROJECT--e.g., | |
306 | ;; in /gnu/guile, filter out guile-oops and | |
307 | ;; guile-www; in mit-scheme, filter out binaries. | |
308 | (filter-map (match-lambda | |
309 | ((file 'file . _) | |
310 | (and (release-file? project file) | |
311 | (file->source file))) | |
312 | (_ #f)) | |
313 | files) | |
314 | result))))))) | |
98fefb21 | 315 | |
e946f2ec LC |
316 | (define* (latest-ftp-release project |
317 | #:key | |
318 | (server "ftp.gnu.org") | |
319 | (directory (string-append "/gnu/" project)) | |
c4991257 | 320 | (keep-file? (const #t)) |
6efa6f76 | 321 | (file->signature (cut string-append <> ".sig")) |
e946f2ec LC |
322 | (ftp-open ftp-open) (ftp-close ftp-close)) |
323 | "Return an <upstream-source> for the latest release of PROJECT on SERVER | |
324 | under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP | |
c4991257 LC |
325 | connections; this can be useful to reuse connections. |
326 | ||
873d0ff2 LC |
327 | KEEP-FILE? is a predicate to decide whether to enter a directory and to |
328 | consider a given file (source tarball) as a valid candidate based on its name. | |
c4991257 LC |
329 | |
330 | FILE->SIGNATURE must be a procedure; it is passed a source file URL and must | |
331 | return the corresponding signature URL, or #f it signatures are unavailable." | |
cac137aa LC |
332 | (define (latest a b) |
333 | (if (version>? a b) a b)) | |
334 | ||
501d7647 | 335 | (define (latest-release a b) |
0a7c5a09 | 336 | (if (version>? (upstream-source-version a) (upstream-source-version b)) |
501d7647 LC |
337 | a b)) |
338 | ||
cac137aa LC |
339 | (define contains-digit? |
340 | (cut string-any char-set:digit <>)) | |
341 | ||
a74da6b0 LC |
342 | (define patch-directory-name? |
343 | ;; Return #t for patch directory names such as 'bash-4.2-patches'. | |
344 | (cut string-suffix? "patches" <>)) | |
345 | ||
e946f2ec LC |
346 | (define conn (ftp-open server)) |
347 | ||
348 | (define (file->url directory file) | |
349 | (string-append "ftp://" server directory "/" file)) | |
350 | ||
351 | (define (file->source directory file) | |
352 | (let ((url (file->url directory file))) | |
353 | (upstream-source | |
354 | (package project) | |
355 | (version (tarball->version file)) | |
356 | (urls (list url)) | |
6efa6f76 LC |
357 | (signature-urls (match (file->signature url) |
358 | (#f #f) | |
359 | (sig (list sig))))))) | |
e946f2ec LC |
360 | |
361 | (let loop ((directory directory) | |
362 | (result #f)) | |
363 | (let* ((entries (ftp-list conn directory)) | |
364 | ||
365 | ;; Filter out sub-directories that do not contain digits---e.g., | |
366 | ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" | |
367 | ;; directories as found on ftp.gnutls.org. | |
368 | (subdirs (filter-map (match-lambda | |
369 | (((? patch-directory-name? dir) | |
370 | 'directory . _) | |
371 | #f) | |
372 | (("w32" 'directory . _) | |
373 | #f) | |
374 | (((? contains-digit? dir) 'directory . _) | |
873d0ff2 | 375 | (and (keep-file? dir) dir)) |
e946f2ec LC |
376 | (_ #f)) |
377 | entries)) | |
378 | ||
379 | ;; Whether or not SUBDIRS is empty, compute the latest releases | |
380 | ;; for the current directory. This is necessary for packages | |
381 | ;; such as 'sharutils' that have a sub-directory that contains | |
382 | ;; only an older release. | |
383 | (releases (filter-map (match-lambda | |
384 | ((file 'file . _) | |
385 | (and (release-file? project file) | |
c4991257 | 386 | (keep-file? file) |
e946f2ec LC |
387 | (file->source directory file))) |
388 | (_ #f)) | |
389 | entries))) | |
390 | ||
391 | ;; Assume that SUBDIRS correspond to versions, and jump into the | |
392 | ;; one with the highest version number. | |
393 | (let* ((release (reduce latest-release #f | |
394 | (coalesce-sources releases))) | |
395 | (result (if (and result release) | |
396 | (latest-release release result) | |
397 | (or release result))) | |
398 | (target (reduce latest #f subdirs))) | |
399 | (if target | |
400 | (loop (string-append directory "/" target) | |
401 | result) | |
402 | (begin | |
403 | (ftp-close conn) | |
404 | result)))))) | |
405 | ||
63e8bb12 LC |
406 | (define* (latest-release package |
407 | #:key | |
408 | (server "ftp.gnu.org") | |
409 | (directory (string-append "/gnu/" package))) | |
e946f2ec | 410 | "Return the <upstream-source> for the latest version of PACKAGE or #f. |
63e8bb12 LC |
411 | PACKAGE must be the canonical name of a GNU package." |
412 | (latest-ftp-release package | |
413 | #:server server | |
414 | #:directory directory)) | |
98fefb21 | 415 | |
e80c0f85 LC |
416 | (define-syntax-rule (false-if-ftp-error exp) |
417 | "Return #f if an FTP error is raise while evaluating EXP; return the result | |
418 | of EXP otherwise." | |
0a7c5a09 LC |
419 | (catch 'ftp-error |
420 | (lambda () | |
e80c0f85 | 421 | exp) |
0a7c5a09 LC |
422 | (lambda (key port . rest) |
423 | (if (ftp-connection? port) | |
424 | (ftp-close port) | |
425 | (close-port port)) | |
426 | #f))) | |
7047133f | 427 | |
e80c0f85 | 428 | (define (latest-release* package) |
63e8bb12 LC |
429 | "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP |
430 | errors that might occur when PACKAGE is not actually a GNU package, or not | |
431 | hosted on ftp.gnu.org, or not under that name (this is the case for | |
432 | \"emacs-auctex\", for instance.)" | |
433 | (let-values (((server directory) | |
434 | (ftp-server/directory package))) | |
3b0fcc67 LC |
435 | (false-if-ftp-error (latest-release (package-upstream-name package) |
436 | #:server server | |
437 | #:directory directory)))) | |
e80c0f85 | 438 | |
100b216d LC |
439 | (define %gnu-file-list-uri |
440 | ;; URI of the file list for ftp.gnu.org. | |
441 | (string->uri "https://ftp.gnu.org/find.txt.gz")) | |
442 | ||
443 | (define ftp.gnu.org-files | |
444 | (mlambda () | |
445 | "Return the list of files available at ftp.gnu.org." | |
446 | ||
447 | ;; XXX: Memoize the whole procedure to work around the fact that | |
448 | ;; 'http-fetch/cached' caches the gzipped version. | |
449 | ||
450 | (define (trim-leading-components str) | |
451 | ;; Trim the leading ".", if any, in "./gnu/foo". | |
452 | (string-trim str (char-set #\.))) | |
453 | ||
454 | (define (string->lines str) | |
455 | (string-tokenize str (char-set-complement (char-set #\newline)))) | |
456 | ||
457 | (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 60 60)))) | |
458 | (map trim-leading-components | |
459 | (call-with-gzip-input-port port | |
460 | (compose string->lines get-string-all)))))) | |
461 | ||
462 | (define (latest-gnu-release package) | |
463 | "Return the latest release of PACKAGE, a GNU package available via | |
464 | ftp.gnu.org. | |
465 | ||
466 | This method does not rely on FTP access at all; instead, it browses the file | |
467 | list available from %GNU-FILE-LIST-URI over HTTP(S)." | |
468 | (let-values (((server directory) | |
469 | (ftp-server/directory package)) | |
470 | ((name) | |
471 | (package-upstream-name package))) | |
472 | (let* ((files (ftp.gnu.org-files)) | |
473 | (relevant (filter (lambda (file) | |
474 | (and (string-contains file directory) | |
475 | (release-file? name (basename file)) | |
476 | )) | |
477 | files))) | |
478 | (match (sort relevant (lambda (file1 file2) | |
479 | (version>? (basename file1) (basename file2)))) | |
480 | ((tarball _ ...) | |
481 | (upstream-source | |
482 | (package name) | |
483 | (version (tarball->version tarball)) | |
484 | (urls (list (string-append "mirror://gnu/" tarball))) | |
485 | (signature-urls (map (cut string-append <> ".sig") urls)))) | |
486 | (() | |
487 | #f))))) | |
488 | ||
98fefb21 LC |
489 | (define %package-name-rx |
490 | ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses | |
491 | ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. | |
492 | (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?")) | |
493 | ||
494 | (define (gnu-package-name->name+version name+version) | |
495 | "Return the package name and version number extracted from NAME+VERSION." | |
496 | (let ((match (regexp-exec %package-name-rx name+version))) | |
497 | (if (not match) | |
498 | (values name+version #f) | |
499 | (values (match:substring match 1) (match:substring match 2))))) | |
500 | ||
e80c0f85 LC |
501 | (define (pure-gnu-package? package) |
502 | "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This | |
503 | excludes AucTeX, for instance, whose releases are now uploaded to | |
2e2cf9a3 LC |
504 | elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its |
505 | releases are on gnu.org." | |
506 | (and (or (not (string-prefix? "emacs-" (package-name package))) | |
507 | (gnu-hosted? package)) | |
e80c0f85 | 508 | (not (gnome-package? package)) |
0a7c5a09 | 509 | (gnu-package? package))) |
0fdd3bea | 510 | |
7632f7bc LC |
511 | (define (url-prefix-predicate prefix) |
512 | "Return a predicate that returns true when passed a package where one of its | |
513 | source URLs starts with PREFIX." | |
514 | (lambda (package) | |
515 | (define matching-uri? | |
516 | (match-lambda | |
517 | ((? string? uri) | |
518 | (string-prefix? prefix uri)) | |
519 | (_ | |
520 | #f))) | |
521 | ||
522 | (match (package-source package) | |
523 | ((? origin? origin) | |
524 | (match (origin-uri origin) | |
525 | ((? matching-uri?) #t) | |
526 | (_ #f))) | |
527 | (_ #f)))) | |
528 | ||
2e2cf9a3 LC |
529 | (define gnu-hosted? |
530 | (url-prefix-predicate "mirror://gnu/")) | |
531 | ||
7632f7bc LC |
532 | (define gnome-package? |
533 | (url-prefix-predicate "mirror://gnome/")) | |
e80c0f85 LC |
534 | |
535 | (define (latest-gnome-release package) | |
536 | "Return the latest release of PACKAGE, the name of a GNOME package." | |
c4991257 LC |
537 | (define %not-dot |
538 | (char-set-complement (char-set #\.))) | |
539 | ||
540 | (define (even-minor-version? version) | |
873d0ff2 LC |
541 | (match (string-tokenize version %not-dot) |
542 | (((= string->number major) (= string->number minor) . rest) | |
543 | (and minor (even? minor))) | |
c4991257 LC |
544 | (_ |
545 | #t))) ;cross fingers | |
546 | ||
873d0ff2 LC |
547 | (define (even-numbered? file) |
548 | ;; Return true if FILE somehow denotes an even-numbered file name. The | |
549 | ;; trick here is that we want this to match both directories such as | |
550 | ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2". | |
551 | (let-values (((name version) (package-name->name+version file))) | |
552 | (even-minor-version? (or version name)))) | |
c4991257 | 553 | |
29d2f451 LC |
554 | (define upstream-name |
555 | ;; Some packages like "NetworkManager" have camel-case names. | |
3b0fcc67 | 556 | (package-upstream-name package)) |
29d2f451 | 557 | |
e80c0f85 | 558 | (false-if-ftp-error |
29d2f451 | 559 | (latest-ftp-release upstream-name |
e80c0f85 LC |
560 | #:server "ftp.gnome.org" |
561 | #:directory (string-append "/pub/gnome/sources/" | |
29d2f451 | 562 | upstream-name) |
6efa6f76 | 563 | |
c4991257 LC |
564 | |
565 | ;; <https://www.gnome.org/gnome-3/source/> explains | |
566 | ;; that odd minor version numbers represent development | |
567 | ;; releases, which we are usually not interested in. | |
873d0ff2 | 568 | #:keep-file? even-numbered? |
c4991257 | 569 | |
6efa6f76 LC |
570 | ;; ftp.gnome.org provides no signatures, only |
571 | ;; checksums. | |
572 | #:file->signature (const #f)))) | |
e80c0f85 | 573 | |
9c97afe8 DC |
574 | |
575 | (define (latest-kde-release package) | |
576 | "Return the latest release of PACKAGE, the name of an KDE.org package." | |
577 | (let ((uri (string->uri (origin-uri (package-source package))))) | |
578 | (false-if-ftp-error | |
579 | (latest-ftp-release | |
3b0fcc67 | 580 | (package-upstream-name package) |
9c97afe8 DC |
581 | #:server "mirrors.mit.edu" |
582 | #:directory | |
583 | (string-append "/kde" (dirname (dirname (uri-path uri)))) | |
584 | #:file->signature (const #f))))) | |
585 | ||
62061d6b AW |
586 | (define (latest-xorg-release package) |
587 | "Return the latest release of PACKAGE, the name of an X.org package." | |
7d27a025 | 588 | (let ((uri (string->uri (origin-uri (package-source package))))) |
62061d6b AW |
589 | (false-if-ftp-error |
590 | (latest-ftp-release | |
7d27a025 | 591 | (package-name package) |
62061d6b AW |
592 | #:server "ftp.freedesktop.org" |
593 | #:directory | |
594 | (string-append "/pub/xorg/" (dirname (uri-path uri))))))) | |
595 | ||
2fd370e8 LC |
596 | (define (latest-kernel.org-release package) |
597 | "Return the latest release of PACKAGE, the name of a kernel.org package." | |
598 | (let ((uri (string->uri (origin-uri (package-source package))))) | |
599 | (false-if-ftp-error | |
600 | (latest-ftp-release | |
601 | (package-name package) | |
602 | #:server "ftp.free.fr" ;a mirror reachable over FTP | |
603 | #:directory (string-append "/mirrors/ftp.kernel.org" | |
604 | (dirname (uri-path uri))) | |
605 | ||
606 | ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of | |
607 | ;; the uncompressed tarball. | |
608 | #:file->signature (lambda (tarball) | |
609 | (string-append (file-sans-extension tarball) | |
610 | ".sign")))))) | |
611 | ||
0a7c5a09 | 612 | (define %gnu-updater |
100b216d | 613 | ;; This is for everything at ftp.gnu.org. |
7e6b490d AK |
614 | (upstream-updater |
615 | (name 'gnu) | |
616 | (description "Updater for GNU packages") | |
100b216d LC |
617 | (pred gnu-hosted?) |
618 | (latest latest-gnu-release))) | |
619 | ||
620 | (define %gnu-ftp-updater | |
621 | ;; This is for GNU packages taken from alternate locations, such as | |
622 | ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent. | |
623 | (upstream-updater | |
624 | (name 'gnu-ftp) | |
625 | (description "Updater for GNU packages only available via FTP") | |
626 | (pred (lambda (package) | |
627 | (and (not (gnu-hosted? package)) | |
628 | (pure-gnu-package? package)))) | |
7e6b490d | 629 | (latest latest-release*))) |
0fdd3bea | 630 | |
e80c0f85 LC |
631 | (define %gnome-updater |
632 | (upstream-updater | |
633 | (name 'gnome) | |
634 | (description "Updater for GNOME packages") | |
635 | (pred gnome-package?) | |
636 | (latest latest-gnome-release))) | |
637 | ||
9c97afe8 DC |
638 | (define %kde-updater |
639 | (upstream-updater | |
640 | (name 'kde) | |
641 | (description "Updater for KDE packages") | |
7632f7bc | 642 | (pred (url-prefix-predicate "mirror://kde/")) |
9c97afe8 DC |
643 | (latest latest-kde-release))) |
644 | ||
62061d6b AW |
645 | (define %xorg-updater |
646 | (upstream-updater | |
647 | (name 'xorg) | |
648 | (description "Updater for X.org packages") | |
7632f7bc | 649 | (pred (url-prefix-predicate "mirror://xorg/")) |
62061d6b AW |
650 | (latest latest-xorg-release))) |
651 | ||
2fd370e8 LC |
652 | (define %kernel.org-updater |
653 | (upstream-updater | |
654 | (name 'kernel.org) | |
655 | (description "Updater for packages hosted on kernel.org") | |
656 | (pred (url-prefix-predicate "mirror://kernel.org/")) | |
657 | (latest latest-kernel.org-release))) | |
658 | ||
98fefb21 | 659 | ;;; gnu-maintenance.scm ends here |