guix/gnu-maintenance.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   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.
  11 ;;;
  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.
  16 ;;;
  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/>.
  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 (sxml simple)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 match)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (rnrs io ports)
  31   #:use-module (system foreign)
  32   #:use-module (guix http-client)
  33   #:use-module (guix ftp-client)
  34   #:use-module (guix utils)
  35   #:use-module (guix memoization)
  36   #:use-module (guix records)
  37   #:use-module (guix upstream)
  38   #:use-module (guix packages)
  39   #:use-module (guix zlib)
  40   #:export (gnu-package-name
  41             gnu-package-mundane-name
  42             gnu-package-copyright-holder
  43             gnu-package-savannah
  44             gnu-package-fsd
  45             gnu-package-language
  46             gnu-package-logo
  47             gnu-package-doc-category
  48             gnu-package-doc-summary
  49             gnu-package-doc-description
  50             gnu-package-doc-urls
  51             gnu-package-download-url
  52
  53             official-gnu-packages
  54             find-package
  55             gnu-package?
  56
  57             release-file?
  58             releases
  59             latest-release
  60             gnu-release-archive-types
  61             gnu-package-name->name+version
  62
  63             %gnu-updater
  64             %gnu-ftp-updater
  65             %xorg-updater
  66             %kernel.org-updater))
  67
  68 ;;; Commentary:
  69 ;;;
  70 ;;; Code for dealing with the maintenance of GNU packages, such as
  71 ;;; auto-updates.
  72 ;;;
  73 ;;; Code:
  74
  75 \f
  76 ;;;
  77 ;;; List of GNU packages.
  78 ;;;
  79
  80 (define %gnumaint-base-url
  81   "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
  82
  83 (define %package-list-url
  84   (string->uri
  85    (string-append %gnumaint-base-url "rec/gnupackages.rec")))
  86
  87 (define %package-description-url
  88   ;; This file contains package descriptions in recutils format.
  89   ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
  90   ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  91   (string->uri
  92    (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
  93
  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)
 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))
 112
 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
 119     ;; package.
 120     (let loop ((alist  (recutils->alist port))
 121                (result '()))
 122       (if (null? alist)
 123           (reverse result)
 124           (loop (recutils->alist port)
 125
 126                 ;; Ignore things like "%rec" (info "(recutils) Record
 127                 ;; Descriptors").
 128                 (if (assoc-ref alist "package")
 129                     (cons alist result)
 130                     result)))))
 131
 132   (define official-description
 133     (let ((db (read-records (fetch %package-description-url #:text? #t))))
 134       (lambda (name)
 135         ;; Return the description found upstream for package NAME, or #f.
 136         (and=> (find (lambda (alist)
 137                        (equal? name (assoc-ref alist "package")))
 138                      db)
 139                (lambda (record)
 140                  (let ((field (assoc-ref record "blurb")))
 141                    ;; The upstream description file uses "redirect PACKAGE" as
 142                    ;; a blurb in cases where the description of the two
 143                    ;; packages should be considered the same (e.g., GTK+ has
 144                    ;; "redirect gnome".)  This is usually not acceptable for
 145                    ;; us because we prefer to have distinct descriptions in
 146                    ;; such cases.  Thus, ignore the 'blurb' field when that
 147                    ;; happens.
 148                    (and field
 149                         (not (string-prefix? "redirect " field))
 150                         field)))))))
 151
 152   (map (lambda (alist)
 153          (let ((name (assoc-ref alist "package")))
 154            (alist->record `(("description" . ,(official-description name))
 155                             ,@alist)
 156                           make-gnu-package-descriptor
 157                           (list "package" "mundane_name" "copyright_holder"
 158                                 "savannah" "fsd" "language" "logo"
 159                                 "doc_category" "doc_summary" "description"
 160                                 "doc_url"
 161                                 "download_url")
 162                           '("doc_url" "language"))))
 163        (let* ((port (fetch %package-list-url #:text? #t))
 164               (lst  (read-records port)))
 165          (close-port port)
 166          lst)))
 167
 168 (define (find-package name)
 169   "Find GNU package called NAME and return it.  Return #f if it was not
 170 found."
 171   (find (lambda (package)
 172           (string=? name (gnu-package-name package)))
 173         (official-gnu-packages)))
 174
 175 (define gnu-package?
 176   (let ((official-gnu-packages (memoize official-gnu-packages)))
 177     (mlambdaq (package)
 178       "Return true if PACKAGE is a GNU package.  This procedure may access the
 179 network to check in GNU's database."
 180       (define (mirror-type url)
 181         (let ((uri (string->uri url)))
 182           (and (eq? (uri-scheme uri) 'mirror)
 183                (cond
 184                 ((member (uri-host uri)
 185                          '("gnu" "gnupg" "gcc" "gnome"))
 186                  ;; Definitely GNU.
 187                  'gnu)
 188                 ((equal? (uri-host uri) "cran")
 189                  ;; Possibly GNU: mirror://cran could be either GNU R itself
 190                  ;; or a non-GNU package.
 191                  #f)
 192                 (else
 193                  ;; Definitely non-GNU.
 194                  'non-gnu)))))
 195
 196       (define (gnu-home-page? package)
 197         (letrec-syntax ((>> (syntax-rules ()
 198                               ((_ value proc)
 199                                (and=> value proc))
 200                               ((_ value proc rest ...)
 201                                (and=> value
 202                                       (lambda (next)
 203                                         (>> (proc next) rest ...)))))))
 204           (>> package package-home-page
 205               string->uri uri-host
 206               (lambda (host)
 207                 (member host '("www.gnu.org" "gnu.org"))))))
 208
 209       (or (gnu-home-page? package)
 210           (let ((url  (and=> (package-source package) origin-uri))
 211                 (name (package-upstream-name package)))
 212             (case (and (string? url) (mirror-type url))
 213               ((gnu) #t)
 214               ((non-gnu) #f)
 215               (else
 216                (and (member name (map gnu-package-name (official-gnu-packages)))
 217                     #t))))))))
 218
 219 \f
 220 ;;;
 221 ;;; Latest FTP release.
 222 ;;;
 223
 224 (define (ftp-server/directory package)
 225   "Return the FTP server and directory where PACKAGE's tarball are stored."
 226   (let ((name (package-upstream-name package)))
 227     (values (or (assoc-ref (package-properties package) 'ftp-server)
 228                 "ftp.gnu.org")
 229             (or (assoc-ref (package-properties package) 'ftp-directory)
 230                 (string-append "/gnu/" name)))))
 231
 232 (define %tarball-rx
 233   ;; The .zip extensions is notably used for freefont-ttf.
 234   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 235   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 236   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 237
 238 (define %alpha-tarball-rx
 239   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 240
 241 (define (release-file? project file)
 242   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 243 true."
 244   (and (not (member (file-extension file) '("sig" "sign" "asc")))
 245        (and=> (regexp-exec %tarball-rx file)
 246               (lambda (match)
 247                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 248                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 249                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 250                 (and=> (match:substring match 1)
 251                        (lambda (name)
 252                          (or (string-ci=? name project)
 253                              (string-ci=? name
 254                                           (string-append project
 255                                                          "-src")))))))
 256        (not (regexp-exec %alpha-tarball-rx file))
 257        (let ((s (tarball-sans-extension file)))
 258          (regexp-exec %package-name-rx s))))
 259
 260 (define (tarball->version tarball)
 261   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 262 \"coreutils-8.23.tar.xz\"."
 263   (let-values (((name version)
 264                 (gnu-package-name->name+version
 265                  (tarball-sans-extension tarball))))
 266     version))
 267
 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."
 274   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 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)))))))
 315
 316 (define* (latest-ftp-release project
 317                              #:key
 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.
 326
 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.
 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."
 332   (define (latest a b)
 333     (if (version>? a b) a b))
 334
 335   (define (latest-release a b)
 336     (if (version>? (upstream-source-version a) (upstream-source-version b))
 337         a b))
 338
 339   (define patch-directory-name?
 340     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 341     (cut string-suffix? "patches" <>))
 342
 343   (define conn (ftp-open server))
 344
 345   (define (file->url directory file)
 346     (string-append "ftp://" server directory "/" file))
 347
 348   (define (file->source directory file)
 349     (let ((url (file->url directory file)))
 350       (upstream-source
 351        (package project)
 352        (version (tarball->version file))
 353        (urls (list url))
 354        (signature-urls (match (file->signature url)
 355                          (#f #f)
 356                          (sig (list sig)))))))
 357
 358   (let loop ((directory directory)
 359              (result    #f))
 360     (let* ((entries (ftp-list conn directory))
 361
 362            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 363            ;; directories as found on ftp.gnutls.org.
 364            (subdirs (filter-map (match-lambda
 365                                   (((? patch-directory-name? dir)
 366                                     'directory . _)
 367                                    #f)
 368                                   (("w32" 'directory . _)
 369                                    #f)
 370                                   (("unstable" 'directory . _)
 371                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 372                                    #f)
 373                                   ((directory 'directory . _)
 374                                    directory)
 375                                   (_ #f))
 376                                 entries))
 377
 378            ;; Whether or not SUBDIRS is empty, compute the latest releases
 379            ;; for the current directory.  This is necessary for packages
 380            ;; such as 'sharutils' that have a sub-directory that contains
 381            ;; only an older release.
 382            (releases (filter-map (match-lambda
 383                                    ((file 'file . _)
 384                                     (and (release-file? project file)
 385                                          (keep-file? file)
 386                                          (file->source directory file)))
 387                                    (_ #f))
 388                                  entries)))
 389
 390       ;; Assume that SUBDIRS correspond to versions, and jump into the
 391       ;; one with the highest version number.
 392       (let* ((release  (reduce latest-release #f
 393                                (coalesce-sources releases)))
 394              (result   (if (and result release)
 395                            (latest-release release result)
 396                            (or release result)))
 397              (target   (reduce latest #f subdirs)))
 398         (if target
 399             (loop (string-append directory "/" target)
 400                   result)
 401             (begin
 402               (ftp-close conn)
 403               result))))))
 404
 405 (define* (latest-release package
 406                          #:key
 407                          (server "ftp.gnu.org")
 408                          (directory (string-append "/gnu/" package)))
 409   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 410 PACKAGE must be the canonical name of a GNU package."
 411   (latest-ftp-release package
 412                       #:server server
 413                       #:directory directory))
 414
 415 (define-syntax-rule (false-if-ftp-error exp)
 416   "Return #f if an FTP error is raise while evaluating EXP; return the result
 417 of EXP otherwise."
 418   (catch 'ftp-error
 419     (lambda ()
 420       exp)
 421     (lambda (key port . rest)
 422       (if (ftp-connection? port)
 423           (ftp-close port)
 424           (close-port port))
 425       #f)))
 426
 427 (define (latest-release* package)
 428   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 429 errors that might occur when PACKAGE is not actually a GNU package, or not
 430 hosted on ftp.gnu.org, or not under that name (this is the case for
 431 \"emacs-auctex\", for instance.)"
 432   (let-values (((server directory)
 433                 (ftp-server/directory package)))
 434     (false-if-ftp-error (latest-release (package-upstream-name package)
 435                                         #:server server
 436                                         #:directory directory))))
 437
 438 \f
 439 ;;;
 440 ;;; Latest HTTP release.
 441 ;;;
 442
 443 (define (html->sxml port)
 444   "Read HTML from PORT and return the corresponding SXML tree."
 445   (let ((str (get-string-all port)))
 446     (catch #t
 447       (lambda ()
 448         ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
 449         ;; enough for directory listings at <https://kernel.org/pub> but if
 450         ;; needed we could resort to (htmlprag) from Guile-Lib.
 451         (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
 452           xml->sxml))
 453       (const '(html)))))                          ;parse error
 454
 455 (define (html-links sxml)
 456   "Return the list of links found in SXML, the SXML tree of an HTML page."
 457   (let loop ((sxml sxml)
 458              (links '()))
 459     (match sxml
 460       (('a ('@ attributes ...) body ...)
 461        (match (assq 'href attributes)
 462          (#f          (fold loop links body))
 463          (('href url) (fold loop (cons url links) body))))
 464       ((tag ('@ _ ...) body ...)
 465        (fold loop links body))
 466       ((tag body ...)
 467        (fold loop links body))
 468       (_
 469        links))))
 470
 471 (define* (latest-html-release package
 472                               #:key
 473                               (base-url "https://kernel.org/pub")
 474                               (directory (string-append "/" package))
 475                               (file->signature (cut string-append <> ".sig")))
 476   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 477 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 478 typically a directory listing as found on 'https://kernel.org/pub'.
 479
 480 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 481 return the corresponding signature URL, or #f it signatures are unavailable."
 482   (let* ((uri  (string->uri (string-append base-url directory "/")))
 483          (port (http-fetch/cached uri #:ttl 3600))
 484          (sxml (html->sxml port)))
 485     (define (url->release url)
 486       (and (string=? url (basename url))          ;relative reference?
 487            (release-file? package url)
 488            (let-values (((name version)
 489                          (package-name->name+version
 490                           (tarball-sans-extension url)
 491                           #\-)))
 492              (upstream-source
 493               (package name)
 494               (version version)
 495               (urls (list (string-append base-url directory "/" url)))
 496               (signature-urls
 497                (list (string-append base-url directory "/"
 498                                     (file-sans-extension url)
 499                                     ".sign")))))))
 500
 501     (define candidates
 502       (filter-map url->release (html-links sxml)))
 503
 504     (close-port port)
 505     (match candidates
 506       (() #f)
 507       ((first . _)
 508        ;; Select the most recent release and return it.
 509        (reduce (lambda (r1 r2)
 510                  (if (version>? (upstream-source-version r1)
 511                                 (upstream-source-version r2))
 512                      r1 r2))
 513                first
 514                (coalesce-sources candidates))))))
 515
 516 \f
 517 ;;;
 518 ;;; Updaters.
 519 ;;;
 520
 521 (define %gnu-file-list-uri
 522   ;; URI of the file list for ftp.gnu.org.
 523   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 524
 525 (define ftp.gnu.org-files
 526   (mlambda ()
 527     "Return the list of files available at ftp.gnu.org."
 528
 529     ;; XXX: Memoize the whole procedure to work around the fact that
 530     ;; 'http-fetch/cached' caches the gzipped version.
 531
 532     (define (trim-leading-components str)
 533       ;; Trim the leading ".", if any, in "./gnu/foo".
 534       (string-trim str (char-set #\.)))
 535
 536     (define (string->lines str)
 537       (string-tokenize str (char-set-complement (char-set #\newline))))
 538
 539     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 540     ;; TTL can be relatively short.
 541     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 542       (map trim-leading-components
 543            (call-with-gzip-input-port port
 544              (compose string->lines get-string-all))))))
 545
 546 (define (latest-gnu-release package)
 547   "Return the latest release of PACKAGE, a GNU package available via
 548 ftp.gnu.org.
 549
 550 This method does not rely on FTP access at all; instead, it browses the file
 551 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 552   (let-values (((server directory)
 553                 (ftp-server/directory package))
 554                ((name)
 555                 (package-upstream-name package)))
 556     (let* ((files    (ftp.gnu.org-files))
 557            (relevant (filter (lambda (file)
 558                                (and (string-prefix? "/gnu" file)
 559                                     (string-contains file directory)
 560                                     (release-file? name (basename file))))
 561                              files)))
 562       (match (sort relevant (lambda (file1 file2)
 563                               (version>? (tarball-sans-extension
 564                                           (basename file1))
 565                                          (tarball-sans-extension
 566                                           (basename file2)))))
 567         ((and tarballs (reference _ ...))
 568          (let* ((version  (tarball->version reference))
 569                 (tarballs (filter (lambda (file)
 570                                     (string=? (tarball-sans-extension
 571                                                (basename file))
 572                                               (tarball-sans-extension
 573                                                (basename reference))))
 574                                   tarballs)))
 575            (upstream-source
 576             (package name)
 577             (version version)
 578             (urls (map (lambda (file)
 579                          (string-append "mirror://gnu/"
 580                                         (string-drop file
 581                                                      (string-length "/gnu/"))))
 582                        tarballs))
 583             (signature-urls (map (cut string-append <> ".sig") urls)))))
 584         (()
 585          #f)))))
 586
 587 (define %package-name-rx
 588   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 589   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 590   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 591
 592 (define (gnu-package-name->name+version name+version)
 593   "Return the package name and version number extracted from NAME+VERSION."
 594   (let ((match (regexp-exec %package-name-rx name+version)))
 595     (if (not match)
 596         (values name+version #f)
 597         (values (match:substring match 1) (match:substring match 2)))))
 598
 599 (define gnome-package?
 600   (url-prefix-predicate "mirror://gnome/"))
 601
 602 (define (pure-gnu-package? package)
 603   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 604 excludes AucTeX, for instance, whose releases are now uploaded to
 605 elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
 606 releases are on gnu.org."
 607   (and (or (not (string-prefix? "emacs-" (package-name package)))
 608            (gnu-hosted? package))
 609        (not (gnome-package? package))
 610        (gnu-package? package)))
 611
 612 (define gnu-hosted?
 613   (url-prefix-predicate "mirror://gnu/"))
 614
 615 (define (latest-xorg-release package)
 616   "Return the latest release of PACKAGE, the name of an X.org package."
 617   (let ((uri (string->uri (origin-uri (package-source package)))))
 618     (false-if-ftp-error
 619      (latest-ftp-release
 620       (package-name package)
 621       #:server "ftp.freedesktop.org"
 622       #:directory
 623       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 624
 625 (define (latest-kernel.org-release package)
 626   "Return the latest release of PACKAGE, the name of a kernel.org package."
 627   (define %kernel.org-base
 628     ;; This URL and sub-directories thereof are nginx-generated directory
 629     ;; listings suitable for 'latest-html-release'.
 630     "https://mirrors.edge.kernel.org/pub")
 631
 632   (define (file->signature file)
 633     (string-append (file-sans-extension file) ".sign"))
 634
 635   (let* ((uri       (string->uri (origin-uri (package-source package))))
 636          (package   (package-upstream-name package))
 637          (directory (dirname (uri-path uri))))
 638     (latest-html-release package
 639                          #:base-url %kernel.org-base
 640                          #:directory directory
 641                          #:file->signature file->signature)))
 642
 643 (define %gnu-updater
 644   ;; This is for everything at ftp.gnu.org.
 645   (upstream-updater
 646    (name 'gnu)
 647    (description "Updater for GNU packages")
 648    (pred gnu-hosted?)
 649    (latest latest-gnu-release)))
 650
 651 (define %gnu-ftp-updater
 652   ;; This is for GNU packages taken from alternate locations, such as
 653   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 654   (upstream-updater
 655    (name 'gnu-ftp)
 656    (description "Updater for GNU packages only available via FTP")
 657    (pred (lambda (package)
 658            (and (not (gnu-hosted? package))
 659                 (pure-gnu-package? package))))
 660    (latest latest-release*)))
 661
 662 (define %xorg-updater
 663   (upstream-updater
 664    (name 'xorg)
 665    (description "Updater for X.org packages")
 666    (pred (url-prefix-predicate "mirror://xorg/"))
 667    (latest latest-xorg-release)))
 668
 669 (define %kernel.org-updater
 670   (upstream-updater
 671    (name 'kernel.org)
 672    (description "Updater for packages hosted on kernel.org")
 673    (pred (url-prefix-predicate "mirror://kernel.org/"))
 674    (latest latest-kernel.org-release)))
 675
 676 ;;; gnu-maintenance.scm ends here