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             %savannah-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           (match (package-source package)
 212             ((? origin? origin)
 213              (let ((url  (origin-uri origin))
 214                    (name (package-upstream-name package)))
 215                (case (and (string? url) (mirror-type url))
 216                  ((gnu) #t)
 217                  ((non-gnu) #f)
 218                  (else
 219                   (and (member name (map gnu-package-name (official-gnu-packages)))
 220                        #t)))))
 221             (_ #f))))))
 222
 223 \f
 224 ;;;
 225 ;;; Latest FTP release.
 226 ;;;
 227
 228 (define (ftp-server/directory package)
 229   "Return the FTP server and directory where PACKAGE's tarball are stored."
 230   (let ((name (package-upstream-name package)))
 231     (values (or (assoc-ref (package-properties package) 'ftp-server)
 232                 "ftp.gnu.org")
 233             (or (assoc-ref (package-properties package) 'ftp-directory)
 234                 (string-append "/gnu/" name)))))
 235
 236 (define %tarball-rx
 237   ;; The .zip extensions is notably used for freefont-ttf.
 238   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 239   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 240   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 241
 242 (define %alpha-tarball-rx
 243   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 244
 245 (define (release-file? project file)
 246   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 247 true."
 248   (and (not (member (file-extension file) '("sig" "sign" "asc")))
 249        (and=> (regexp-exec %tarball-rx file)
 250               (lambda (match)
 251                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 252                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 253                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 254                 (and=> (match:substring match 1)
 255                        (lambda (name)
 256                          (or (string-ci=? name project)
 257                              (string-ci=? name
 258                                           (string-append project
 259                                                          "-src")))))))
 260        (not (regexp-exec %alpha-tarball-rx file))
 261        (let ((s (tarball-sans-extension file)))
 262          (regexp-exec %package-name-rx s))))
 263
 264 (define (tarball->version tarball)
 265   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 266 \"coreutils-8.23.tar.xz\"."
 267   (let-values (((name version)
 268                 (gnu-package-name->name+version
 269                  (tarball-sans-extension tarball))))
 270     version))
 271
 272 (define* (releases project
 273                    #:key
 274                    (server "ftp.gnu.org")
 275                    (directory (string-append "/gnu/" project)))
 276   "Return the list of <upstream-release> of PROJECT as a list of release
 277 name/directory pairs."
 278   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 279   (define conn (ftp-open server))
 280
 281   (let loop ((directories (list directory))
 282              (result      '()))
 283     (match directories
 284       (()
 285        (ftp-close conn)
 286        (coalesce-sources result))
 287       ((directory rest ...)
 288        (let* ((files   (ftp-list conn directory))
 289               (subdirs (filter-map (match-lambda
 290                                      ((name 'directory . _) name)
 291                                      (_ #f))
 292                                    files)))
 293          (define (file->url file)
 294            (string-append "ftp://" server directory "/" file))
 295
 296          (define (file->source file)
 297            (let ((url (file->url file)))
 298              (upstream-source
 299               (package project)
 300               (version (tarball->version file))
 301               (urls (list url))
 302               (signature-urls (list (string-append url ".sig"))))))
 303
 304          (loop (append (map (cut string-append directory "/" <>)
 305                             subdirs)
 306                        rest)
 307                (append
 308                 ;; Filter out signatures, deltas, and files which
 309                 ;; are potentially not releases of PROJECT--e.g.,
 310                 ;; in /gnu/guile, filter out guile-oops and
 311                 ;; guile-www; in mit-scheme, filter out binaries.
 312                 (filter-map (match-lambda
 313                               ((file 'file . _)
 314                                (and (release-file? project file)
 315                                     (file->source file)))
 316                               (_ #f))
 317                             files)
 318                 result)))))))
 319
 320 (define* (latest-ftp-release project
 321                              #:key
 322                              (server "ftp.gnu.org")
 323                              (directory (string-append "/gnu/" project))
 324                              (keep-file? (const #t))
 325                              (file->signature (cut string-append <> ".sig"))
 326                              (ftp-open ftp-open) (ftp-close ftp-close))
 327   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 328 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 329 connections; this can be useful to reuse connections.
 330
 331 KEEP-FILE? is a predicate to decide whether to enter a directory and to
 332 consider a given file (source tarball) as a valid candidate based on its name.
 333
 334 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 335 return the corresponding signature URL, or #f it signatures are unavailable."
 336   (define (latest a b)
 337     (if (version>? a b) a b))
 338
 339   (define (latest-release a b)
 340     (if (version>? (upstream-source-version a) (upstream-source-version b))
 341         a b))
 342
 343   (define patch-directory-name?
 344     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 345     (cut string-suffix? "patches" <>))
 346
 347   (define conn (ftp-open server))
 348
 349   (define (file->url directory file)
 350     (string-append "ftp://" server directory "/" file))
 351
 352   (define (file->source directory file)
 353     (let ((url (file->url directory file)))
 354       (upstream-source
 355        (package project)
 356        (version (tarball->version file))
 357        (urls (list url))
 358        (signature-urls (match (file->signature url)
 359                          (#f #f)
 360                          (sig (list sig)))))))
 361
 362   (let loop ((directory directory)
 363              (result    #f))
 364     (let* ((entries (ftp-list conn directory))
 365
 366            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 367            ;; directories as found on ftp.gnutls.org.
 368            (subdirs (filter-map (match-lambda
 369                                   (((? patch-directory-name? dir)
 370                                     'directory . _)
 371                                    #f)
 372                                   (("w32" 'directory . _)
 373                                    #f)
 374                                   (("unstable" 'directory . _)
 375                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 376                                    #f)
 377                                   ((directory 'directory . _)
 378                                    directory)
 379                                   (_ #f))
 380                                 entries))
 381
 382            ;; Whether or not SUBDIRS is empty, compute the latest releases
 383            ;; for the current directory.  This is necessary for packages
 384            ;; such as 'sharutils' that have a sub-directory that contains
 385            ;; only an older release.
 386            (releases (filter-map (match-lambda
 387                                    ((file 'file . _)
 388                                     (and (release-file? project file)
 389                                          (keep-file? file)
 390                                          (file->source directory file)))
 391                                    (_ #f))
 392                                  entries)))
 393
 394       ;; Assume that SUBDIRS correspond to versions, and jump into the
 395       ;; one with the highest version number.
 396       (let* ((release  (reduce latest-release #f
 397                                (coalesce-sources releases)))
 398              (result   (if (and result release)
 399                            (latest-release release result)
 400                            (or release result)))
 401              (target   (reduce latest #f subdirs)))
 402         (if target
 403             (loop (string-append directory "/" target)
 404                   result)
 405             (begin
 406               (ftp-close conn)
 407               result))))))
 408
 409 (define* (latest-release package
 410                          #:key
 411                          (server "ftp.gnu.org")
 412                          (directory (string-append "/gnu/" package)))
 413   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 414 PACKAGE must be the canonical name of a GNU package."
 415   (latest-ftp-release package
 416                       #:server server
 417                       #:directory directory))
 418
 419 (define-syntax-rule (false-if-ftp-error exp)
 420   "Return #f if an FTP error is raise while evaluating EXP; return the result
 421 of EXP otherwise."
 422   (catch 'ftp-error
 423     (lambda ()
 424       exp)
 425     (lambda (key port . rest)
 426       (if (ftp-connection? port)
 427           (ftp-close port)
 428           (close-port port))
 429       #f)))
 430
 431 (define (latest-release* package)
 432   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 433 errors that might occur when PACKAGE is not actually a GNU package, or not
 434 hosted on ftp.gnu.org, or not under that name (this is the case for
 435 \"emacs-auctex\", for instance.)"
 436   (let-values (((server directory)
 437                 (ftp-server/directory package)))
 438     (false-if-ftp-error (latest-release (package-upstream-name package)
 439                                         #:server server
 440                                         #:directory directory))))
 441
 442 \f
 443 ;;;
 444 ;;; Latest HTTP release.
 445 ;;;
 446
 447 (define (html->sxml port)
 448   "Read HTML from PORT and return the corresponding SXML tree."
 449   (let ((str (get-string-all port)))
 450     (catch #t
 451       (lambda ()
 452         ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
 453         ;; enough for directory listings at <https://kernel.org/pub> but if
 454         ;; needed we could resort to (htmlprag) from Guile-Lib.
 455         (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
 456           xml->sxml))
 457       (const '(html)))))                          ;parse error
 458
 459 (define (html-links sxml)
 460   "Return the list of links found in SXML, the SXML tree of an HTML page."
 461   (let loop ((sxml sxml)
 462              (links '()))
 463     (match sxml
 464       (('a ('@ attributes ...) body ...)
 465        (match (assq 'href attributes)
 466          (#f          (fold loop links body))
 467          (('href url) (fold loop (cons url links) body))))
 468       ((tag ('@ _ ...) body ...)
 469        (fold loop links body))
 470       ((tag body ...)
 471        (fold loop links body))
 472       (_
 473        links))))
 474
 475 (define* (latest-html-release package
 476                               #:key
 477                               (base-url "https://kernel.org/pub")
 478                               (directory (string-append "/" package))
 479                               (file->signature (cut string-append <> ".sig")))
 480   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 481 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 482 typically a directory listing as found on 'https://kernel.org/pub'.
 483
 484 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 485 return the corresponding signature URL, or #f it signatures are unavailable."
 486   (let* ((uri  (string->uri (string-append base-url directory "/")))
 487          (port (http-fetch/cached uri #:ttl 3600))
 488          (sxml (html->sxml port)))
 489     (define (url->release url)
 490       (and (string=? url (basename url))          ;relative reference?
 491            (release-file? package url)
 492            (let-values (((name version)
 493                          (package-name->name+version
 494                           (tarball-sans-extension url)
 495                           #\-)))
 496              (upstream-source
 497               (package name)
 498               (version version)
 499               (urls (list (string-append base-url directory "/" url)))
 500               (signature-urls
 501                (list (file->signature
 502                       (string-append base-url directory "/" url))))))))
 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 (url-prefix-rewrite old new)
 619   "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
 620   (lambda (url)
 621     (if (string-prefix? old url)
 622         (string-append new (string-drop url (string-length old)))
 623         url)))
 624
 625 (define (adjusted-upstream-source source rewrite-url)
 626   "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
 627   (upstream-source
 628    (inherit source)
 629    (urls (map rewrite-url (upstream-source-urls source)))
 630    (signature-urls (and=> (upstream-source-signature-urls source)
 631                           (lambda (urls)
 632                             (map rewrite-url urls))))))
 633
 634 (define savannah-package?
 635   (url-prefix-predicate "mirror://savannah/"))
 636
 637 (define %savannah-base
 638   ;; One of the Savannah mirrors listed at
 639   ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
 640   ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
 641   "https://nongnu.freemirror.org/nongnu")
 642
 643 (define (latest-savannah-release package)
 644   "Return the latest release of PACKAGE."
 645   (let* ((uri       (string->uri
 646                      (match (origin-uri (package-source package))
 647                        ((? string? uri) uri)
 648                        ((uri mirrors ...) uri))))
 649          (package   (package-upstream-name package))
 650          (directory (dirname (uri-path uri)))
 651          (rewrite   (url-prefix-rewrite %savannah-base
 652                                         "mirror://savannah")))
 653     ;; Note: We use the default 'file->signature', which adds ".sig", but not
 654     ;; all projects on Savannah follow that convention: some use ".asc" and
 655     ;; perhaps some lack signatures altogether.
 656     (and=> (latest-html-release package
 657                                 #:base-url %savannah-base
 658                                 #:directory directory)
 659            (cut adjusted-upstream-source <> rewrite))))
 660
 661 (define (latest-xorg-release package)
 662   "Return the latest release of PACKAGE."
 663   (let ((uri (string->uri (origin-uri (package-source package)))))
 664     (false-if-ftp-error
 665      (latest-ftp-release
 666       (package-name package)
 667       #:server "ftp.freedesktop.org"
 668       #:directory
 669       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 670
 671 (define (latest-kernel.org-release package)
 672   "Return the latest release of PACKAGE, the name of a kernel.org package."
 673   (define %kernel.org-base
 674     ;; This URL and sub-directories thereof are nginx-generated directory
 675     ;; listings suitable for 'latest-html-release'.
 676     "https://mirrors.edge.kernel.org/pub")
 677
 678   (define (file->signature file)
 679     (string-append (file-sans-extension file) ".sign"))
 680
 681   (let* ((uri       (string->uri
 682                      (match (origin-uri (package-source package))
 683                        ((? string? uri) uri)
 684                        ((uri mirrors ...) uri))))
 685          (package   (package-upstream-name package))
 686          (directory (dirname (uri-path uri)))
 687          (rewrite   (url-prefix-rewrite %kernel.org-base
 688                                         "mirror://kernel.org")))
 689     (and=> (latest-html-release package
 690                                 #:base-url %kernel.org-base
 691                                 #:directory directory
 692                                 #:file->signature file->signature)
 693            (cut adjusted-upstream-source <> rewrite))))
 694
 695 (define %gnu-updater
 696   ;; This is for everything at ftp.gnu.org.
 697   (upstream-updater
 698    (name 'gnu)
 699    (description "Updater for GNU packages")
 700    (pred gnu-hosted?)
 701    (latest latest-gnu-release)))
 702
 703 (define %gnu-ftp-updater
 704   ;; This is for GNU packages taken from alternate locations, such as
 705   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 706   (upstream-updater
 707    (name 'gnu-ftp)
 708    (description "Updater for GNU packages only available via FTP")
 709    (pred (lambda (package)
 710            (and (not (gnu-hosted? package))
 711                 (pure-gnu-package? package))))
 712    (latest latest-release*)))
 713
 714 (define %savannah-updater
 715   (upstream-updater
 716    (name 'savannah)
 717    (description "Updater for packages hosted on savannah.gnu.org")
 718    (pred (url-prefix-predicate "mirror://savannah/"))
 719    (latest latest-savannah-release)))
 720
 721 (define %xorg-updater
 722   (upstream-updater
 723    (name 'xorg)
 724    (description "Updater for X.org packages")
 725    (pred (url-prefix-predicate "mirror://xorg/"))
 726    (latest latest-xorg-release)))
 727
 728 (define %kernel.org-updater
 729   (upstream-updater
 730    (name 'kernel.org)
 731    (description "Updater for packages hosted on kernel.org")
 732    (pred (url-prefix-predicate "mirror://kernel.org/"))
 733    (latest latest-kernel.org-release)))
 734
 735 ;;; gnu-maintenance.scm ends here