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             %kde-updater
  66             %xorg-updater
  67             %kernel.org-updater))
  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 ;;;
  80
  81 (define %gnumaint-base-url
  82   "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
  83
  84 (define %package-list-url
  85   (string->uri
  86    (string-append %gnumaint-base-url "rec/gnupackages.rec")))
  87
  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   ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  92   (string->uri
  93    (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
  94
  95 (define-record-type* <gnu-package-descriptor>
  96   gnu-package-descriptor
  97   make-gnu-package-descriptor
  98
  99   gnu-package-descriptor?
 100
 101   (name             gnu-package-name)
 102   (mundane-name     gnu-package-mundane-name)
 103   (copyright-holder gnu-package-copyright-holder)
 104   (savannah         gnu-package-savannah)
 105   (fsd              gnu-package-fsd)
 106   (language         gnu-package-language)         ; list of strings
 107   (logo             gnu-package-logo)
 108   (doc-category     gnu-package-doc-category)
 109   (doc-summary      gnu-package-doc-summary)
 110   (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
 111   (doc-urls         gnu-package-doc-urls)         ; list of strings
 112   (download-url     gnu-package-download-url))
 113
 114 (define* (official-gnu-packages
 115           #:optional (fetch http-fetch/cached))
 116   "Return a list of records, which are GNU packages.  Use FETCH,
 117 to fetch the list of GNU packages over HTTP."
 118   (define (read-records port)
 119     ;; Return a list of alists.  Each alist contains fields of a GNU
 120     ;; package.
 121     (let loop ((alist  (recutils->alist port))
 122                (result '()))
 123       (if (null? alist)
 124           (reverse result)
 125           (loop (recutils->alist port)
 126
 127                 ;; Ignore things like "%rec" (info "(recutils) Record
 128                 ;; Descriptors").
 129                 (if (assoc-ref alist "package")
 130                     (cons alist result)
 131                     result)))))
 132
 133   (define official-description
 134     (let ((db (read-records (fetch %package-description-url #:text? #t))))
 135       (lambda (name)
 136         ;; Return the description found upstream for package NAME, or #f.
 137         (and=> (find (lambda (alist)
 138                        (equal? name (assoc-ref alist "package")))
 139                      db)
 140                (lambda (record)
 141                  (let ((field (assoc-ref record "blurb")))
 142                    ;; The upstream description file uses "redirect PACKAGE" as
 143                    ;; a blurb in cases where the description of the two
 144                    ;; packages should be considered the same (e.g., GTK+ has
 145                    ;; "redirect gnome".)  This is usually not acceptable for
 146                    ;; us because we prefer to have distinct descriptions in
 147                    ;; such cases.  Thus, ignore the 'blurb' field when that
 148                    ;; happens.
 149                    (and field
 150                         (not (string-prefix? "redirect " field))
 151                         field)))))))
 152
 153   (map (lambda (alist)
 154          (let ((name (assoc-ref alist "package")))
 155            (alist->record `(("description" . ,(official-description name))
 156                             ,@alist)
 157                           make-gnu-package-descriptor
 158                           (list "package" "mundane_name" "copyright_holder"
 159                                 "savannah" "fsd" "language" "logo"
 160                                 "doc_category" "doc_summary" "description"
 161                                 "doc_url"
 162                                 "download_url")
 163                           '("doc_url" "language"))))
 164        (let* ((port (fetch %package-list-url #:text? #t))
 165               (lst  (read-records port)))
 166          (close-port port)
 167          lst)))
 168
 169 (define (find-package name)
 170   "Find GNU package called NAME and return it.  Return #f if it was not
 171 found."
 172   (find (lambda (package)
 173           (string=? name (gnu-package-name package)))
 174         (official-gnu-packages)))
 175
 176 (define gnu-package?
 177   (let ((official-gnu-packages (memoize official-gnu-packages)))
 178     (mlambdaq (package)
 179       "Return true if PACKAGE is a GNU package.  This procedure may access the
 180 network to check in GNU's database."
 181       (define (mirror-type url)
 182         (let ((uri (string->uri url)))
 183           (and (eq? (uri-scheme uri) 'mirror)
 184                (cond
 185                 ((member (uri-host uri)
 186                          '("gnu" "gnupg" "gcc" "gnome"))
 187                  ;; Definitely GNU.
 188                  'gnu)
 189                 ((equal? (uri-host uri) "cran")
 190                  ;; Possibly GNU: mirror://cran could be either GNU R itself
 191                  ;; or a non-GNU package.
 192                  #f)
 193                 (else
 194                  ;; Definitely non-GNU.
 195                  'non-gnu)))))
 196
 197       (define (gnu-home-page? package)
 198         (letrec-syntax ((>> (syntax-rules ()
 199                               ((_ value proc)
 200                                (and=> value proc))
 201                               ((_ value proc rest ...)
 202                                (and=> value
 203                                       (lambda (next)
 204                                         (>> (proc next) rest ...)))))))
 205           (>> package package-home-page
 206               string->uri uri-host
 207               (lambda (host)
 208                 (member host '("www.gnu.org" "gnu.org"))))))
 209
 210       (or (gnu-home-page? package)
 211           (let ((url  (and=> (package-source package) origin-uri))
 212                 (name (package-upstream-name package)))
 213             (case (and (string? url) (mirror-type url))
 214               ((gnu) #t)
 215               ((non-gnu) #f)
 216               (else
 217                (and (member name (map gnu-package-name (official-gnu-packages)))
 218                     #t))))))))
 219
 220 \f
 221 ;;;
 222 ;;; Latest FTP release.
 223 ;;;
 224
 225 (define (ftp-server/directory package)
 226   "Return the FTP server and directory where PACKAGE's tarball are stored."
 227   (let ((name (package-upstream-name package)))
 228     (values (or (assoc-ref (package-properties package) 'ftp-server)
 229                 "ftp.gnu.org")
 230             (or (assoc-ref (package-properties package) 'ftp-directory)
 231                 (string-append "/gnu/" name)))))
 232
 233 (define %tarball-rx
 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$)"))
 238
 239 (define %alpha-tarball-rx
 240   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 241
 242 (define (release-file? project file)
 243   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 244 true."
 245   (and (not (member (file-extension file) '("sig" "sign" "asc")))
 246        (and=> (regexp-exec %tarball-rx file)
 247               (lambda (match)
 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)
 252                        (lambda (name)
 253                          (or (string-ci=? name project)
 254                              (string-ci=? name
 255                                           (string-append project
 256                                                          "-src")))))))
 257        (not (regexp-exec %alpha-tarball-rx file))
 258        (let ((s (tarball-sans-extension file)))
 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
 266                  (tarball-sans-extension tarball))))
 267     version))
 268
 269 (define* (releases project
 270                    #:key
 271                    (server "ftp.gnu.org")
 272                    (directory (string-append "/gnu/" project)))
 273   "Return the list of <upstream-release> of PROJECT as a list of release
 274 name/directory pairs."
 275   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 276   (define conn (ftp-open server))
 277
 278   (let loop ((directories (list directory))
 279              (result      '()))
 280     (match directories
 281       (()
 282        (ftp-close conn)
 283        (coalesce-sources result))
 284       ((directory rest ...)
 285        (let* ((files   (ftp-list conn directory))
 286               (subdirs (filter-map (match-lambda
 287                                      ((name 'directory . _) name)
 288                                      (_ #f))
 289                                    files)))
 290          (define (file->url file)
 291            (string-append "ftp://" server directory "/" file))
 292
 293          (define (file->source file)
 294            (let ((url (file->url file)))
 295              (upstream-source
 296               (package project)
 297               (version (tarball->version file))
 298               (urls (list url))
 299               (signature-urls (list (string-append url ".sig"))))))
 300
 301          (loop (append (map (cut string-append directory "/" <>)
 302                             subdirs)
 303                        rest)
 304                (append
 305                 ;; Filter out signatures, deltas, and files which
 306                 ;; are potentially not releases of PROJECT--e.g.,
 307                 ;; in /gnu/guile, filter out guile-oops and
 308                 ;; guile-www; in mit-scheme, filter out binaries.
 309                 (filter-map (match-lambda
 310                               ((file 'file . _)
 311                                (and (release-file? project file)
 312                                     (file->source file)))
 313                               (_ #f))
 314                             files)
 315                 result)))))))
 316
 317 (define* (latest-ftp-release project
 318                              #:key
 319                              (server "ftp.gnu.org")
 320                              (directory (string-append "/gnu/" project))
 321                              (keep-file? (const #t))
 322                              (file->signature (cut string-append <> ".sig"))
 323                              (ftp-open ftp-open) (ftp-close ftp-close))
 324   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 325 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 326 connections; this can be useful to reuse connections.
 327
 328 KEEP-FILE? is a predicate to decide whether to enter a directory and to
 329 consider a given file (source tarball) as a valid candidate based on its name.
 330
 331 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 332 return the corresponding signature URL, or #f it signatures are unavailable."
 333   (define (latest a b)
 334     (if (version>? a b) a b))
 335
 336   (define (latest-release a b)
 337     (if (version>? (upstream-source-version a) (upstream-source-version b))
 338         a b))
 339
 340   (define patch-directory-name?
 341     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 342     (cut string-suffix? "patches" <>))
 343
 344   (define conn (ftp-open server))
 345
 346   (define (file->url directory file)
 347     (string-append "ftp://" server directory "/" file))
 348
 349   (define (file->source directory file)
 350     (let ((url (file->url directory file)))
 351       (upstream-source
 352        (package project)
 353        (version (tarball->version file))
 354        (urls (list url))
 355        (signature-urls (match (file->signature url)
 356                          (#f #f)
 357                          (sig (list sig)))))))
 358
 359   (let loop ((directory directory)
 360              (result    #f))
 361     (let* ((entries (ftp-list conn directory))
 362
 363            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 364            ;; directories as found on ftp.gnutls.org.
 365            (subdirs (filter-map (match-lambda
 366                                   (((? patch-directory-name? dir)
 367                                     'directory . _)
 368                                    #f)
 369                                   (("w32" 'directory . _)
 370                                    #f)
 371                                   (("unstable" 'directory . _)
 372                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 373                                    #f)
 374                                   ((directory 'directory . _)
 375                                    directory)
 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)
 386                                          (keep-file? file)
 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
 406 (define* (latest-release package
 407                          #:key
 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
 413                       #:server server
 414                       #:directory directory))
 415
 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."
 419   (catch 'ftp-error
 420     (lambda ()
 421       exp)
 422     (lambda (key port . rest)
 423       (if (ftp-connection? port)
 424           (ftp-close port)
 425           (close-port port))
 426       #f)))
 427
 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)
 436                                         #:server server
 437                                         #:directory directory))))
 438
 439 \f
 440 ;;;
 441 ;;; Latest HTTP release.
 442 ;;;
 443
 444 (define (html->sxml port)
 445   "Read HTML from PORT and return the corresponding SXML tree."
 446   (let ((str (get-string-all port)))
 447     (catch #t
 448       (lambda ()
 449         ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
 450         ;; enough for directory listings at <https://kernel.org/pub> but if
 451         ;; needed we could resort to (htmlprag) from Guile-Lib.
 452         (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
 453           xml->sxml))
 454       (const '(html)))))                          ;parse error
 455
 456 (define (html-links sxml)
 457   "Return the list of links found in SXML, the SXML tree of an HTML page."
 458   (let loop ((sxml sxml)
 459              (links '()))
 460     (match sxml
 461       (('a ('@ attributes ...) body ...)
 462        (match (assq 'href attributes)
 463          (#f          (fold loop links body))
 464          (('href url) (fold loop (cons url links) body))))
 465       ((tag ('@ _ ...) body ...)
 466        (fold loop links body))
 467       ((tag body ...)
 468        (fold loop links body))
 469       (_
 470        links))))
 471
 472 (define* (latest-html-release package
 473                               #:key
 474                               (base-url "https://kernel.org/pub")
 475                               (directory (string-append "/" package))
 476                               (file->signature (cut string-append <> ".sig")))
 477   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 478 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 479 typically a directory listing as found on 'https://kernel.org/pub'.
 480
 481 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 482 return the corresponding signature URL, or #f it signatures are unavailable."
 483   (let* ((uri  (string->uri (string-append base-url directory "/")))
 484          (port (http-fetch/cached uri #:ttl 3600))
 485          (sxml (html->sxml port)))
 486     (define (url->release url)
 487       (and (string=? url (basename url))          ;relative reference?
 488            (release-file? package url)
 489            (let-values (((name version)
 490                          (package-name->name+version
 491                           (tarball-sans-extension url)
 492                           #\-)))
 493              (upstream-source
 494               (package name)
 495               (version version)
 496               (urls (list (string-append base-url directory "/" url)))
 497               (signature-urls
 498                (list (string-append base-url directory "/"
 499                                     (file-sans-extension url)
 500                                     ".sign")))))))
 501
 502     (define candidates
 503       (filter-map url->release (html-links sxml)))
 504
 505     (close-port port)
 506     (match candidates
 507       (() #f)
 508       ((first . _)
 509        ;; Select the most recent release and return it.
 510        (reduce (lambda (r1 r2)
 511                  (if (version>? (upstream-source-version r1)
 512                                 (upstream-source-version r2))
 513                      r1 r2))
 514                first
 515                (coalesce-sources candidates))))))
 516
 517 \f
 518 ;;;
 519 ;;; Updaters.
 520 ;;;
 521
 522 (define %gnu-file-list-uri
 523   ;; URI of the file list for ftp.gnu.org.
 524   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 525
 526 (define ftp.gnu.org-files
 527   (mlambda ()
 528     "Return the list of files available at ftp.gnu.org."
 529
 530     ;; XXX: Memoize the whole procedure to work around the fact that
 531     ;; 'http-fetch/cached' caches the gzipped version.
 532
 533     (define (trim-leading-components str)
 534       ;; Trim the leading ".", if any, in "./gnu/foo".
 535       (string-trim str (char-set #\.)))
 536
 537     (define (string->lines str)
 538       (string-tokenize str (char-set-complement (char-set #\newline))))
 539
 540     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 541     ;; TTL can be relatively short.
 542     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 543       (map trim-leading-components
 544            (call-with-gzip-input-port port
 545              (compose string->lines get-string-all))))))
 546
 547 (define (latest-gnu-release package)
 548   "Return the latest release of PACKAGE, a GNU package available via
 549 ftp.gnu.org.
 550
 551 This method does not rely on FTP access at all; instead, it browses the file
 552 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 553   (let-values (((server directory)
 554                 (ftp-server/directory package))
 555                ((name)
 556                 (package-upstream-name package)))
 557     (let* ((files    (ftp.gnu.org-files))
 558            (relevant (filter (lambda (file)
 559                                (and (string-prefix? "/gnu" file)
 560                                     (string-contains file directory)
 561                                     (release-file? name (basename file))))
 562                              files)))
 563       (match (sort relevant (lambda (file1 file2)
 564                               (version>? (tarball-sans-extension
 565                                           (basename file1))
 566                                          (tarball-sans-extension
 567                                           (basename file2)))))
 568         ((and tarballs (reference _ ...))
 569          (let* ((version  (tarball->version reference))
 570                 (tarballs (filter (lambda (file)
 571                                     (string=? (tarball-sans-extension
 572                                                (basename file))
 573                                               (tarball-sans-extension
 574                                                (basename reference))))
 575                                   tarballs)))
 576            (upstream-source
 577             (package name)
 578             (version version)
 579             (urls (map (lambda (file)
 580                          (string-append "mirror://gnu/"
 581                                         (string-drop file
 582                                                      (string-length "/gnu/"))))
 583                        tarballs))
 584             (signature-urls (map (cut string-append <> ".sig") urls)))))
 585         (()
 586          #f)))))
 587
 588 (define %package-name-rx
 589   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 590   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 591   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 592
 593 (define (gnu-package-name->name+version name+version)
 594   "Return the package name and version number extracted from NAME+VERSION."
 595   (let ((match (regexp-exec %package-name-rx name+version)))
 596     (if (not match)
 597         (values name+version #f)
 598         (values (match:substring match 1) (match:substring match 2)))))
 599
 600 (define gnome-package?
 601   (url-prefix-predicate "mirror://gnome/"))
 602
 603 (define (pure-gnu-package? package)
 604   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 605 excludes AucTeX, for instance, whose releases are now uploaded to
 606 elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
 607 releases are on gnu.org."
 608   (and (or (not (string-prefix? "emacs-" (package-name package)))
 609            (gnu-hosted? package))
 610        (not (gnome-package? package))
 611        (gnu-package? package)))
 612
 613 (define gnu-hosted?
 614   (url-prefix-predicate "mirror://gnu/"))
 615
 616 (define (latest-kde-release package)
 617   "Return the latest release of PACKAGE, the name of an KDE.org package."
 618   (let ((uri (string->uri (origin-uri (package-source package)))))
 619     (false-if-ftp-error
 620      (latest-ftp-release
 621       (package-upstream-name package)
 622       #:server "ftp.mirrorservice.org"
 623       #:directory (string-append "/sites/ftp.kde.org/pub/kde/"
 624                                  (dirname (dirname (uri-path uri))))))))
 625
 626 (define (latest-xorg-release package)
 627   "Return the latest release of PACKAGE, the name of an X.org package."
 628   (let ((uri (string->uri (origin-uri (package-source package)))))
 629     (false-if-ftp-error
 630      (latest-ftp-release
 631       (package-name package)
 632       #:server "ftp.freedesktop.org"
 633       #:directory
 634       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 635
 636 (define (latest-kernel.org-release package)
 637   "Return the latest release of PACKAGE, the name of a kernel.org package."
 638   (define %kernel.org-base
 639     ;; This URL and sub-directories thereof are nginx-generated directory
 640     ;; listings suitable for 'latest-html-release'.
 641     "https://mirrors.edge.kernel.org/pub")
 642
 643   (define (file->signature file)
 644     (string-append (file-sans-extension file) ".sign"))
 645
 646   (let* ((uri       (string->uri (origin-uri (package-source package))))
 647          (package   (package-upstream-name package))
 648          (directory (dirname (uri-path uri))))
 649     (latest-html-release package
 650                          #:base-url %kernel.org-base
 651                          #:directory directory
 652                          #:file->signature file->signature)))
 653
 654 (define %gnu-updater
 655   ;; This is for everything at ftp.gnu.org.
 656   (upstream-updater
 657    (name 'gnu)
 658    (description "Updater for GNU packages")
 659    (pred gnu-hosted?)
 660    (latest latest-gnu-release)))
 661
 662 (define %gnu-ftp-updater
 663   ;; This is for GNU packages taken from alternate locations, such as
 664   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 665   (upstream-updater
 666    (name 'gnu-ftp)
 667    (description "Updater for GNU packages only available via FTP")
 668    (pred (lambda (package)
 669            (and (not (gnu-hosted? package))
 670                 (pure-gnu-package? package))))
 671    (latest latest-release*)))
 672
 673 (define %kde-updater
 674   (upstream-updater
 675     (name 'kde)
 676     (description "Updater for KDE packages")
 677     (pred (url-prefix-predicate "mirror://kde/"))
 678     (latest latest-kde-release)))
 679
 680 (define %xorg-updater
 681   (upstream-updater
 682    (name 'xorg)
 683    (description "Updater for X.org packages")
 684    (pred (url-prefix-predicate "mirror://xorg/"))
 685    (latest latest-xorg-release)))
 686
 687 (define %kernel.org-updater
 688   (upstream-updater
 689    (name 'kernel.org)
 690    (description "Updater for packages hosted on kernel.org")
 691    (pred (url-prefix-predicate "mirror://kernel.org/"))
 692    (latest latest-kernel.org-release)))
 693
 694 ;;; gnu-maintenance.scm ends here