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, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix gnu-maintenance)
  22   #:use-module (web uri)
  23   #:use-module (web client)
  24   #:use-module (web response)
  25   #:use-module (sxml simple)
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (rnrs io ports)
  33   #:use-module (system foreign)
  34   #:use-module ((guix http-client) #:hide (open-socket-for-uri))
  35   #:use-module (guix ftp-client)
  36   #:use-module (guix utils)
  37   #:use-module (guix memoization)
  38   #:use-module (guix records)
  39   #:use-module (guix upstream)
  40   #:use-module (guix packages)
  41   #:autoload   (zlib) (call-with-gzip-input-port)
  42   #:autoload   (htmlprag) (html->sxml)            ;from Guile-Lib
  43   #:export (gnu-package-name
  44             gnu-package-mundane-name
  45             gnu-package-copyright-holder
  46             gnu-package-savannah
  47             gnu-package-fsd
  48             gnu-package-language
  49             gnu-package-logo
  50             gnu-package-doc-category
  51             gnu-package-doc-summary
  52             gnu-package-doc-description
  53             gnu-package-doc-urls
  54             gnu-package-download-url
  55
  56             official-gnu-packages
  57             find-package
  58             gnu-package?
  59
  60             release-file?
  61             releases
  62             latest-release
  63             gnu-release-archive-types
  64             gnu-package-name->name+version
  65
  66             %gnu-updater
  67             %gnu-ftp-updater
  68             %savannah-updater
  69             %sourceforge-updater
  70             %xorg-updater
  71             %kernel.org-updater
  72             %generic-html-updater))
  73
  74 ;;; Commentary:
  75 ;;;
  76 ;;; Code for dealing with the maintenance of GNU packages, such as
  77 ;;; auto-updates.
  78 ;;;
  79 ;;; Code:
  80
  81 \f
  82 ;;;
  83 ;;; List of GNU packages.
  84 ;;;
  85
  86 (define %gnumaint-base-url
  87   "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
  88
  89 (define %package-list-url
  90   (string->uri
  91    (string-append %gnumaint-base-url "rec/gnupackages.rec")))
  92
  93 (define %package-description-url
  94   ;; This file contains package descriptions in recutils format.
  95   ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
  96   ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  97   (string->uri
  98    (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
  99
 100 (define-record-type* <gnu-package-descriptor>
 101   gnu-package-descriptor
 102   make-gnu-package-descriptor
 103
 104   gnu-package-descriptor?
 105
 106   (name             gnu-package-name)
 107   (mundane-name     gnu-package-mundane-name)
 108   (copyright-holder gnu-package-copyright-holder)
 109   (savannah         gnu-package-savannah)
 110   (fsd              gnu-package-fsd)
 111   (language         gnu-package-language)         ; list of strings
 112   (logo             gnu-package-logo)
 113   (doc-category     gnu-package-doc-category)
 114   (doc-summary      gnu-package-doc-summary)
 115   (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
 116   (doc-urls         gnu-package-doc-urls)         ; list of strings
 117   (download-url     gnu-package-download-url))
 118
 119 (define* (official-gnu-packages
 120           #:optional (fetch http-fetch/cached))
 121   "Return a list of records, which are GNU packages.  Use FETCH,
 122 to fetch the list of GNU packages over HTTP."
 123   (define (read-records port)
 124     ;; Return a list of alists.  Each alist contains fields of a GNU
 125     ;; package.
 126     (let loop ((alist  (recutils->alist port))
 127                (result '()))
 128       (if (null? alist)
 129           (reverse result)
 130           (loop (recutils->alist port)
 131
 132                 ;; Ignore things like "%rec" (info "(recutils) Record
 133                 ;; Descriptors").
 134                 (if (assoc-ref alist "package")
 135                     (cons alist result)
 136                     result)))))
 137
 138   (define official-description
 139     (let ((db (read-records (fetch %package-description-url #:text? #t))))
 140       (lambda (name)
 141         ;; Return the description found upstream for package NAME, or #f.
 142         (and=> (find (lambda (alist)
 143                        (equal? name (assoc-ref alist "package")))
 144                      db)
 145                (lambda (record)
 146                  (let ((field (assoc-ref record "blurb")))
 147                    ;; The upstream description file uses "redirect PACKAGE" as
 148                    ;; a blurb in cases where the description of the two
 149                    ;; packages should be considered the same (e.g., GTK+ has
 150                    ;; "redirect gnome".)  This is usually not acceptable for
 151                    ;; us because we prefer to have distinct descriptions in
 152                    ;; such cases.  Thus, ignore the 'blurb' field when that
 153                    ;; happens.
 154                    (and field
 155                         (not (string-prefix? "redirect " field))
 156                         field)))))))
 157
 158   (map (lambda (alist)
 159          (let ((name (assoc-ref alist "package")))
 160            (alist->record `(("description" . ,(official-description name))
 161                             ,@alist)
 162                           make-gnu-package-descriptor
 163                           (list "package" "mundane_name" "copyright_holder"
 164                                 "savannah" "fsd" "language" "logo"
 165                                 "doc_category" "doc_summary" "description"
 166                                 "doc_url"
 167                                 "download_url")
 168                           '("doc_url" "language"))))
 169        (let* ((port (fetch %package-list-url #:text? #t))
 170               (lst  (read-records port)))
 171          (close-port port)
 172          lst)))
 173
 174 (define (find-package name)
 175   "Find GNU package called NAME and return it.  Return #f if it was not
 176 found."
 177   (find (lambda (package)
 178           (string=? name (gnu-package-name package)))
 179         (official-gnu-packages)))
 180
 181 (define gnu-package?
 182   (let ((official-gnu-packages (memoize official-gnu-packages)))
 183     (mlambdaq (package)
 184       "Return true if PACKAGE is a GNU package.  This procedure may access the
 185 network to check in GNU's database."
 186       (define (mirror-type url)
 187         (let ((uri (string->uri url)))
 188           (and (eq? (uri-scheme uri) 'mirror)
 189                (cond
 190                 ((member (uri-host uri)
 191                          '("gnu" "gnupg" "gcc" "gnome"))
 192                  ;; Definitely GNU.
 193                  'gnu)
 194                 ((equal? (uri-host uri) "cran")
 195                  ;; Possibly GNU: mirror://cran could be either GNU R itself
 196                  ;; or a non-GNU package.
 197                  #f)
 198                 (else
 199                  ;; Definitely non-GNU.
 200                  'non-gnu)))))
 201
 202       (define (gnu-home-page? package)
 203         (letrec-syntax ((>> (syntax-rules ()
 204                               ((_ value proc)
 205                                (and=> value proc))
 206                               ((_ value proc rest ...)
 207                                (and=> value
 208                                       (lambda (next)
 209                                         (>> (proc next) rest ...)))))))
 210           (>> package package-home-page
 211               string->uri uri-host
 212               (lambda (host)
 213                 (member host '("www.gnu.org" "gnu.org"))))))
 214
 215       (or (gnu-home-page? package)
 216           (match (package-source package)
 217             ((? origin? origin)
 218              (let ((url  (origin-uri origin))
 219                    (name (package-upstream-name package)))
 220                (case (and (string? url) (mirror-type url))
 221                  ((gnu) #t)
 222                  ((non-gnu) #f)
 223                  (else
 224                   (and (member name (map gnu-package-name (official-gnu-packages)))
 225                        #t)))))
 226             (_ #f))))))
 227
 228 \f
 229 ;;;
 230 ;;; Latest FTP release.
 231 ;;;
 232
 233 (define (ftp-server/directory package)
 234   "Return the FTP server and directory where PACKAGE's tarball are stored."
 235   (let ((name (package-upstream-name package)))
 236     (values (or (assoc-ref (package-properties package) 'ftp-server)
 237                 "ftp.gnu.org")
 238             (or (assoc-ref (package-properties package) 'ftp-directory)
 239                 (string-append "/gnu/" name)))))
 240
 241 (define %tarball-rx
 242   ;; The .zip extensions is notably used for freefont-ttf.
 243   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 244   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 245   ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages.
 246   (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|zip$)"))
 247
 248 (define %alpha-tarball-rx
 249   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 250
 251 (define (release-file? project file)
 252   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 253 true."
 254   (and (not (member (file-extension file)
 255                     '("sig" "sign" "asc"
 256                       "md5sum" "sha1sum" "sha256sum")))
 257        (and=> (regexp-exec %tarball-rx file)
 258               (lambda (match)
 259                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 260                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 261                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 262                 (and=> (match:substring match 1)
 263                        (lambda (name)
 264                          (or (string-ci=? name project)
 265                              (string-ci=? name
 266                                           (string-append project
 267                                                          "-src")))))))
 268        (not (regexp-exec %alpha-tarball-rx file))
 269        (let ((s (tarball-sans-extension file)))
 270          (regexp-exec %package-name-rx s))))
 271
 272 (define (tarball->version tarball)
 273   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 274 \"coreutils-8.23.tar.xz\"."
 275   (let-values (((name version)
 276                 (gnu-package-name->name+version
 277                  (tarball-sans-extension tarball))))
 278     version))
 279
 280 (define* (releases project
 281                    #:key
 282                    (server "ftp.gnu.org")
 283                    (directory (string-append "/gnu/" project)))
 284   "Return the list of <upstream-release> of PROJECT as a list of release
 285 name/directory pairs."
 286   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 287   (define conn (ftp-open server))
 288
 289   (let loop ((directories (list directory))
 290              (result      '()))
 291     (match directories
 292       (()
 293        (ftp-close conn)
 294        (coalesce-sources result))
 295       ((directory rest ...)
 296        (let* ((files   (ftp-list conn directory))
 297               (subdirs (filter-map (match-lambda
 298                                      ((name 'directory . _) name)
 299                                      (_ #f))
 300                                    files)))
 301          (define (file->url file)
 302            (string-append "ftp://" server directory "/" file))
 303
 304          (define (file->source file)
 305            (let ((url (file->url file)))
 306              (upstream-source
 307               (package project)
 308               (version (tarball->version file))
 309               (urls (list url))
 310               (signature-urls (list (string-append url ".sig"))))))
 311
 312          (loop (append (map (cut string-append directory "/" <>)
 313                             subdirs)
 314                        rest)
 315                (append
 316                 ;; Filter out signatures, deltas, and files which
 317                 ;; are potentially not releases of PROJECT--e.g.,
 318                 ;; in /gnu/guile, filter out guile-oops and
 319                 ;; guile-www; in mit-scheme, filter out binaries.
 320                 (filter-map (match-lambda
 321                               ((file 'file . _)
 322                                (and (release-file? project file)
 323                                     (file->source file)))
 324                               (_ #f))
 325                             files)
 326                 result)))))))
 327
 328 (define* (latest-ftp-release project
 329                              #:key
 330                              (server "ftp.gnu.org")
 331                              (directory (string-append "/gnu/" project))
 332                              (file->signature (cut string-append <> ".sig")))
 333   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 334 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 335 connections; this can be useful to reuse connections.
 336
 337 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 338 return the corresponding signature URL, or #f it signatures are unavailable."
 339   (define (latest a b)
 340     (if (version>? a b) a b))
 341
 342   (define (latest-release a b)
 343     (if (version>? (upstream-source-version a) (upstream-source-version b))
 344         a b))
 345
 346   (define patch-directory-name?
 347     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 348     (cut string-suffix? "patches" <>))
 349
 350   (define conn (ftp-open server #:timeout 5))
 351
 352   (define (file->url directory file)
 353     (string-append "ftp://" server directory "/" file))
 354
 355   (define (file->source directory file)
 356     (let ((url (file->url directory file)))
 357       (upstream-source
 358        (package project)
 359        (version (tarball->version file))
 360        (urls (list url))
 361        (signature-urls (match (file->signature url)
 362                          (#f #f)
 363                          (sig (list sig)))))))
 364
 365   (let loop ((directory directory)
 366              (result    #f))
 367     (let* ((entries (catch 'ftp-error
 368                       (lambda _ (ftp-list conn directory))
 369                       (const '())))
 370
 371            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 372            ;; directories as found on ftp.gnutls.org.
 373            (subdirs (filter-map (match-lambda
 374                                   (((? patch-directory-name? dir)
 375                                     'directory . _)
 376                                    #f)
 377                                   (("w32" 'directory . _)
 378                                    #f)
 379                                   (("unstable" 'directory . _)
 380                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 381                                    #f)
 382                                   ((directory 'directory . _)
 383                                    directory)
 384                                   (_ #f))
 385                                 entries))
 386
 387            ;; Whether or not SUBDIRS is empty, compute the latest releases
 388            ;; for the current directory.  This is necessary for packages
 389            ;; such as 'sharutils' that have a sub-directory that contains
 390            ;; only an older release.
 391            (releases (filter-map (match-lambda
 392                                    ((file 'file . _)
 393                                     (and (release-file? project file)
 394                                          (file->source directory file)))
 395                                    (_ #f))
 396                                  entries)))
 397
 398       ;; Assume that SUBDIRS correspond to versions, and jump into the
 399       ;; one with the highest version number.
 400       (let* ((release  (reduce latest-release #f
 401                                (coalesce-sources releases)))
 402              (result   (if (and result release)
 403                            (latest-release release result)
 404                            (or release result)))
 405              (target   (reduce latest #f subdirs)))
 406         (if target
 407             (loop (string-append directory "/" target)
 408                   result)
 409             (begin
 410               (ftp-close conn)
 411               result))))))
 412
 413 (define* (latest-release package
 414                          #:key
 415                          (server "ftp.gnu.org")
 416                          (directory (string-append "/gnu/" package)))
 417   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 418 PACKAGE must be the canonical name of a GNU package."
 419   (latest-ftp-release package
 420                       #:server server
 421                       #:directory directory))
 422
 423 (define-syntax-rule (false-if-ftp-error exp)
 424   "Return #f if an FTP error is raise while evaluating EXP; return the result
 425 of EXP otherwise."
 426   (catch 'ftp-error
 427     (lambda ()
 428       exp)
 429     (lambda (key port . rest)
 430       (if (ftp-connection? port)
 431           (ftp-close port)
 432           (close-port port))
 433       #f)))
 434
 435 (define (latest-release* package)
 436   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 437 errors that might occur when PACKAGE is not actually a GNU package, or not
 438 hosted on ftp.gnu.org, or not under that name (this is the case for
 439 \"emacs-auctex\", for instance.)"
 440   (let-values (((server directory)
 441                 (ftp-server/directory package)))
 442     (false-if-ftp-error (latest-release (package-upstream-name package)
 443                                         #:server server
 444                                         #:directory directory))))
 445
 446 \f
 447 ;;;
 448 ;;; Latest HTTP release.
 449 ;;;
 450
 451 (define (html-links sxml)
 452   "Return the list of links found in SXML, the SXML tree of an HTML page."
 453   (let loop ((sxml sxml)
 454              (links '()))
 455     (match sxml
 456       (('a ('@ attributes ...) body ...)
 457        (match (assq 'href attributes)
 458          (#f          (fold loop links body))
 459          (('href url) (fold loop (cons url links) body))))
 460       ((tag ('@ _ ...) body ...)
 461        (fold loop links body))
 462       ((tag body ...)
 463        (fold loop links body))
 464       (_
 465        links))))
 466
 467 (define* (latest-html-release package
 468                               #:key
 469                               (base-url "https://kernel.org/pub")
 470                               (directory (string-append "/" package))
 471                               file->signature)
 472   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 473 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 474 typically a directory listing as found on 'https://kernel.org/pub'.
 475
 476 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 477 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 478 file URL and must return the corresponding signature URL, or #f it signatures
 479 are unavailable."
 480   (let* ((uri   (string->uri (if (string-null? directory)
 481                                  base-url
 482                                  (string-append base-url directory "/"))))
 483          (port  (http-fetch/cached uri #:ttl 3600))
 484          (sxml  (html->sxml port))
 485          (links (delete-duplicates (html-links sxml))))
 486     (define (file->signature/guess url)
 487       (let ((base (basename url)))
 488         (any (lambda (link)
 489                (any (lambda (extension)
 490                       (and (string=? (string-append base extension)
 491                                      (basename link))
 492                            (string-append url extension)))
 493                     '(".asc" ".sig" ".sign")))
 494              links)))
 495
 496     (define (url->release url)
 497       (let* ((base (basename url))
 498              (url  (if (string=? base url)
 499                        (string-append base-url directory "/" url)
 500                        url)))
 501         (and (release-file? package base)
 502              (let ((version (tarball->version base)))
 503                (upstream-source
 504                 (package package)
 505                 (version version)
 506                 (urls (list url))
 507                 (signature-urls
 508                  (list ((or file->signature file->signature/guess) url))))))))
 509
 510     (define candidates
 511       (filter-map url->release links))
 512
 513     (close-port port)
 514     (match candidates
 515       (() #f)
 516       ((first . _)
 517        ;; Select the most recent release and return it.
 518        (reduce (lambda (r1 r2)
 519                  (if (version>? (upstream-source-version r1)
 520                                 (upstream-source-version r2))
 521                      r1 r2))
 522                first
 523                (coalesce-sources candidates))))))
 524
 525 \f
 526 ;;;
 527 ;;; Updaters.
 528 ;;;
 529
 530 (define %gnu-file-list-uri
 531   ;; URI of the file list for ftp.gnu.org.
 532   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 533
 534 (define ftp.gnu.org-files
 535   (mlambda ()
 536     "Return the list of files available at ftp.gnu.org."
 537
 538     ;; XXX: Memoize the whole procedure to work around the fact that
 539     ;; 'http-fetch/cached' caches the gzipped version.
 540
 541     (define (trim-leading-components str)
 542       ;; Trim the leading ".", if any, in "./gnu/foo".
 543       (string-trim str (char-set #\.)))
 544
 545     (define (string->lines str)
 546       (string-tokenize str (char-set-complement (char-set #\newline))))
 547
 548     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 549     ;; TTL can be relatively short.
 550     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 551       (map trim-leading-components
 552            (call-with-gzip-input-port port
 553              (compose string->lines get-string-all))))))
 554
 555 (define (latest-gnu-release package)
 556   "Return the latest release of PACKAGE, a GNU package available via
 557 ftp.gnu.org.
 558
 559 This method does not rely on FTP access at all; instead, it browses the file
 560 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 561   (let-values (((server directory)
 562                 (ftp-server/directory package))
 563                ((name)
 564                 (package-upstream-name package)))
 565     (let* ((files    (ftp.gnu.org-files))
 566            (relevant (filter (lambda (file)
 567                                (and (string-prefix? "/gnu" file)
 568                                     (string-contains file directory)
 569                                     (release-file? name (basename file))))
 570                              files)))
 571       (match (sort relevant (lambda (file1 file2)
 572                               (version>? (tarball-sans-extension
 573                                           (basename file1))
 574                                          (tarball-sans-extension
 575                                           (basename file2)))))
 576         ((and tarballs (reference _ ...))
 577          (let* ((version  (tarball->version reference))
 578                 (tarballs (filter (lambda (file)
 579                                     (string=? (tarball-sans-extension
 580                                                (basename file))
 581                                               (tarball-sans-extension
 582                                                (basename reference))))
 583                                   tarballs)))
 584            (upstream-source
 585             (package name)
 586             (version version)
 587             (urls (map (lambda (file)
 588                          (string-append "mirror://gnu/"
 589                                         (string-drop file
 590                                                      (string-length "/gnu/"))))
 591                        tarballs))
 592             (signature-urls (map (cut string-append <> ".sig") urls)))))
 593         (()
 594          #f)))))
 595
 596 (define %package-name-rx
 597   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 598   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 599   (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src|\\.src|\\.orig)?"))
 600
 601 (define (gnu-package-name->name+version name+version)
 602   "Return the package name and version number extracted from NAME+VERSION."
 603   (let ((match (regexp-exec %package-name-rx name+version)))
 604     (if (not match)
 605         (values name+version #f)
 606         (values (match:substring match 1) (match:substring match 2)))))
 607
 608 (define gnome-package?
 609   (url-prefix-predicate "mirror://gnome/"))
 610
 611 (define (pure-gnu-package? package)
 612   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 613 excludes AucTeX, for instance, whose releases are now uploaded to
 614 elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
 615 GNOME packages; EMMS is included though, because its releases are on gnu.org."
 616   (and (or (not (string-prefix? "emacs-" (package-name package)))
 617            (gnu-hosted? package))
 618        (not (gnome-package? package))
 619        (not (string-prefix? "gnuradio" (package-name package)))
 620        (gnu-package? package)))
 621
 622 (define gnu-hosted?
 623   (url-prefix-predicate "mirror://gnu/"))
 624
 625 (define (url-prefix-rewrite old new)
 626   "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
 627   (lambda (url)
 628     (if (and url (string-prefix? old url))
 629         (string-append new (string-drop url (string-length old)))
 630         url)))
 631
 632 (define (adjusted-upstream-source source rewrite-url)
 633   "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
 634   (upstream-source
 635    (inherit source)
 636    (urls (map rewrite-url (upstream-source-urls source)))
 637    (signature-urls (and=> (upstream-source-signature-urls source)
 638                           (lambda (urls)
 639                             (map rewrite-url urls))))))
 640
 641 (define %savannah-base
 642   ;; One of the Savannah mirrors listed at
 643   ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
 644   ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
 645   "https://nongnu.freemirror.org/nongnu")
 646
 647 (define (latest-savannah-release package)
 648   "Return the latest release of PACKAGE."
 649   (let* ((uri       (string->uri
 650                      (match (origin-uri (package-source package))
 651                        ((? string? uri) uri)
 652                        ((uri mirrors ...) uri))))
 653          (package   (package-upstream-name package))
 654          (directory (dirname (uri-path uri)))
 655          (rewrite   (url-prefix-rewrite %savannah-base
 656                                         "mirror://savannah")))
 657     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
 658     ;; or whichever detached signature naming scheme PACKAGE uses.
 659     (and=> (latest-html-release package
 660                                 #:base-url %savannah-base
 661                                 #:directory directory)
 662            (cut adjusted-upstream-source <> rewrite))))
 663
 664 (define (latest-sourceforge-release package)
 665   "Return the latest release of PACKAGE."
 666   (define (uri-append uri extension)
 667     ;; Return URI with EXTENSION appended.
 668     (build-uri (uri-scheme uri)
 669                #:host (uri-host uri)
 670                #:path (string-append (uri-path uri) extension)))
 671
 672   (define (valid-uri? uri port)
 673     ;; Return true if URI is reachable.
 674     (false-if-exception
 675      (case (response-code (http-head uri #:port port #:keep-alive? #t))
 676        ((200 302) #t)
 677        (else #f))))
 678
 679   (let* ((name     (package-upstream-name package))
 680          (base     (string-append "https://sourceforge.net/projects/"
 681                                   name "/files"))
 682          (url      (string-append base "/latest/download"))
 683          (uri      (string->uri url))
 684          (port     (false-if-exception (open-socket-for-uri uri)))
 685          (response (and port
 686                         (http-head uri #:port port #:keep-alive? #t))))
 687     (dynamic-wind
 688       (const #t)
 689       (lambda ()
 690         (and response
 691              (= 302 (response-code response))
 692              (response-location response)
 693              (match (string-tokenize (uri-path (response-location response))
 694                                      (char-set-complement (char-set #\/)))
 695                ((_ components ...)
 696                 (let* ((path (string-join components "/"))
 697                        (url  (string-append "mirror://sourceforge/" path)))
 698                   (and (release-file? name (basename path))
 699
 700                        ;; Take the heavy-handed approach of probing 3 additional
 701                        ;; URLs.  XXX: Would be nicer if this could be avoided.
 702                        (let* ((loc (response-location response))
 703                               (sig (any (lambda (extension)
 704                                           (let ((uri (uri-append loc extension)))
 705                                             (and (valid-uri? uri port)
 706                                                  (string-append url extension))))
 707                                         '(".asc" ".sig" ".sign"))))
 708                          (upstream-source
 709                           (package name)
 710                           (version (tarball->version (basename path)))
 711                           (urls (list url))
 712                           (signature-urls (and sig (list sig)))))))))))
 713       (lambda ()
 714         (when port
 715           (close-port port))))))
 716
 717 (define (latest-xorg-release package)
 718   "Return the latest release of PACKAGE."
 719   (let ((uri (string->uri (origin-uri (package-source package)))))
 720     (false-if-ftp-error
 721      (latest-ftp-release
 722       (package-name package)
 723       #:server "ftp.freedesktop.org"
 724       #:directory
 725       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 726
 727 (define (latest-kernel.org-release package)
 728   "Return the latest release of PACKAGE, the name of a kernel.org package."
 729   (define %kernel.org-base
 730     ;; This URL and sub-directories thereof are nginx-generated directory
 731     ;; listings suitable for 'latest-html-release'.
 732     "https://mirrors.edge.kernel.org/pub")
 733
 734   (define (file->signature file)
 735     (string-append (file-sans-extension file) ".sign"))
 736
 737   (let* ((uri       (string->uri
 738                      (match (origin-uri (package-source package))
 739                        ((? string? uri) uri)
 740                        ((uri mirrors ...) uri))))
 741          (package   (package-upstream-name package))
 742          (directory (dirname (uri-path uri)))
 743          (rewrite   (url-prefix-rewrite %kernel.org-base
 744                                         "mirror://kernel.org")))
 745     (and=> (latest-html-release package
 746                                 #:base-url %kernel.org-base
 747                                 #:directory directory
 748                                 #:file->signature file->signature)
 749            (cut adjusted-upstream-source <> rewrite))))
 750
 751 (define html-updatable-package?
 752   ;; Return true if the given package may be handled by the generic HTML
 753   ;; updater.
 754   (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
 755                          "notabug.org" "sr.ht"
 756                          "gforge.inria.fr" "gitlab.inria.fr"
 757                          "ftp.gnu.org" "download.savannah.gnu.org"
 758                          "pypi.org" "crates.io" "rubygems.org"
 759                          "bioconductor.org")))
 760     (define http-url?
 761       (url-predicate (lambda (url)
 762                        (match (string->uri url)
 763                          (#f #f)
 764                          (uri
 765                           (let ((scheme (uri-scheme uri))
 766                                 (host   (uri-host uri)))
 767                             (and (memq scheme '(http https))
 768                                  (not (member host hosting-sites)))))))))
 769
 770     (lambda (package)
 771       (or (assoc-ref (package-properties package) 'release-monitoring-url)
 772           (http-url? package)))))
 773
 774 (define (latest-html-updatable-release package)
 775   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
 776 the directory containing its source tarball."
 777   (let* ((uri       (string->uri
 778                      (match (origin-uri (package-source package))
 779                        ((? string? url) url)
 780                        ((url _ ...) url))))
 781          (custom    (assoc-ref (package-properties package)
 782                                'release-monitoring-url))
 783          (base      (or custom
 784                         (string-append (symbol->string (uri-scheme uri))
 785                                        "://" (uri-host uri))))
 786          (directory (if custom
 787                         ""
 788                         (dirname (uri-path uri))))
 789          (package   (package-upstream-name package)))
 790     (catch #t
 791       (lambda ()
 792         (guard (c ((http-get-error? c) #f))
 793           (latest-html-release package
 794                                #:base-url base
 795                                #:directory directory)))
 796       (lambda (key . args)
 797         ;; Return false and move on upon connection failures and bogus HTTP
 798         ;; servers.
 799         (unless (memq key '(gnutls-error tls-certificate-error
 800                                          system-error
 801                                          bad-header bad-header-component))
 802           (apply throw key args))
 803         #f))))
 804
 805 (define %gnu-updater
 806   ;; This is for everything at ftp.gnu.org.
 807   (upstream-updater
 808    (name 'gnu)
 809    (description "Updater for GNU packages")
 810    (pred gnu-hosted?)
 811    (latest latest-gnu-release)))
 812
 813 (define %gnu-ftp-updater
 814   ;; This is for GNU packages taken from alternate locations, such as
 815   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 816   (upstream-updater
 817    (name 'gnu-ftp)
 818    (description "Updater for GNU packages only available via FTP")
 819    (pred (lambda (package)
 820            (and (not (gnu-hosted? package))
 821                 (pure-gnu-package? package))))
 822    (latest latest-release*)))
 823
 824 (define %savannah-updater
 825   (upstream-updater
 826    (name 'savannah)
 827    (description "Updater for packages hosted on savannah.gnu.org")
 828    (pred (url-prefix-predicate "mirror://savannah/"))
 829    (latest latest-savannah-release)))
 830
 831 (define %sourceforge-updater
 832   (upstream-updater
 833    (name 'sourceforge)
 834    (description "Updater for packages hosted on sourceforge.net")
 835    (pred (url-prefix-predicate "mirror://sourceforge/"))
 836    (latest latest-sourceforge-release)))
 837
 838 (define %xorg-updater
 839   (upstream-updater
 840    (name 'xorg)
 841    (description "Updater for X.org packages")
 842    (pred (url-prefix-predicate "mirror://xorg/"))
 843    (latest latest-xorg-release)))
 844
 845 (define %kernel.org-updater
 846   (upstream-updater
 847    (name 'kernel.org)
 848    (description "Updater for packages hosted on kernel.org")
 849    (pred (url-prefix-predicate "mirror://kernel.org/"))
 850    (latest latest-kernel.org-release)))
 851
 852 (define %generic-html-updater
 853   (upstream-updater
 854    (name 'generic-html)
 855    (description "Updater that crawls HTML pages.")
 856    (pred html-updatable-package?)
 857    (latest latest-html-updatable-release)))
 858
 859 ;;; gnu-maintenance.scm ends here