1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
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.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
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.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
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)
25 #:use-module (ice-9 match)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-11)
28 #:use-module (srfi srfi-26)
29 #:use-module (rnrs io ports)
30 #:use-module (system foreign)
31 #:use-module (guix http-client)
32 #:use-module (guix ftp-client)
33 #:use-module (guix utils)
34 #:use-module (guix memoization)
35 #:use-module (guix records)
36 #:use-module (guix upstream)
37 #:use-module (guix packages)
38 #:use-module (guix zlib)
39 #:export (gnu-package-name
40 gnu-package-mundane-name
41 gnu-package-copyright-holder
46 gnu-package-doc-category
47 gnu-package-doc-summary
48 gnu-package-doc-description
50 gnu-package-download-url
59 gnu-release-archive-types
60 gnu-package-name->name+version
71 ;;; Code for dealing with the maintenance of GNU packages, such as
78 ;;; List of GNU packages.
81 (define %gnumaint-base-url
82 "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/")
84 (define %package-list-url
86 (string-append %gnumaint-base-url "gnupackages.txt")))
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>.
92 (string-append %gnumaint-base-url "pkgblurbs.txt")))
94 (define-record-type* <gnu-package-descriptor>
95 gnu-package-descriptor
96 make-gnu-package-descriptor
98 gnu-package-descriptor?
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)
105 (language gnu-package-language) ; list of strings
106 (logo gnu-package-logo)
107 (doc-category gnu-package-doc-category)
108 (doc-summary gnu-package-doc-summary)
109 (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
110 (doc-urls gnu-package-doc-urls) ; list of strings
111 (download-url gnu-package-download-url))
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."
117 (define (read-records port)
118 ;; Return a list of alists. Each alist contains fields of a GNU
120 (let loop ((alist (recutils->alist port))
124 (loop (recutils->alist port)
125 (cons alist result)))))
127 (define official-description
128 (let ((db (read-records (fetch %package-description-url #:text? #t))))
130 ;; Return the description found upstream for package NAME, or #f.
131 (and=> (find (lambda (alist)
132 (equal? name (assoc-ref alist "package")))
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
144 (not (string-prefix? "redirect " field))
148 (let ((name (assoc-ref alist "package")))
149 (alist->record `(("description" . ,(official-description name))
151 make-gnu-package-descriptor
152 (list "package" "mundane-name" "copyright-holder"
153 "savannah" "fsd" "language" "logo"
154 "doc-category" "doc-summary" "description"
157 '("doc-url" "language"))))
158 (let* ((port (fetch %package-list-url #:text? #t))
159 (lst (read-records port)))
163 (define (find-package name)
164 "Find GNU package called NAME and return it. Return #f if it was not
166 (find (lambda (package)
167 (string=? name (gnu-package-name package)))
168 (official-gnu-packages)))
171 (let ((official-gnu-packages (memoize official-gnu-packages)))
173 "Return true if PACKAGE is a GNU package. This procedure may access the
174 network to check in GNU's database."
175 (define (mirror-type url)
176 (let ((uri (string->uri url)))
177 (and (eq? (uri-scheme uri) 'mirror)
179 ((member (uri-host uri)
180 '("gnu" "gnupg" "gcc" "gnome"))
183 ((equal? (uri-host uri) "cran")
184 ;; Possibly GNU: mirror://cran could be either GNU R itself
185 ;; or a non-GNU package.
188 ;; Definitely non-GNU.
191 (define (gnu-home-page? package)
192 (letrec-syntax ((>> (syntax-rules ()
195 ((_ value proc rest ...)
198 (>> (proc next) rest ...)))))))
199 (>> package package-home-page
202 (member host '("www.gnu.org" "gnu.org"))))))
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))
211 (and (member name (map gnu-package-name (official-gnu-packages)))
219 (define (ftp-server/directory package)
220 "Return the FTP server and directory where PACKAGE's tarball are stored."
221 (let ((name (package-upstream-name package)))
222 (values (or (assoc-ref (package-properties package) 'ftp-server)
224 (or (assoc-ref (package-properties package) 'ftp-directory)
225 (string-append "/gnu/" name)))))
227 (define (sans-extension tarball)
228 "Return TARBALL without its .tar.* or .zip extension."
229 (let ((end (or (string-contains tarball ".tar")
230 (string-contains tarball ".zip"))))
231 (substring tarball 0 end)))
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$)"))
239 (define %alpha-tarball-rx
240 (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
242 (define (release-file? project file)
243 "Return #f if FILE is not a release tarball of PROJECT, otherwise return
245 (and (not (string-suffix? ".sig" file))
246 (and=> (regexp-exec %tarball-rx file)
248 ;; Filter out unrelated files, like `guile-www-1.1.1'.
249 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
250 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
251 (and=> (match:substring match 1)
253 (or (string-ci=? name project)
255 (string-append project
257 (not (regexp-exec %alpha-tarball-rx file))
258 (let ((s (sans-extension file)))
259 (regexp-exec %package-name-rx s))))
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))))
268 (define* (releases project
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."
274 ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
275 (define conn (ftp-open server))
277 (let loop ((directories (list directory))
282 (coalesce-sources result))
283 ((directory rest ...)
284 (let* ((files (ftp-list conn directory))
285 (subdirs (filter-map (match-lambda
286 ((name 'directory . _) name)
289 (define (file->url file)
290 (string-append "ftp://" server directory "/" file))
292 (define (file->source file)
293 (let ((url (file->url file)))
296 (version (tarball->version file))
298 (signature-urls (list (string-append url ".sig"))))))
300 (loop (append (map (cut string-append directory "/" <>)
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
310 (and (release-file? project file)
311 (file->source file)))
316 (define* (latest-ftp-release project
318 (server "ftp.gnu.org")
319 (directory (string-append "/gnu/" project))
320 (keep-file? (const #t))
321 (file->signature (cut string-append <> ".sig"))
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
325 connections; this can be useful to reuse connections.
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.
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."
333 (if (version>? a b) a b))
335 (define (latest-release a b)
336 (if (version>? (upstream-source-version a) (upstream-source-version b))
339 (define contains-digit?
340 (cut string-any char-set:digit <>))
342 (define patch-directory-name?
343 ;; Return #t for patch directory names such as 'bash-4.2-patches'.
344 (cut string-suffix? "patches" <>))
346 (define conn (ftp-open server))
348 (define (file->url directory file)
349 (string-append "ftp://" server directory "/" file))
351 (define (file->source directory file)
352 (let ((url (file->url directory file)))
355 (version (tarball->version file))
357 (signature-urls (match (file->signature url)
359 (sig (list sig)))))))
361 (let loop ((directory directory)
363 (let* ((entries (ftp-list conn directory))
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)
372 (("w32" 'directory . _)
374 (((? contains-digit? dir) 'directory . _)
375 (and (keep-file? dir) dir))
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
385 (and (release-file? project file)
387 (file->source directory file)))
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)))
400 (loop (string-append directory "/" target)
406 (define* (latest-release package
408 (server "ftp.gnu.org")
409 (directory (string-append "/gnu/" package)))
410 "Return the <upstream-source> for the latest version of PACKAGE or #f.
411 PACKAGE must be the canonical name of a GNU package."
412 (latest-ftp-release package
414 #:directory directory))
416 (define-syntax-rule (false-if-ftp-error exp)
417 "Return #f if an FTP error is raise while evaluating EXP; return the result
422 (lambda (key port . rest)
423 (if (ftp-connection? port)
428 (define (latest-release* package)
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)))
435 (false-if-ftp-error (latest-release (package-upstream-name package)
437 #:directory directory))))
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"))
443 (define ftp.gnu.org-files
445 "Return the list of files available at ftp.gnu.org."
447 ;; XXX: Memoize the whole procedure to work around the fact that
448 ;; 'http-fetch/cached' caches the gzipped version.
450 (define (trim-leading-components str)
451 ;; Trim the leading ".", if any, in "./gnu/foo".
452 (string-trim str (char-set #\.)))
454 (define (string->lines str)
455 (string-tokenize str (char-set-complement (char-set #\newline))))
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))))))
462 (define (latest-gnu-release package)
463 "Return the latest release of PACKAGE, a GNU package available via
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))
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))
478 (match (sort relevant (lambda (file1 file2)
479 (version>? (basename file1) (basename file2))))
483 (version (tarball->version tarball))
484 (urls (list (string-append "mirror://gnu/" tarball)))
485 (signature-urls (map (cut string-append <> ".sig") urls))))
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)?"))
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)))
498 (values name+version #f)
499 (values (match:substring match 1) (match:substring match 2)))))
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
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))
508 (not (gnome-package? package))
509 (gnu-package? package)))
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."
515 (define matching-uri?
518 (string-prefix? prefix uri))
522 (match (package-source package)
524 (match (origin-uri origin)
525 ((? matching-uri?) #t)
530 (url-prefix-predicate "mirror://gnu/"))
532 (define gnome-package?
533 (url-prefix-predicate "mirror://gnome/"))
535 (define (latest-gnome-release package)
536 "Return the latest release of PACKAGE, the name of a GNOME package."
538 (char-set-complement (char-set #\.)))
540 (define (even-minor-version? version)
541 (match (string-tokenize version %not-dot)
542 (((= string->number major) (= string->number minor) . rest)
543 (and minor (even? minor)))
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))))
554 (define upstream-name
555 ;; Some packages like "NetworkManager" have camel-case names.
556 (package-upstream-name package))
559 (latest-ftp-release upstream-name
560 #:server "ftp.gnome.org"
561 #:directory (string-append "/pub/gnome/sources/"
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.
568 #:keep-file? even-numbered?
570 ;; ftp.gnome.org provides no signatures, only
572 #:file->signature (const #f))))
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)))))
580 (package-upstream-name package)
581 #:server "mirrors.mit.edu"
583 (string-append "/kde" (dirname (dirname (uri-path uri))))
584 #:file->signature (const #f)))))
586 (define (latest-xorg-release package)
587 "Return the latest release of PACKAGE, the name of an X.org package."
588 (let ((uri (string->uri (origin-uri (package-source package)))))
591 (package-name package)
592 #:server "ftp.freedesktop.org"
594 (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
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)))))
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)))
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)
613 ;; This is for everything at ftp.gnu.org.
616 (description "Updater for GNU packages")
618 (latest latest-gnu-release)))
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.
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))))
629 (latest latest-release*)))
631 (define %gnome-updater
634 (description "Updater for GNOME packages")
635 (pred gnome-package?)
636 (latest latest-gnome-release)))
641 (description "Updater for KDE packages")
642 (pred (url-prefix-predicate "mirror://kde/"))
643 (latest latest-kde-release)))
645 (define %xorg-updater
648 (description "Updater for X.org packages")
649 (pred (url-prefix-predicate "mirror://xorg/"))
650 (latest latest-xorg-release)))
652 (define %kernel.org-updater
655 (description "Updater for packages hosted on kernel.org")
656 (pred (url-prefix-predicate "mirror://kernel.org/"))
657 (latest latest-kernel.org-release)))
659 ;;; gnu-maintenance.scm ends here