guix/gnu-maintenance.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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           (match (package-source package)
 211             ((? origin? origin)
 212              (let ((url  (origin-uri origin))
 213                    (name (package-upstream-name package)))
 214                (case (and (string? url) (mirror-type url))
 215                  ((gnu) #t)
 216                  ((non-gnu) #f)
 217                  (else
 218                   (and (member name (map gnu-package-name (official-gnu-packages)))
 219                        #t)))))
 220             (_ #f))))))
 221
 222 \f
 223 ;;;
 224 ;;; Latest FTP release.
 225 ;;;
 226
 227 (define (ftp-server/directory package)
 228   "Return the FTP server and directory where PACKAGE's tarball are stored."
 229   (let ((name (package-upstream-name package)))
 230     (values (or (assoc-ref (package-properties package) 'ftp-server)
 231                 "ftp.gnu.org")
 232             (or (assoc-ref (package-properties package) 'ftp-directory)
 233                 (string-append "/gnu/" name)))))
 234
 235 (define %tarball-rx
 236   ;; The .zip extensions is notably used for freefont-ttf.
 237   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 238   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 239   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 240
 241 (define %alpha-tarball-rx
 242   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 243
 244 (define (release-file? project file)
 245   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 246 true."
 247   (and (not (member (file-extension file) '("sig" "sign" "asc")))
 248        (and=> (regexp-exec %tarball-rx file)
 249               (lambda (match)
 250                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 251                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 252                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 253                 (and=> (match:substring match 1)
 254                        (lambda (name)
 255                          (or (string-ci=? name project)
 256                              (string-ci=? name
 257                                           (string-append project
 258                                                          "-src")))))))
 259        (not (regexp-exec %alpha-tarball-rx file))
 260        (let ((s (tarball-sans-extension file)))
 261          (regexp-exec %package-name-rx s))))
 262
 263 (define (tarball->version tarball)
 264   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 265 \"coreutils-8.23.tar.xz\"."
 266   (let-values (((name version)
 267                 (gnu-package-name->name+version
 268                  (tarball-sans-extension tarball))))
 269     version))
 270
 271 (define* (releases project
 272                    #:key
 273                    (server "ftp.gnu.org")
 274                    (directory (string-append "/gnu/" project)))
 275   "Return the list of <upstream-release> of PROJECT as a list of release
 276 name/directory pairs."
 277   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 278   (define conn (ftp-open server))
 279
 280   (let loop ((directories (list directory))
 281              (result      '()))
 282     (match directories
 283       (()
 284        (ftp-close conn)
 285        (coalesce-sources result))
 286       ((directory rest ...)
 287        (let* ((files   (ftp-list conn directory))
 288               (subdirs (filter-map (match-lambda
 289                                      ((name 'directory . _) name)
 290                                      (_ #f))
 291                                    files)))
 292          (define (file->url file)
 293            (string-append "ftp://" server directory "/" file))
 294
 295          (define (file->source file)
 296            (let ((url (file->url file)))
 297              (upstream-source
 298               (package project)
 299               (version (tarball->version file))
 300               (urls (list url))
 301               (signature-urls (list (string-append url ".sig"))))))
 302
 303          (loop (append (map (cut string-append directory "/" <>)
 304                             subdirs)
 305                        rest)
 306                (append
 307                 ;; Filter out signatures, deltas, and files which
 308                 ;; are potentially not releases of PROJECT--e.g.,
 309                 ;; in /gnu/guile, filter out guile-oops and
 310                 ;; guile-www; in mit-scheme, filter out binaries.
 311                 (filter-map (match-lambda
 312                               ((file 'file . _)
 313                                (and (release-file? project file)
 314                                     (file->source file)))
 315                               (_ #f))
 316                             files)
 317                 result)))))))
 318
 319 (define* (latest-ftp-release project
 320                              #:key
 321                              (server "ftp.gnu.org")
 322                              (directory (string-append "/gnu/" project))
 323                              (keep-file? (const #t))
 324                              (file->signature (cut string-append <> ".sig"))
 325                              (ftp-open ftp-open) (ftp-close ftp-close))
 326   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 327 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 328 connections; this can be useful to reuse connections.
 329
 330 KEEP-FILE? is a predicate to decide whether to enter a directory and to
 331 consider a given file (source tarball) as a valid candidate based on its name.
 332
 333 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 334 return the corresponding signature URL, or #f it signatures are unavailable."
 335   (define (latest a b)
 336     (if (version>? a b) a b))
 337
 338   (define (latest-release a b)
 339     (if (version>? (upstream-source-version a) (upstream-source-version b))
 340         a b))
 341
 342   (define patch-directory-name?
 343     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 344     (cut string-suffix? "patches" <>))
 345
 346   (define conn (ftp-open server))
 347
 348   (define (file->url directory file)
 349     (string-append "ftp://" server directory "/" file))
 350
 351   (define (file->source directory file)
 352     (let ((url (file->url directory file)))
 353       (upstream-source
 354        (package project)
 355        (version (tarball->version file))
 356        (urls (list url))
 357        (signature-urls (match (file->signature url)
 358                          (#f #f)
 359                          (sig (list sig)))))))
 360
 361   (let loop ((directory directory)
 362              (result    #f))
 363     (let* ((entries (ftp-list conn directory))
 364
 365            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 366            ;; directories as found on ftp.gnutls.org.
 367            (subdirs (filter-map (match-lambda
 368                                   (((? patch-directory-name? dir)
 369                                     'directory . _)
 370                                    #f)
 371                                   (("w32" 'directory . _)
 372                                    #f)
 373                                   (("unstable" 'directory . _)
 374                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 375                                    #f)
 376                                   ((directory 'directory . _)
 377                                    directory)
 378                                   (_ #f))
 379                                 entries))
 380
 381            ;; Whether or not SUBDIRS is empty, compute the latest releases
 382            ;; for the current directory.  This is necessary for packages
 383            ;; such as 'sharutils' that have a sub-directory that contains
 384            ;; only an older release.
 385            (releases (filter-map (match-lambda
 386                                    ((file 'file . _)
 387                                     (and (release-file? project file)
 388                                          (keep-file? file)
 389                                          (file->source directory file)))
 390                                    (_ #f))
 391                                  entries)))
 392
 393       ;; Assume that SUBDIRS correspond to versions, and jump into the
 394       ;; one with the highest version number.
 395       (let* ((release  (reduce latest-release #f
 396                                (coalesce-sources releases)))
 397              (result   (if (and result release)
 398                            (latest-release release result)
 399                            (or release result)))
 400              (target   (reduce latest #f subdirs)))
 401         (if target
 402             (loop (string-append directory "/" target)
 403                   result)
 404             (begin
 405               (ftp-close conn)
 406               result))))))
 407
 408 (define* (latest-release package
 409                          #:key
 410                          (server "ftp.gnu.org")
 411                          (directory (string-append "/gnu/" package)))
 412   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 413 PACKAGE must be the canonical name of a GNU package."
 414   (latest-ftp-release package
 415                       #:server server
 416                       #:directory directory))
 417
 418 (define-syntax-rule (false-if-ftp-error exp)
 419   "Return #f if an FTP error is raise while evaluating EXP; return the result
 420 of EXP otherwise."
 421   (catch 'ftp-error
 422     (lambda ()
 423       exp)
 424     (lambda (key port . rest)
 425       (if (ftp-connection? port)
 426           (ftp-close port)
 427           (close-port port))
 428       #f)))
 429
 430 (define (latest-release* package)
 431   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 432 errors that might occur when PACKAGE is not actually a GNU package, or not
 433 hosted on ftp.gnu.org, or not under that name (this is the case for
 434 \"emacs-auctex\", for instance.)"
 435   (let-values (((server directory)
 436                 (ftp-server/directory package)))
 437     (false-if-ftp-error (latest-release (package-upstream-name package)
 438                                         #:server server
 439                                         #:directory directory))))
 440
 441 \f
 442 ;;;
 443 ;;; Latest HTTP release.
 444 ;;;
 445
 446 (define (html->sxml port)
 447   "Read HTML from PORT and return the corresponding SXML tree."
 448   (let ((str (get-string-all port)))
 449     (catch #t
 450       (lambda ()
 451         ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
 452         ;; enough for directory listings at <https://kernel.org/pub> but if
 453         ;; needed we could resort to (htmlprag) from Guile-Lib.
 454         (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
 455           xml->sxml))
 456       (const '(html)))))                          ;parse error
 457
 458 (define (html-links sxml)
 459   "Return the list of links found in SXML, the SXML tree of an HTML page."
 460   (let loop ((sxml sxml)
 461              (links '()))
 462     (match sxml
 463       (('a ('@ attributes ...) body ...)
 464        (match (assq 'href attributes)
 465          (#f          (fold loop links body))
 466          (('href url) (fold loop (cons url links) body))))
 467       ((tag ('@ _ ...) body ...)
 468        (fold loop links body))
 469       ((tag body ...)
 470        (fold loop links body))
 471       (_
 472        links))))
 473
 474 (define* (latest-html-release package
 475                               #:key
 476                               (base-url "https://kernel.org/pub")
 477                               (directory (string-append "/" package))
 478                               (file->signature (cut string-append <> ".sig")))
 479   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 480 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 481 typically a directory listing as found on 'https://kernel.org/pub'.
 482
 483 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 484 return the corresponding signature URL, or #f it signatures are unavailable."
 485   (let* ((uri  (string->uri (string-append base-url directory "/")))
 486          (port (http-fetch/cached uri #:ttl 3600))
 487          (sxml (html->sxml port)))
 488     (define (url->release url)
 489       (and (string=? url (basename url))          ;relative reference?
 490            (release-file? package url)
 491            (let-values (((name version)
 492                          (package-name->name+version
 493                           (tarball-sans-extension url)
 494                           #\-)))
 495              (upstream-source
 496               (package name)
 497               (version version)
 498               (urls (list (string-append base-url directory "/" url)))
 499               (signature-urls
 500                (list (string-append base-url directory "/"
 501                                     (file-sans-extension url)
 502                                     ".sign")))))))
 503
 504     (define candidates
 505       (filter-map url->release (html-links sxml)))
 506
 507     (close-port port)
 508     (match candidates
 509       (() #f)
 510       ((first . _)
 511        ;; Select the most recent release and return it.
 512        (reduce (lambda (r1 r2)
 513                  (if (version>? (upstream-source-version r1)
 514                                 (upstream-source-version r2))
 515                      r1 r2))
 516                first
 517                (coalesce-sources candidates))))))
 518
 519 \f
 520 ;;;
 521 ;;; Updaters.
 522 ;;;
 523
 524 (define %gnu-file-list-uri
 525   ;; URI of the file list for ftp.gnu.org.
 526   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 527
 528 (define ftp.gnu.org-files
 529   (mlambda ()
 530     "Return the list of files available at ftp.gnu.org."
 531
 532     ;; XXX: Memoize the whole procedure to work around the fact that
 533     ;; 'http-fetch/cached' caches the gzipped version.
 534
 535     (define (trim-leading-components str)
 536       ;; Trim the leading ".", if any, in "./gnu/foo".
 537       (string-trim str (char-set #\.)))
 538
 539     (define (string->lines str)
 540       (string-tokenize str (char-set-complement (char-set #\newline))))
 541
 542     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 543     ;; TTL can be relatively short.
 544     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 545       (map trim-leading-components
 546            (call-with-gzip-input-port port
 547              (compose string->lines get-string-all))))))
 548
 549 (define (latest-gnu-release package)
 550   "Return the latest release of PACKAGE, a GNU package available via
 551 ftp.gnu.org.
 552
 553 This method does not rely on FTP access at all; instead, it browses the file
 554 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 555   (let-values (((server directory)
 556                 (ftp-server/directory package))
 557                ((name)
 558                 (package-upstream-name package)))
 559     (let* ((files    (ftp.gnu.org-files))
 560            (relevant (filter (lambda (file)
 561                                (and (string-prefix? "/gnu" file)
 562                                     (string-contains file directory)
 563                                     (release-file? name (basename file))))
 564                              files)))
 565       (match (sort relevant (lambda (file1 file2)
 566                               (version>? (tarball-sans-extension
 567                                           (basename file1))
 568                                          (tarball-sans-extension
 569                                           (basename file2)))))
 570         ((and tarballs (reference _ ...))
 571          (let* ((version  (tarball->version reference))
 572                 (tarballs (filter (lambda (file)
 573                                     (string=? (tarball-sans-extension
 574                                                (basename file))
 575                                               (tarball-sans-extension
 576                                                (basename reference))))
 577                                   tarballs)))
 578            (upstream-source
 579             (package name)
 580             (version version)
 581             (urls (map (lambda (file)
 582                          (string-append "mirror://gnu/"
 583                                         (string-drop file
 584                                                      (string-length "/gnu/"))))
 585                        tarballs))
 586             (signature-urls (map (cut string-append <> ".sig") urls)))))
 587         (()
 588          #f)))))
 589
 590 (define %package-name-rx
 591   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 592   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 593   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 594
 595 (define (gnu-package-name->name+version name+version)
 596   "Return the package name and version number extracted from NAME+VERSION."
 597   (let ((match (regexp-exec %package-name-rx name+version)))
 598     (if (not match)
 599         (values name+version #f)
 600         (values (match:substring match 1) (match:substring match 2)))))
 601
 602 (define gnome-package?
 603   (url-prefix-predicate "mirror://gnome/"))
 604
 605 (define (pure-gnu-package? package)
 606   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 607 excludes AucTeX, for instance, whose releases are now uploaded to
 608 elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
 609 releases are on gnu.org."
 610   (and (or (not (string-prefix? "emacs-" (package-name package)))
 611            (gnu-hosted? package))
 612        (not (gnome-package? package))
 613        (gnu-package? package)))
 614
 615 (define gnu-hosted?
 616   (url-prefix-predicate "mirror://gnu/"))
 617
 618 (define (latest-xorg-release package)
 619   "Return the latest release of PACKAGE, the name of an X.org package."
 620   (let ((uri (string->uri (origin-uri (package-source package)))))
 621     (false-if-ftp-error
 622      (latest-ftp-release
 623       (package-name package)
 624       #:server "ftp.freedesktop.org"
 625       #:directory
 626       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 627
 628 (define (latest-kernel.org-release package)
 629   "Return the latest release of PACKAGE, the name of a kernel.org package."
 630   (define %kernel.org-base
 631     ;; This URL and sub-directories thereof are nginx-generated directory
 632     ;; listings suitable for 'latest-html-release'.
 633     "https://mirrors.edge.kernel.org/pub")
 634
 635   (define (file->signature file)
 636     (string-append (file-sans-extension file) ".sign"))
 637
 638   (let* ((uri       (string->uri (origin-uri (package-source package))))
 639          (package   (package-upstream-name package))
 640          (directory (dirname (uri-path uri))))
 641     (latest-html-release package
 642                          #:base-url %kernel.org-base
 643                          #:directory directory
 644                          #:file->signature file->signature)))
 645
 646 (define %gnu-updater
 647   ;; This is for everything at ftp.gnu.org.
 648   (upstream-updater
 649    (name 'gnu)
 650    (description "Updater for GNU packages")
 651    (pred gnu-hosted?)
 652    (latest latest-gnu-release)))
 653
 654 (define %gnu-ftp-updater
 655   ;; This is for GNU packages taken from alternate locations, such as
 656   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 657   (upstream-updater
 658    (name 'gnu-ftp)
 659    (description "Updater for GNU packages only available via FTP")
 660    (pred (lambda (package)
 661            (and (not (gnu-hosted? package))
 662                 (pure-gnu-package? package))))
 663    (latest latest-release*)))
 664
 665 (define %xorg-updater
 666   (upstream-updater
 667    (name 'xorg)
 668    (description "Updater for X.org packages")
 669    (pred (url-prefix-predicate "mirror://xorg/"))
 670    (latest latest-xorg-release)))
 671
 672 (define %kernel.org-updater
 673   (upstream-updater
 674    (name 'kernel.org)
 675    (description "Updater for packages hosted on kernel.org")
 676    (pred (url-prefix-predicate "mirror://kernel.org/"))
 677    (latest latest-kernel.org-release)))
 678
 679 ;;; gnu-maintenance.scm ends here