1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 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 (system foreign)
30 #:use-module (guix http-client)
31 #:use-module (guix ftp-client)
32 #:use-module (guix utils)
33 #:use-module (guix combinators)
34 #:use-module (guix records)
35 #:use-module (guix upstream)
36 #:use-module (guix packages)
37 #:export (gnu-package-name
38 gnu-package-mundane-name
39 gnu-package-copyright-holder
44 gnu-package-doc-category
45 gnu-package-doc-summary
46 gnu-package-doc-description
48 gnu-package-download-url
57 gnu-release-archive-types
58 gnu-package-name->name+version
66 ;;; Code for dealing with the maintenance of GNU packages, such as
73 ;;; List of GNU packages.
76 (define %gnumaint-base-url
77 "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/")
79 (define %package-list-url
81 (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
83 (define %package-description-url
84 ;; This file contains package descriptions in recutils format.
85 ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
87 (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
89 (define-record-type* <gnu-package-descriptor>
90 gnu-package-descriptor
91 make-gnu-package-descriptor
93 gnu-package-descriptor?
95 (name gnu-package-name)
96 (mundane-name gnu-package-mundane-name)
97 (copyright-holder gnu-package-copyright-holder)
98 (savannah gnu-package-savannah)
100 (language gnu-package-language) ; list of strings
101 (logo gnu-package-logo)
102 (doc-category gnu-package-doc-category)
103 (doc-summary gnu-package-doc-summary)
104 (doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
105 (doc-urls gnu-package-doc-urls) ; list of strings
106 (download-url gnu-package-download-url))
108 (define* (official-gnu-packages
109 #:optional (fetch http-fetch/cached))
110 "Return a list of records, which are GNU packages. Use FETCH,
111 to fetch the list of GNU packages over HTTP."
112 (define (read-records port)
113 ;; Return a list of alists. Each alist contains fields of a GNU
115 (let loop ((alist (recutils->alist port))
119 (loop (recutils->alist port)
120 (cons alist result)))))
122 (define official-description
123 (let ((db (read-records (fetch %package-description-url #:text? #t))))
125 ;; Return the description found upstream for package NAME, or #f.
126 (and=> (find (lambda (alist)
127 (equal? name (assoc-ref alist "package")))
130 (let ((field (assoc-ref record "blurb")))
131 ;; The upstream description file uses "redirect PACKAGE" as
132 ;; a blurb in cases where the description of the two
133 ;; packages should be considered the same (e.g., GTK+ has
134 ;; "redirect gnome".) This is usually not acceptable for
135 ;; us because we prefer to have distinct descriptions in
136 ;; such cases. Thus, ignore the 'blurb' field when that
139 (not (string-prefix? "redirect " field))
143 (let ((name (assoc-ref alist "package")))
144 (alist->record `(("description" . ,(official-description name))
146 make-gnu-package-descriptor
147 (list "package" "mundane-name" "copyright-holder"
148 "savannah" "fsd" "language" "logo"
149 "doc-category" "doc-summary" "description"
152 '("doc-url" "language"))))
153 (let* ((port (fetch %package-list-url #:text? #t))
154 (lst (read-records port)))
158 (define (find-package name)
159 "Find GNU package called NAME and return it. Return #f if it was not
161 (find (lambda (package)
162 (string=? name (gnu-package-name package)))
163 (official-gnu-packages)))
167 (let ((official-gnu-packages (memoize official-gnu-packages)))
169 "Return true if PACKAGE is a GNU package. This procedure may access the
170 network to check in GNU's database."
171 (define (mirror-type url)
172 (let ((uri (string->uri url)))
173 (and (eq? (uri-scheme uri) 'mirror)
175 ((member (uri-host uri)
176 '("gnu" "gnupg" "gcc" "gnome"))
179 ((equal? (uri-host uri) "cran")
180 ;; Possibly GNU: mirror://cran could be either GNU R itself
181 ;; or a non-GNU package.
184 ;; Definitely non-GNU.
187 (define (gnu-home-page? package)
188 (and=> (package-home-page package)
190 (and=> (uri-host (string->uri url))
192 (member host '("www.gnu.org" "gnu.org")))))))
194 (or (gnu-home-page? package)
195 (let ((url (and=> (package-source package) origin-uri))
196 (name (package-name package)))
197 (case (and (string? url) (mirror-type url))
201 (and (member name (map gnu-package-name (official-gnu-packages)))
209 (define (ftp-server/directory package)
210 "Return the FTP server and directory where PACKAGE's tarball are stored."
211 (values (or (assoc-ref (package-properties package) 'ftp-server)
213 (or (assoc-ref (package-properties package) 'ftp-directory)
214 (string-append "/gnu/" (package-name package)))))
216 (define (sans-extension tarball)
217 "Return TARBALL without its .tar.* or .zip extension."
218 (let ((end (or (string-contains tarball ".tar")
219 (string-contains tarball ".zip"))))
220 (substring tarball 0 end)))
223 ;; The .zip extensions is notably used for freefont-ttf.
224 ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
225 ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
226 (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
228 (define %alpha-tarball-rx
229 (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
231 (define (release-file? project file)
232 "Return #f if FILE is not a release tarball of PROJECT, otherwise return
234 (and (not (string-suffix? ".sig" file))
235 (and=> (regexp-exec %tarball-rx file)
237 ;; Filter out unrelated files, like `guile-www-1.1.1'.
238 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
239 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
240 (and=> (match:substring match 1)
242 (or (string-ci=? name project)
244 (string-append project
246 (not (regexp-exec %alpha-tarball-rx file))
247 (let ((s (sans-extension file)))
248 (regexp-exec %package-name-rx s))))
250 (define (tarball->version tarball)
251 "Return the version TARBALL corresponds to. TARBALL is a file name like
252 \"coreutils-8.23.tar.xz\"."
253 (let-values (((name version)
254 (gnu-package-name->name+version (sans-extension tarball))))
257 (define* (releases project
259 (server "ftp.gnu.org")
260 (directory (string-append "/gnu/" project)))
261 "Return the list of <upstream-release> of PROJECT as a list of release
262 name/directory pairs."
263 ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
264 (define conn (ftp-open server))
266 (let loop ((directories (list directory))
271 (coalesce-sources result))
272 ((directory rest ...)
273 (let* ((files (ftp-list conn directory))
274 (subdirs (filter-map (match-lambda
275 ((name 'directory . _) name)
278 (define (file->url file)
279 (string-append "ftp://" server directory "/" file))
281 (define (file->source file)
282 (let ((url (file->url file)))
285 (version (tarball->version file))
287 (signature-urls (list (string-append url ".sig"))))))
289 (loop (append (map (cut string-append directory "/" <>)
293 ;; Filter out signatures, deltas, and files which
294 ;; are potentially not releases of PROJECT--e.g.,
295 ;; in /gnu/guile, filter out guile-oops and
296 ;; guile-www; in mit-scheme, filter out binaries.
297 (filter-map (match-lambda
299 (and (release-file? project file)
300 (file->source file)))
305 (define* (latest-ftp-release project
307 (server "ftp.gnu.org")
308 (directory (string-append "/gnu/" project))
309 (keep-file? (const #t))
310 (file->signature (cut string-append <> ".sig"))
311 (ftp-open ftp-open) (ftp-close ftp-close))
312 "Return an <upstream-source> for the latest release of PROJECT on SERVER
313 under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
314 connections; this can be useful to reuse connections.
316 KEEP-FILE? is a predicate to decide whether to enter a directory and to
317 consider a given file (source tarball) as a valid candidate based on its name.
319 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
320 return the corresponding signature URL, or #f it signatures are unavailable."
322 (if (version>? a b) a b))
324 (define (latest-release a b)
325 (if (version>? (upstream-source-version a) (upstream-source-version b))
328 (define contains-digit?
329 (cut string-any char-set:digit <>))
331 (define patch-directory-name?
332 ;; Return #t for patch directory names such as 'bash-4.2-patches'.
333 (cut string-suffix? "patches" <>))
335 (define conn (ftp-open server))
337 (define (file->url directory file)
338 (string-append "ftp://" server directory "/" file))
340 (define (file->source directory file)
341 (let ((url (file->url directory file)))
344 (version (tarball->version file))
346 (signature-urls (match (file->signature url)
348 (sig (list sig)))))))
350 (let loop ((directory directory)
352 (let* ((entries (ftp-list conn directory))
354 ;; Filter out sub-directories that do not contain digits---e.g.,
355 ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32"
356 ;; directories as found on ftp.gnutls.org.
357 (subdirs (filter-map (match-lambda
358 (((? patch-directory-name? dir)
361 (("w32" 'directory . _)
363 (((? contains-digit? dir) 'directory . _)
364 (and (keep-file? dir) dir))
368 ;; Whether or not SUBDIRS is empty, compute the latest releases
369 ;; for the current directory. This is necessary for packages
370 ;; such as 'sharutils' that have a sub-directory that contains
371 ;; only an older release.
372 (releases (filter-map (match-lambda
374 (and (release-file? project file)
376 (file->source directory file)))
380 ;; Assume that SUBDIRS correspond to versions, and jump into the
381 ;; one with the highest version number.
382 (let* ((release (reduce latest-release #f
383 (coalesce-sources releases)))
384 (result (if (and result release)
385 (latest-release release result)
386 (or release result)))
387 (target (reduce latest #f subdirs)))
389 (loop (string-append directory "/" target)
395 (define* (latest-release package
397 (server "ftp.gnu.org")
398 (directory (string-append "/gnu/" package)))
399 "Return the <upstream-source> for the latest version of PACKAGE or #f.
400 PACKAGE must be the canonical name of a GNU package."
401 (latest-ftp-release package
403 #:directory directory))
405 (define-syntax-rule (false-if-ftp-error exp)
406 "Return #f if an FTP error is raise while evaluating EXP; return the result
411 (lambda (key port . rest)
412 (if (ftp-connection? port)
417 (define (latest-release* package)
418 "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
419 errors that might occur when PACKAGE is not actually a GNU package, or not
420 hosted on ftp.gnu.org, or not under that name (this is the case for
421 \"emacs-auctex\", for instance.)"
422 (let-values (((server directory)
423 (ftp-server/directory package)))
424 (let ((name (or (assoc-ref (package-properties package) 'upstream-name)
425 (package-name package))))
426 (false-if-ftp-error (latest-release name
428 #:directory directory)))))
430 (define %package-name-rx
431 ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
432 ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
433 (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
435 (define (gnu-package-name->name+version name+version)
436 "Return the package name and version number extracted from NAME+VERSION."
437 (let ((match (regexp-exec %package-name-rx name+version)))
439 (values name+version #f)
440 (values (match:substring match 1) (match:substring match 2)))))
442 (define (pure-gnu-package? package)
443 "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package. This
444 excludes AucTeX, for instance, whose releases are now uploaded to
445 elpa.gnu.org, and all the GNOME packages."
446 (and (not (string-prefix? "emacs-" (package-name package)))
447 (not (gnome-package? package))
448 (gnu-package? package)))
450 (define (gnome-package? package)
451 "Return true if PACKAGE is a GNOME package, hosted on gnome.org."
455 (string-prefix? "mirror://gnome/" uri))
459 (match (package-source package)
461 (match (origin-uri origin)
466 (define (latest-gnome-release package)
467 "Return the latest release of PACKAGE, the name of a GNOME package."
469 (char-set-complement (char-set #\.)))
471 (define (even-minor-version? version)
472 (match (string-tokenize version %not-dot)
473 (((= string->number major) (= string->number minor) . rest)
474 (and minor (even? minor)))
478 (define (even-numbered? file)
479 ;; Return true if FILE somehow denotes an even-numbered file name. The
480 ;; trick here is that we want this to match both directories such as
481 ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2".
482 (let-values (((name version) (package-name->name+version file)))
483 (even-minor-version? (or version name))))
486 (latest-ftp-release (package-name package)
487 #:server "ftp.gnome.org"
488 #:directory (string-append "/pub/gnome/sources/"
489 (match (package-name package)
494 ;; <https://www.gnome.org/gnome-3/source/> explains
495 ;; that odd minor version numbers represent development
496 ;; releases, which we are usually not interested in.
497 #:keep-file? even-numbered?
499 ;; ftp.gnome.org provides no signatures, only
501 #:file->signature (const #f))))
503 (define (xorg-package? package)
504 "Return true if PACKAGE is an X.org package, developed by X.org."
508 (string-prefix? "mirror://xorg/" uri))
512 (match (package-source package)
514 (match (origin-uri origin)
519 (define (latest-xorg-release package)
520 "Return the latest release of PACKAGE, the name of an X.org package."
521 (let ((uri (string->uri (origin-uri (package-source package)))))
524 (package-name package)
525 #:server "ftp.freedesktop.org"
527 (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
532 (description "Updater for GNU packages")
533 (pred pure-gnu-package?)
534 (latest latest-release*)))
536 (define %gnome-updater
539 (description "Updater for GNOME packages")
540 (pred gnome-package?)
541 (latest latest-gnome-release)))
543 (define %xorg-updater
546 (description "Updater for X.org packages")
548 (latest latest-xorg-release)))
550 ;;; gnu-maintenance.scm ends here