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