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   ;; Accept 'v' or 'V' prefix as in 'PKG-v2.3.tgz'.
 247   (make-regexp "^([^.]+)[-_][vV]?([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|tgz|zip$)"))
 248
 249 (define %alpha-tarball-rx
 250   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 251
 252 (define (release-file? project file)
 253   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 254 true."
 255   (and (not (member (file-extension file)
 256                     '("sig" "sign" "asc"
 257                       "md5sum" "sha1sum" "sha256sum")))
 258        (and=> (regexp-exec %tarball-rx file)
 259               (lambda (match)
 260                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 261                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 262                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 263                 (and=> (match:substring match 1)
 264                        (lambda (name)
 265                          (or (string-ci=? name project)
 266                              (string-ci=? name
 267                                           (string-append project
 268                                                          "-src")))))))
 269        (not (regexp-exec %alpha-tarball-rx file))
 270        (let ((s (tarball-sans-extension file)))
 271          (regexp-exec %package-name-rx s))))
 272
 273 (define (tarball->version tarball)
 274   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 275 \"coreutils-8.23.tar.xz\"."
 276   (let-values (((name version)
 277                 (gnu-package-name->name+version
 278                  (tarball-sans-extension tarball))))
 279     version))
 280
 281 (define* (releases project
 282                    #:key
 283                    (server "ftp.gnu.org")
 284                    (directory (string-append "/gnu/" project)))
 285   "Return the list of <upstream-release> of PROJECT as a list of release
 286 name/directory pairs."
 287   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 288   (define conn (ftp-open server))
 289
 290   (let loop ((directories (list directory))
 291              (result      '()))
 292     (match directories
 293       (()
 294        (ftp-close conn)
 295        (coalesce-sources result))
 296       ((directory rest ...)
 297        (let* ((files   (ftp-list conn directory))
 298               (subdirs (filter-map (match-lambda
 299                                      ((name 'directory . _) name)
 300                                      (_ #f))
 301                                    files)))
 302          (define (file->url file)
 303            (string-append "ftp://" server directory "/" file))
 304
 305          (define (file->source file)
 306            (let ((url (file->url file)))
 307              (upstream-source
 308               (package project)
 309               (version (tarball->version file))
 310               (urls (list url))
 311               (signature-urls (list (string-append url ".sig"))))))
 312
 313          (loop (append (map (cut string-append directory "/" <>)
 314                             subdirs)
 315                        rest)
 316                (append
 317                 ;; Filter out signatures, deltas, and files which
 318                 ;; are potentially not releases of PROJECT--e.g.,
 319                 ;; in /gnu/guile, filter out guile-oops and
 320                 ;; guile-www; in mit-scheme, filter out binaries.
 321                 (filter-map (match-lambda
 322                               ((file 'file . _)
 323                                (and (release-file? project file)
 324                                     (file->source file)))
 325                               (_ #f))
 326                             files)
 327                 result)))))))
 328
 329 (define* (latest-ftp-release project
 330                              #:key
 331                              (server "ftp.gnu.org")
 332                              (directory (string-append "/gnu/" project))
 333                              (file->signature (cut string-append <> ".sig")))
 334   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 335 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 336 connections; this can be useful to reuse connections.
 337
 338 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 339 return the corresponding signature URL, or #f it signatures are unavailable."
 340   (define (latest a b)
 341     (if (version>? a b) a b))
 342
 343   (define (latest-release a b)
 344     (if (version>? (upstream-source-version a) (upstream-source-version b))
 345         a b))
 346
 347   (define patch-directory-name?
 348     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 349     (cut string-suffix? "patches" <>))
 350
 351   (define conn (ftp-open server #:timeout 5))
 352
 353   (define (file->url directory file)
 354     (string-append "ftp://" server directory "/" file))
 355
 356   (define (file->source directory file)
 357     (let ((url (file->url directory file)))
 358       (upstream-source
 359        (package project)
 360        (version (tarball->version file))
 361        (urls (list url))
 362        (signature-urls (match (file->signature url)
 363                          (#f #f)
 364                          (sig (list sig)))))))
 365
 366   (let loop ((directory directory)
 367              (result    #f))
 368     (let* ((entries (catch 'ftp-error
 369                       (lambda _ (ftp-list conn directory))
 370                       (const '())))
 371
 372            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 373            ;; directories as found on ftp.gnutls.org.
 374            (subdirs (filter-map (match-lambda
 375                                   (((? patch-directory-name? dir)
 376                                     'directory . _)
 377                                    #f)
 378                                   (("w32" 'directory . _)
 379                                    #f)
 380                                   (("unstable" 'directory . _)
 381                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 382                                    #f)
 383                                   ((directory 'directory . _)
 384                                    directory)
 385                                   (_ #f))
 386                                 entries))
 387
 388            ;; Whether or not SUBDIRS is empty, compute the latest releases
 389            ;; for the current directory.  This is necessary for packages
 390            ;; such as 'sharutils' that have a sub-directory that contains
 391            ;; only an older release.
 392            (releases (filter-map (match-lambda
 393                                    ((file 'file . _)
 394                                     (and (release-file? project file)
 395                                          (file->source directory file)))
 396                                    (_ #f))
 397                                  entries)))
 398
 399       ;; Assume that SUBDIRS correspond to versions, and jump into the
 400       ;; one with the highest version number.
 401       (let* ((release  (reduce latest-release #f
 402                                (coalesce-sources releases)))
 403              (result   (if (and result release)
 404                            (latest-release release result)
 405                            (or release result)))
 406              (target   (reduce latest #f subdirs)))
 407         (if target
 408             (loop (string-append directory "/" target)
 409                   result)
 410             (begin
 411               (ftp-close conn)
 412               result))))))
 413
 414 (define* (latest-release package
 415                          #:key
 416                          (server "ftp.gnu.org")
 417                          (directory (string-append "/gnu/" package)))
 418   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 419 PACKAGE must be the canonical name of a GNU package."
 420   (latest-ftp-release package
 421                       #:server server
 422                       #:directory directory))
 423
 424 (define-syntax-rule (false-if-ftp-error exp)
 425   "Return #f if an FTP error is raise while evaluating EXP; return the result
 426 of EXP otherwise."
 427   (catch 'ftp-error
 428     (lambda ()
 429       exp)
 430     (lambda (key port . rest)
 431       (if (ftp-connection? port)
 432           (ftp-close port)
 433           (close-port port))
 434       #f)))
 435
 436 (define (latest-release* package)
 437   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 438 errors that might occur when PACKAGE is not actually a GNU package, or not
 439 hosted on ftp.gnu.org, or not under that name (this is the case for
 440 \"emacs-auctex\", for instance.)"
 441   (let-values (((server directory)
 442                 (ftp-server/directory package)))
 443     (false-if-ftp-error (latest-release (package-upstream-name package)
 444                                         #:server server
 445                                         #:directory directory))))
 446
 447 \f
 448 ;;;
 449 ;;; Latest HTTP release.
 450 ;;;
 451
 452 (define (html-links sxml)
 453   "Return the list of links found in SXML, the SXML tree of an HTML page."
 454   (let loop ((sxml sxml)
 455              (links '()))
 456     (match sxml
 457       (('a ('@ attributes ...) body ...)
 458        (match (assq 'href attributes)
 459          (#f          (fold loop links body))
 460          (('href url) (fold loop (cons url links) body))))
 461       ((tag ('@ _ ...) body ...)
 462        (fold loop links body))
 463       ((tag body ...)
 464        (fold loop links body))
 465       (_
 466        links))))
 467
 468 (define* (latest-html-release package
 469                               #:key
 470                               (base-url "https://kernel.org/pub")
 471                               (directory (string-append "/" package))
 472                               file->signature)
 473   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 474 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 475 typically a directory listing as found on 'https://kernel.org/pub'.
 476
 477 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 478 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 479 file URL and must return the corresponding signature URL, or #f it signatures
 480 are unavailable."
 481   (let* ((uri   (string->uri (if (string-null? directory)
 482                                  base-url
 483                                  (string-append base-url directory "/"))))
 484          (port  (http-fetch/cached uri #:ttl 3600))
 485          (sxml  (html->sxml port))
 486          (links (delete-duplicates (html-links sxml))))
 487     (define (file->signature/guess url)
 488       (let ((base (basename url)))
 489         (any (lambda (link)
 490                (any (lambda (extension)
 491                       (and (string=? (string-append base extension)
 492                                      (basename link))
 493                            (string-append url extension)))
 494                     '(".asc" ".sig" ".sign")))
 495              links)))
 496
 497     (define (url->release url)
 498       (let* ((base (basename url))
 499              (url  (if (string=? base url)
 500                        (string-append base-url directory "/" url)
 501                        url)))
 502         (and (release-file? package base)
 503              (let ((version (tarball->version base)))
 504                (upstream-source
 505                 (package package)
 506                 (version version)
 507                 (urls (list url))
 508                 (signature-urls
 509                  (list ((or file->signature file->signature/guess) url))))))))
 510
 511     (define candidates
 512       (filter-map url->release links))
 513
 514     (close-port port)
 515     (match candidates
 516       (() #f)
 517       ((first . _)
 518        ;; Select the most recent release and return it.
 519        (reduce (lambda (r1 r2)
 520                  (if (version>? (upstream-source-version r1)
 521                                 (upstream-source-version r2))
 522                      r1 r2))
 523                first
 524                (coalesce-sources candidates))))))
 525
 526 \f
 527 ;;;
 528 ;;; Updaters.
 529 ;;;
 530
 531 (define %gnu-file-list-uri
 532   ;; URI of the file list for ftp.gnu.org.
 533   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 534
 535 (define ftp.gnu.org-files
 536   (mlambda ()
 537     "Return the list of files available at ftp.gnu.org."
 538
 539     ;; XXX: Memoize the whole procedure to work around the fact that
 540     ;; 'http-fetch/cached' caches the gzipped version.
 541
 542     (define (trim-leading-components str)
 543       ;; Trim the leading ".", if any, in "./gnu/foo".
 544       (string-trim str (char-set #\.)))
 545
 546     (define (string->lines str)
 547       (string-tokenize str (char-set-complement (char-set #\newline))))
 548
 549     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 550     ;; TTL can be relatively short.
 551     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 552       (map trim-leading-components
 553            (call-with-gzip-input-port port
 554              (compose string->lines get-string-all))))))
 555
 556 (define (latest-gnu-release package)
 557   "Return the latest release of PACKAGE, a GNU package available via
 558 ftp.gnu.org.
 559
 560 This method does not rely on FTP access at all; instead, it browses the file
 561 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 562   (let-values (((server directory)
 563                 (ftp-server/directory package))
 564                ((name)
 565                 (package-upstream-name package)))
 566     (let* ((files    (ftp.gnu.org-files))
 567            (relevant (filter (lambda (file)
 568                                (and (string-prefix? "/gnu" file)
 569                                     (string-contains file directory)
 570                                     (release-file? name (basename file))))
 571                              files)))
 572       (match (sort relevant (lambda (file1 file2)
 573                               (version>? (tarball-sans-extension
 574                                           (basename file1))
 575                                          (tarball-sans-extension
 576                                           (basename file2)))))
 577         ((and tarballs (reference _ ...))
 578          (let* ((version  (tarball->version reference))
 579                 (tarballs (filter (lambda (file)
 580                                     (string=? (tarball-sans-extension
 581                                                (basename file))
 582                                               (tarball-sans-extension
 583                                                (basename reference))))
 584                                   tarballs)))
 585            (upstream-source
 586             (package name)
 587             (version version)
 588             (urls (map (lambda (file)
 589                          (string-append "mirror://gnu/"
 590                                         (string-drop file
 591                                                      (string-length "/gnu/"))))
 592                        tarballs))
 593             (signature-urls (map (cut string-append <> ".sig") urls)))))
 594         (()
 595          #f)))))
 596
 597 (define %package-name-rx
 598   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 599   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 600   (make-regexp "^(.*)[-_][vV]?(([0-9]|\\.)+)(-src|\\.src|\\.orig)?"))
 601
 602 (define (gnu-package-name->name+version name+version)
 603   "Return the package name and version number extracted from NAME+VERSION."
 604   (let ((match (regexp-exec %package-name-rx name+version)))
 605     (if (not match)
 606         (values name+version #f)
 607         (values (match:substring match 1) (match:substring match 2)))))
 608
 609 (define gnome-package?
 610   (url-prefix-predicate "mirror://gnome/"))
 611
 612 (define (pure-gnu-package? package)
 613   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 614 excludes AucTeX, for instance, whose releases are now uploaded to
 615 elpa.gnu.org, GNU Radio, which has releases at www.gnuradio.org, and all the
 616 GNOME packages; EMMS is included though, because its releases are on gnu.org."
 617   (and (or (not (string-prefix? "emacs-" (package-name package)))
 618            (gnu-hosted? package))
 619        (not (gnome-package? package))
 620        (not (string-prefix? "gnuradio" (package-name package)))
 621        (gnu-package? package)))
 622
 623 (define gnu-hosted?
 624   (url-prefix-predicate "mirror://gnu/"))
 625
 626 (define (url-prefix-rewrite old new)
 627   "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
 628   (lambda (url)
 629     (if (and url (string-prefix? old url))
 630         (string-append new (string-drop url (string-length old)))
 631         url)))
 632
 633 (define (adjusted-upstream-source source rewrite-url)
 634   "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
 635   (upstream-source
 636    (inherit source)
 637    (urls (map rewrite-url (upstream-source-urls source)))
 638    (signature-urls (and=> (upstream-source-signature-urls source)
 639                           (lambda (urls)
 640                             (map rewrite-url urls))))))
 641
 642 (define %savannah-base
 643   ;; One of the Savannah mirrors listed at
 644   ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid
 645   ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
 646   "https://nongnu.freemirror.org/nongnu")
 647
 648 (define (latest-savannah-release package)
 649   "Return the latest release of PACKAGE."
 650   (let* ((uri       (string->uri
 651                      (match (origin-uri (package-source package))
 652                        ((? string? uri) uri)
 653                        ((uri mirrors ...) uri))))
 654          (package   (package-upstream-name package))
 655          (directory (dirname (uri-path uri)))
 656          (rewrite   (url-prefix-rewrite %savannah-base
 657                                         "mirror://savannah")))
 658     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
 659     ;; or whichever detached signature naming scheme PACKAGE uses.
 660     (and=> (latest-html-release package
 661                                 #:base-url %savannah-base
 662                                 #:directory directory)
 663            (cut adjusted-upstream-source <> rewrite))))
 664
 665 (define (latest-sourceforge-release package)
 666   "Return the latest release of PACKAGE."
 667   (define (uri-append uri extension)
 668     ;; Return URI with EXTENSION appended.
 669     (build-uri (uri-scheme uri)
 670                #:host (uri-host uri)
 671                #:path (string-append (uri-path uri) extension)))
 672
 673   (define (valid-uri? uri port)
 674     ;; Return true if URI is reachable.
 675     (false-if-exception
 676      (case (response-code (http-head uri #:port port #:keep-alive? #t))
 677        ((200 302) #t)
 678        (else #f))))
 679
 680   (let* ((name     (package-upstream-name package))
 681          (base     (string-append "https://sourceforge.net/projects/"
 682                                   name "/files"))
 683          (url      (string-append base "/latest/download"))
 684          (uri      (string->uri url))
 685          (port     (false-if-exception (open-socket-for-uri uri)))
 686          (response (and port
 687                         (http-head uri #:port port #:keep-alive? #t))))
 688     (dynamic-wind
 689       (const #t)
 690       (lambda ()
 691         (and response
 692              (= 302 (response-code response))
 693              (response-location response)
 694              (match (string-tokenize (uri-path (response-location response))
 695                                      (char-set-complement (char-set #\/)))
 696                ((_ components ...)
 697                 (let* ((path (string-join components "/"))
 698                        (url  (string-append "mirror://sourceforge/" path)))
 699                   (and (release-file? name (basename path))
 700
 701                        ;; Take the heavy-handed approach of probing 3 additional
 702                        ;; URLs.  XXX: Would be nicer if this could be avoided.
 703                        (let* ((loc (response-location response))
 704                               (sig (any (lambda (extension)
 705                                           (let ((uri (uri-append loc extension)))
 706                                             (and (valid-uri? uri port)
 707                                                  (string-append url extension))))
 708                                         '(".asc" ".sig" ".sign"))))
 709                          (upstream-source
 710                           (package name)
 711                           (version (tarball->version (basename path)))
 712                           (urls (list url))
 713                           (signature-urls (and sig (list sig)))))))))))
 714       (lambda ()
 715         (when port
 716           (close-port port))))))
 717
 718 (define (latest-xorg-release package)
 719   "Return the latest release of PACKAGE."
 720   (let ((uri (string->uri (origin-uri (package-source package)))))
 721     (false-if-ftp-error
 722      (latest-ftp-release
 723       (package-name package)
 724       #:server "ftp.freedesktop.org"
 725       #:directory
 726       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 727
 728 (define (latest-kernel.org-release package)
 729   "Return the latest release of PACKAGE, the name of a kernel.org package."
 730   (define %kernel.org-base
 731     ;; This URL and sub-directories thereof are nginx-generated directory
 732     ;; listings suitable for 'latest-html-release'.
 733     "https://mirrors.edge.kernel.org/pub")
 734
 735   (define (file->signature file)
 736     (string-append (file-sans-extension file) ".sign"))
 737
 738   (let* ((uri       (string->uri
 739                      (match (origin-uri (package-source package))
 740                        ((? string? uri) uri)
 741                        ((uri mirrors ...) uri))))
 742          (package   (package-upstream-name package))
 743          (directory (dirname (uri-path uri)))
 744          (rewrite   (url-prefix-rewrite %kernel.org-base
 745                                         "mirror://kernel.org")))
 746     (and=> (latest-html-release package
 747                                 #:base-url %kernel.org-base
 748                                 #:directory directory
 749                                 #:file->signature file->signature)
 750            (cut adjusted-upstream-source <> rewrite))))
 751
 752 (define html-updatable-package?
 753   ;; Return true if the given package may be handled by the generic HTML
 754   ;; updater.
 755   (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
 756                          "notabug.org" "sr.ht"
 757                          "gforge.inria.fr" "gitlab.inria.fr"
 758                          "ftp.gnu.org" "download.savannah.gnu.org"
 759                          "pypi.org" "crates.io" "rubygems.org"
 760                          "bioconductor.org")))
 761     (define http-url?
 762       (url-predicate (lambda (url)
 763                        (match (string->uri url)
 764                          (#f #f)
 765                          (uri
 766                           (let ((scheme (uri-scheme uri))
 767                                 (host   (uri-host uri)))
 768                             (and (memq scheme '(http https))
 769                                  (not (member host hosting-sites)))))))))
 770
 771     (lambda (package)
 772       (or (assoc-ref (package-properties package) 'release-monitoring-url)
 773           (http-url? package)))))
 774
 775 (define (latest-html-updatable-release package)
 776   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
 777 the directory containing its source tarball."
 778   (let* ((uri       (string->uri
 779                      (match (origin-uri (package-source package))
 780                        ((? string? url) url)
 781                        ((url _ ...) url))))
 782          (custom    (assoc-ref (package-properties package)
 783                                'release-monitoring-url))
 784          (base      (or custom
 785                         (string-append (symbol->string (uri-scheme uri))
 786                                        "://" (uri-host uri))))
 787          (directory (if custom
 788                         ""
 789                         (dirname (uri-path uri))))
 790          (package   (package-upstream-name package)))
 791     (catch #t
 792       (lambda ()
 793         (guard (c ((http-get-error? c) #f))
 794           (latest-html-release package
 795                                #:base-url base
 796                                #:directory directory)))
 797       (lambda (key . args)
 798         ;; Return false and move on upon connection failures and bogus HTTP
 799         ;; servers.
 800         (unless (memq key '(gnutls-error tls-certificate-error
 801                                          system-error
 802                                          bad-header bad-header-component))
 803           (apply throw key args))
 804         #f))))
 805
 806 (define %gnu-updater
 807   ;; This is for everything at ftp.gnu.org.
 808   (upstream-updater
 809    (name 'gnu)
 810    (description "Updater for GNU packages")
 811    (pred gnu-hosted?)
 812    (latest latest-gnu-release)))
 813
 814 (define %gnu-ftp-updater
 815   ;; This is for GNU packages taken from alternate locations, such as
 816   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 817   (upstream-updater
 818    (name 'gnu-ftp)
 819    (description "Updater for GNU packages only available via FTP")
 820    (pred (lambda (package)
 821            (and (not (gnu-hosted? package))
 822                 (pure-gnu-package? package))))
 823    (latest latest-release*)))
 824
 825 (define %savannah-updater
 826   (upstream-updater
 827    (name 'savannah)
 828    (description "Updater for packages hosted on savannah.gnu.org")
 829    (pred (url-prefix-predicate "mirror://savannah/"))
 830    (latest latest-savannah-release)))
 831
 832 (define %sourceforge-updater
 833   (upstream-updater
 834    (name 'sourceforge)
 835    (description "Updater for packages hosted on sourceforge.net")
 836    (pred (url-prefix-predicate "mirror://sourceforge/"))
 837    (latest latest-sourceforge-release)))
 838
 839 (define %xorg-updater
 840   (upstream-updater
 841    (name 'xorg)
 842    (description "Updater for X.org packages")
 843    (pred (url-prefix-predicate "mirror://xorg/"))
 844    (latest latest-xorg-release)))
 845
 846 (define %kernel.org-updater
 847   (upstream-updater
 848    (name 'kernel.org)
 849    (description "Updater for packages hosted on kernel.org")
 850    (pred (url-prefix-predicate "mirror://kernel.org/"))
 851    (latest latest-kernel.org-release)))
 852
 853 (define %generic-html-updater
 854   (upstream-updater
 855    (name 'generic-html)
 856    (description "Updater that crawls HTML pages.")
 857    (pred html-updatable-package?)
 858    (latest latest-html-updatable-release)))
 859
 860 ;;; gnu-maintenance.scm ends here