guix/gnu-maintenance.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix gnu-maintenance)
  21   #:use-module (web uri)
  22   #:use-module (web client)
  23   #:use-module (web response)
  24   #:use-module (sxml simple)
  25   #:use-module (ice-9 regex)
  26   #:use-module (ice-9 match)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (rnrs io ports)
  31   #:use-module (system foreign)
  32   #:use-module (guix http-client)
  33   #:use-module (guix ftp-client)
  34   #:use-module (guix utils)
  35   #:use-module (guix memoization)
  36   #:use-module (guix records)
  37   #:use-module (guix upstream)
  38   #:use-module (guix packages)
  39   #:use-module (guix zlib)
  40   #:export (gnu-package-name
  41             gnu-package-mundane-name
  42             gnu-package-copyright-holder
  43             gnu-package-savannah
  44             gnu-package-fsd
  45             gnu-package-language
  46             gnu-package-logo
  47             gnu-package-doc-category
  48             gnu-package-doc-summary
  49             gnu-package-doc-description
  50             gnu-package-doc-urls
  51             gnu-package-download-url
  52
  53             official-gnu-packages
  54             find-package
  55             gnu-package?
  56
  57             release-file?
  58             releases
  59             latest-release
  60             gnu-release-archive-types
  61             gnu-package-name->name+version
  62
  63             %gnu-updater
  64             %gnu-ftp-updater
  65             %kde-updater
  66             %xorg-updater
  67             %kernel.org-updater))
  68
  69 ;;; Commentary:
  70 ;;;
  71 ;;; Code for dealing with the maintenance of GNU packages, such as
  72 ;;; auto-updates.
  73 ;;;
  74 ;;; Code:
  75
  76 \f
  77 ;;;
  78 ;;; List of GNU packages.
  79 ;;;
  80
  81 (define %gnumaint-base-url
  82   "https://web.cvs.savannah.gnu.org/viewvc/*checkout*/www/www/prep/gnumaint/")
  83
  84 (define %package-list-url
  85   (string->uri
  86    (string-append %gnumaint-base-url "rec/gnupackages.rec")))
  87
  88 (define %package-description-url
  89   ;; This file contains package descriptions in recutils format.
  90   ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>
  91   ;; and <https://lists.gnu.org/archive/html/guix-devel/2018-06/msg00362.html>.
  92   (string->uri
  93    (string-append %gnumaint-base-url "rec/pkgblurbs.rec")))
  94
  95 (define-record-type* <gnu-package-descriptor>
  96   gnu-package-descriptor
  97   make-gnu-package-descriptor
  98
  99   gnu-package-descriptor?
 100
 101   (name             gnu-package-name)
 102   (mundane-name     gnu-package-mundane-name)
 103   (copyright-holder gnu-package-copyright-holder)
 104   (savannah         gnu-package-savannah)
 105   (fsd              gnu-package-fsd)
 106   (language         gnu-package-language)         ; list of strings
 107   (logo             gnu-package-logo)
 108   (doc-category     gnu-package-doc-category)
 109   (doc-summary      gnu-package-doc-summary)
 110   (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
 111   (doc-urls         gnu-package-doc-urls)         ; list of strings
 112   (download-url     gnu-package-download-url))
 113
 114 (define* (official-gnu-packages
 115           #:optional (fetch http-fetch/cached))
 116   "Return a list of records, which are GNU packages.  Use FETCH,
 117 to fetch the list of GNU packages over HTTP."
 118   (define (read-records port)
 119     ;; Return a list of alists.  Each alist contains fields of a GNU
 120     ;; package.
 121     (let loop ((alist  (recutils->alist port))
 122                (result '()))
 123       (if (null? alist)
 124           (reverse result)
 125           (loop (recutils->alist port)
 126
 127                 ;; Ignore things like "%rec" (info "(recutils) Record
 128                 ;; Descriptors").
 129                 (if (assoc-ref alist "package")
 130                     (cons alist result)
 131                     result)))))
 132
 133   (define official-description
 134     (let ((db (read-records (fetch %package-description-url #:text? #t))))
 135       (lambda (name)
 136         ;; Return the description found upstream for package NAME, or #f.
 137         (and=> (find (lambda (alist)
 138                        (equal? name (assoc-ref alist "package")))
 139                      db)
 140                (lambda (record)
 141                  (let ((field (assoc-ref record "blurb")))
 142                    ;; The upstream description file uses "redirect PACKAGE" as
 143                    ;; a blurb in cases where the description of the two
 144                    ;; packages should be considered the same (e.g., GTK+ has
 145                    ;; "redirect gnome".)  This is usually not acceptable for
 146                    ;; us because we prefer to have distinct descriptions in
 147                    ;; such cases.  Thus, ignore the 'blurb' field when that
 148                    ;; happens.
 149                    (and field
 150                         (not (string-prefix? "redirect " field))
 151                         field)))))))
 152
 153   (map (lambda (alist)
 154          (let ((name (assoc-ref alist "package")))
 155            (alist->record `(("description" . ,(official-description name))
 156                             ,@alist)
 157                           make-gnu-package-descriptor
 158                           (list "package" "mundane_name" "copyright_holder"
 159                                 "savannah" "fsd" "language" "logo"
 160                                 "doc_category" "doc_summary" "description"
 161                                 "doc_url"
 162                                 "download_url")
 163                           '("doc_url" "language"))))
 164        (let* ((port (fetch %package-list-url #:text? #t))
 165               (lst  (read-records port)))
 166          (close-port port)
 167          lst)))
 168
 169 (define (find-package name)
 170   "Find GNU package called NAME and return it.  Return #f if it was not
 171 found."
 172   (find (lambda (package)
 173           (string=? name (gnu-package-name package)))
 174         (official-gnu-packages)))
 175
 176 (define gnu-package?
 177   (let ((official-gnu-packages (memoize official-gnu-packages)))
 178     (mlambdaq (package)
 179       "Return true if PACKAGE is a GNU package.  This procedure may access the
 180 network to check in GNU's database."
 181       (define (mirror-type url)
 182         (let ((uri (string->uri url)))
 183           (and (eq? (uri-scheme uri) 'mirror)
 184                (cond
 185                 ((member (uri-host uri)
 186                          '("gnu" "gnupg" "gcc" "gnome"))
 187                  ;; Definitely GNU.
 188                  'gnu)
 189                 ((equal? (uri-host uri) "cran")
 190                  ;; Possibly GNU: mirror://cran could be either GNU R itself
 191                  ;; or a non-GNU package.
 192                  #f)
 193                 (else
 194                  ;; Definitely non-GNU.
 195                  'non-gnu)))))
 196
 197       (define (gnu-home-page? package)
 198         (letrec-syntax ((>> (syntax-rules ()
 199                               ((_ value proc)
 200                                (and=> value proc))
 201                               ((_ value proc rest ...)
 202                                (and=> value
 203                                       (lambda (next)
 204                                         (>> (proc next) rest ...)))))))
 205           (>> package package-home-page
 206               string->uri uri-host
 207               (lambda (host)
 208                 (member host '("www.gnu.org" "gnu.org"))))))
 209
 210       (or (gnu-home-page? package)
 211           (let ((url  (and=> (package-source package) origin-uri))
 212                 (name (package-upstream-name package)))
 213             (case (and (string? url) (mirror-type url))
 214               ((gnu) #t)
 215               ((non-gnu) #f)
 216               (else
 217                (and (member name (map gnu-package-name (official-gnu-packages)))
 218                     #t))))))))
 219
 220 \f
 221 ;;;
 222 ;;; Latest FTP release.
 223 ;;;
 224
 225 (define (ftp-server/directory package)
 226   "Return the FTP server and directory where PACKAGE's tarball are stored."
 227   (let ((name (package-upstream-name package)))
 228     (values (or (assoc-ref (package-properties package) 'ftp-server)
 229                 "ftp.gnu.org")
 230             (or (assoc-ref (package-properties package) 'ftp-directory)
 231                 (string-append "/gnu/" name)))))
 232
 233 (define (sans-extension tarball)
 234   "Return TARBALL without its .tar.* or .zip extension."
 235   (let ((end (or (string-contains tarball ".tar")
 236                  (string-contains tarball ".zip"))))
 237     (substring tarball 0 end)))
 238
 239 (define %tarball-rx
 240   ;; The .zip extensions is notably used for freefont-ttf.
 241   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 242   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 243   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 244
 245 (define %alpha-tarball-rx
 246   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 247
 248 (define (release-file? project file)
 249   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 250 true."
 251   (and (not (member (file-extension file) '("sig" "sign" "asc")))
 252        (and=> (regexp-exec %tarball-rx file)
 253               (lambda (match)
 254                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 255                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 256                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 257                 (and=> (match:substring match 1)
 258                        (lambda (name)
 259                          (or (string-ci=? name project)
 260                              (string-ci=? name
 261                                           (string-append project
 262                                                          "-src")))))))
 263        (not (regexp-exec %alpha-tarball-rx file))
 264        (let ((s (sans-extension file)))
 265          (regexp-exec %package-name-rx s))))
 266
 267 (define (tarball->version tarball)
 268   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 269 \"coreutils-8.23.tar.xz\"."
 270   (let-values (((name version)
 271                 (gnu-package-name->name+version (sans-extension tarball))))
 272     version))
 273
 274 (define* (releases project
 275                    #:key
 276                    (server "ftp.gnu.org")
 277                    (directory (string-append "/gnu/" project)))
 278   "Return the list of <upstream-release> of PROJECT as a list of release
 279 name/directory pairs."
 280   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 281   (define conn (ftp-open server))
 282
 283   (let loop ((directories (list directory))
 284              (result      '()))
 285     (match directories
 286       (()
 287        (ftp-close conn)
 288        (coalesce-sources result))
 289       ((directory rest ...)
 290        (let* ((files   (ftp-list conn directory))
 291               (subdirs (filter-map (match-lambda
 292                                      ((name 'directory . _) name)
 293                                      (_ #f))
 294                                    files)))
 295          (define (file->url file)
 296            (string-append "ftp://" server directory "/" file))
 297
 298          (define (file->source file)
 299            (let ((url (file->url file)))
 300              (upstream-source
 301               (package project)
 302               (version (tarball->version file))
 303               (urls (list url))
 304               (signature-urls (list (string-append url ".sig"))))))
 305
 306          (loop (append (map (cut string-append directory "/" <>)
 307                             subdirs)
 308                        rest)
 309                (append
 310                 ;; Filter out signatures, deltas, and files which
 311                 ;; are potentially not releases of PROJECT--e.g.,
 312                 ;; in /gnu/guile, filter out guile-oops and
 313                 ;; guile-www; in mit-scheme, filter out binaries.
 314                 (filter-map (match-lambda
 315                               ((file 'file . _)
 316                                (and (release-file? project file)
 317                                     (file->source file)))
 318                               (_ #f))
 319                             files)
 320                 result)))))))
 321
 322 (define* (latest-ftp-release project
 323                              #:key
 324                              (server "ftp.gnu.org")
 325                              (directory (string-append "/gnu/" project))
 326                              (keep-file? (const #t))
 327                              (file->signature (cut string-append <> ".sig"))
 328                              (ftp-open ftp-open) (ftp-close ftp-close))
 329   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 330 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 331 connections; this can be useful to reuse connections.
 332
 333 KEEP-FILE? is a predicate to decide whether to enter a directory and to
 334 consider a given file (source tarball) as a valid candidate based on its name.
 335
 336 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 337 return the corresponding signature URL, or #f it signatures are unavailable."
 338   (define (latest a b)
 339     (if (version>? a b) a b))
 340
 341   (define (latest-release a b)
 342     (if (version>? (upstream-source-version a) (upstream-source-version b))
 343         a b))
 344
 345   (define patch-directory-name?
 346     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 347     (cut string-suffix? "patches" <>))
 348
 349   (define conn (ftp-open server))
 350
 351   (define (file->url directory file)
 352     (string-append "ftp://" server directory "/" file))
 353
 354   (define (file->source directory file)
 355     (let ((url (file->url directory file)))
 356       (upstream-source
 357        (package project)
 358        (version (tarball->version file))
 359        (urls (list url))
 360        (signature-urls (match (file->signature url)
 361                          (#f #f)
 362                          (sig (list sig)))))))
 363
 364   (let loop ((directory directory)
 365              (result    #f))
 366     (let* ((entries (ftp-list conn directory))
 367
 368            ;; Filter out things like /gnupg/patches.  Filter out "w32"
 369            ;; directories as found on ftp.gnutls.org.
 370            (subdirs (filter-map (match-lambda
 371                                   (((? patch-directory-name? dir)
 372                                     'directory . _)
 373                                    #f)
 374                                   (("w32" 'directory . _)
 375                                    #f)
 376                                   (("unstable" 'directory . _)
 377                                    ;; As seen at ftp.gnupg.org/gcrypt/pinentry.
 378                                    #f)
 379                                   ((directory 'directory . _)
 380                                    directory)
 381                                   (_ #f))
 382                                 entries))
 383
 384            ;; Whether or not SUBDIRS is empty, compute the latest releases
 385            ;; for the current directory.  This is necessary for packages
 386            ;; such as 'sharutils' that have a sub-directory that contains
 387            ;; only an older release.
 388            (releases (filter-map (match-lambda
 389                                    ((file 'file . _)
 390                                     (and (release-file? project file)
 391                                          (keep-file? file)
 392                                          (file->source directory file)))
 393                                    (_ #f))
 394                                  entries)))
 395
 396       ;; Assume that SUBDIRS correspond to versions, and jump into the
 397       ;; one with the highest version number.
 398       (let* ((release  (reduce latest-release #f
 399                                (coalesce-sources releases)))
 400              (result   (if (and result release)
 401                            (latest-release release result)
 402                            (or release result)))
 403              (target   (reduce latest #f subdirs)))
 404         (if target
 405             (loop (string-append directory "/" target)
 406                   result)
 407             (begin
 408               (ftp-close conn)
 409               result))))))
 410
 411 (define* (latest-release package
 412                          #:key
 413                          (server "ftp.gnu.org")
 414                          (directory (string-append "/gnu/" package)))
 415   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 416 PACKAGE must be the canonical name of a GNU package."
 417   (latest-ftp-release package
 418                       #:server server
 419                       #:directory directory))
 420
 421 (define-syntax-rule (false-if-ftp-error exp)
 422   "Return #f if an FTP error is raise while evaluating EXP; return the result
 423 of EXP otherwise."
 424   (catch 'ftp-error
 425     (lambda ()
 426       exp)
 427     (lambda (key port . rest)
 428       (if (ftp-connection? port)
 429           (ftp-close port)
 430           (close-port port))
 431       #f)))
 432
 433 (define (latest-release* package)
 434   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 435 errors that might occur when PACKAGE is not actually a GNU package, or not
 436 hosted on ftp.gnu.org, or not under that name (this is the case for
 437 \"emacs-auctex\", for instance.)"
 438   (let-values (((server directory)
 439                 (ftp-server/directory package)))
 440     (false-if-ftp-error (latest-release (package-upstream-name package)
 441                                         #:server server
 442                                         #:directory directory))))
 443
 444 \f
 445 ;;;
 446 ;;; Latest HTTP release.
 447 ;;;
 448
 449 (define (html->sxml port)
 450   "Read HTML from PORT and return the corresponding SXML tree."
 451   (let ((str (get-string-all port)))
 452     (catch #t
 453       (lambda ()
 454         ;; XXX: This is the poor developer's HTML-to-XML converter.  It's good
 455         ;; enough for directory listings at <https://kernel.org/pub> but if
 456         ;; needed we could resort to (htmlprag) from Guile-Lib.
 457         (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
 458           xml->sxml))
 459       (const '(html)))))                          ;parse error
 460
 461 (define (html-links sxml)
 462   "Return the list of links found in SXML, the SXML tree of an HTML page."
 463   (let loop ((sxml sxml)
 464              (links '()))
 465     (match sxml
 466       (('a ('@ attributes ...) body ...)
 467        (match (assq 'href attributes)
 468          (#f          (fold loop links body))
 469          (('href url) (fold loop (cons url links) body))))
 470       ((tag ('@ _ ...) body ...)
 471        (fold loop links body))
 472       ((tag body ...)
 473        (fold loop links body))
 474       (_
 475        links))))
 476
 477 (define* (latest-html-release package
 478                               #:key
 479                               (base-url "https://kernel.org/pub")
 480                               (directory (string-append "/" package))
 481                               (file->signature (cut string-append <> ".sig")))
 482   "Return an <upstream-source> for the latest release of PACKAGE (a string) on
 483 SERVER under DIRECTORY, or #f.  BASE-URL should be the URL of an HTML page,
 484 typically a directory listing as found on 'https://kernel.org/pub'.
 485
 486 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 487 return the corresponding signature URL, or #f it signatures are unavailable."
 488   (let* ((uri  (string->uri (string-append base-url directory "/")))
 489          (port (http-fetch/cached uri #:ttl 3600))
 490          (sxml (html->sxml port)))
 491     (define (url->release url)
 492       (and (string=? url (basename url))          ;relative reference?
 493            (release-file? package url)
 494            (let-values (((name version)
 495                          (package-name->name+version (sans-extension url)
 496                                                      #\-)))
 497              (upstream-source
 498               (package name)
 499               (version version)
 500               (urls (list (string-append base-url directory "/" url)))
 501               (signature-urls
 502                (list (string-append base-url directory "/"
 503                                     (file-sans-extension url)
 504                                     ".sign")))))))
 505
 506     (define candidates
 507       (filter-map url->release (html-links sxml)))
 508
 509     (close-port port)
 510     (match candidates
 511       (() #f)
 512       ((first . _)
 513        ;; Select the most recent release and return it.
 514        (reduce (lambda (r1 r2)
 515                  (if (version>? (upstream-source-version r1)
 516                                 (upstream-source-version r2))
 517                      r1 r2))
 518                first
 519                (coalesce-sources candidates))))))
 520
 521 \f
 522 ;;;
 523 ;;; Updaters.
 524 ;;;
 525
 526 (define %gnu-file-list-uri
 527   ;; URI of the file list for ftp.gnu.org.
 528   (string->uri "https://ftp.gnu.org/find.txt.gz"))
 529
 530 (define ftp.gnu.org-files
 531   (mlambda ()
 532     "Return the list of files available at ftp.gnu.org."
 533
 534     ;; XXX: Memoize the whole procedure to work around the fact that
 535     ;; 'http-fetch/cached' caches the gzipped version.
 536
 537     (define (trim-leading-components str)
 538       ;; Trim the leading ".", if any, in "./gnu/foo".
 539       (string-trim str (char-set #\.)))
 540
 541     (define (string->lines str)
 542       (string-tokenize str (char-set-complement (char-set #\newline))))
 543
 544     ;; Since https://ftp.gnu.org honors 'If-Modified-Since', the hard-coded
 545     ;; TTL can be relatively short.
 546     (let ((port (http-fetch/cached %gnu-file-list-uri #:ttl (* 15 60))))
 547       (map trim-leading-components
 548            (call-with-gzip-input-port port
 549              (compose string->lines get-string-all))))))
 550
 551 (define (latest-gnu-release package)
 552   "Return the latest release of PACKAGE, a GNU package available via
 553 ftp.gnu.org.
 554
 555 This method does not rely on FTP access at all; instead, it browses the file
 556 list available from %GNU-FILE-LIST-URI over HTTP(S)."
 557   (let-values (((server directory)
 558                 (ftp-server/directory package))
 559                ((name)
 560                 (package-upstream-name package)))
 561     (let* ((files    (ftp.gnu.org-files))
 562            (relevant (filter (lambda (file)
 563                                (and (string-prefix? "/gnu" file)
 564                                     (string-contains file directory)
 565                                     (release-file? name (basename file))))
 566                              files)))
 567       (match (sort relevant (lambda (file1 file2)
 568                               (version>? (sans-extension (basename file1))
 569                                          (sans-extension (basename file2)))))
 570         ((and tarballs (reference _ ...))
 571          (let* ((version  (tarball->version reference))
 572                 (tarballs (filter (lambda (file)
 573                                     (string=? (sans-extension
 574                                                (basename file))
 575                                               (sans-extension
 576                                                (basename reference))))
 577                                   tarballs)))
 578            (upstream-source
 579             (package name)
 580             (version version)
 581             (urls (map (lambda (file)
 582                          (string-append "mirror://gnu/"
 583                                         (string-drop file
 584                                                      (string-length "/gnu/"))))
 585                        tarballs))
 586             (signature-urls (map (cut string-append <> ".sig") urls)))))
 587         (()
 588          #f)))))
 589
 590 (define %package-name-rx
 591   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 592   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 593   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 594
 595 (define (gnu-package-name->name+version name+version)
 596   "Return the package name and version number extracted from NAME+VERSION."
 597   (let ((match (regexp-exec %package-name-rx name+version)))
 598     (if (not match)
 599         (values name+version #f)
 600         (values (match:substring match 1) (match:substring match 2)))))
 601
 602 (define gnome-package?
 603   (url-prefix-predicate "mirror://gnome/"))
 604
 605 (define (pure-gnu-package? package)
 606   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 607 excludes AucTeX, for instance, whose releases are now uploaded to
 608 elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
 609 releases are on gnu.org."
 610   (and (or (not (string-prefix? "emacs-" (package-name package)))
 611            (gnu-hosted? package))
 612        (not (gnome-package? package))
 613        (gnu-package? package)))
 614
 615 (define gnu-hosted?
 616   (url-prefix-predicate "mirror://gnu/"))
 617
 618 (define (latest-kde-release package)
 619   "Return the latest release of PACKAGE, the name of an KDE.org package."
 620   (let ((uri (string->uri (origin-uri (package-source package)))))
 621     (false-if-ftp-error
 622      (latest-ftp-release
 623       (package-upstream-name package)
 624       #:server "ftp.mirrorservice.org"
 625       #:directory (string-append "/sites/ftp.kde.org/pub/kde/"
 626                                  (dirname (dirname (uri-path uri))))))))
 627
 628 (define (latest-xorg-release package)
 629   "Return the latest release of PACKAGE, the name of an X.org package."
 630   (let ((uri (string->uri (origin-uri (package-source package)))))
 631     (false-if-ftp-error
 632      (latest-ftp-release
 633       (package-name package)
 634       #:server "ftp.freedesktop.org"
 635       #:directory
 636       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 637
 638 (define (latest-kernel.org-release package)
 639   "Return the latest release of PACKAGE, the name of a kernel.org package."
 640   (define %kernel.org-base
 641     ;; This URL and sub-directories thereof are nginx-generated directory
 642     ;; listings suitable for 'latest-html-release'.
 643     "https://mirrors.edge.kernel.org/pub")
 644
 645   (define (file->signature file)
 646     (string-append (file-sans-extension file) ".sign"))
 647
 648   (let* ((uri       (string->uri (origin-uri (package-source package))))
 649          (package   (package-upstream-name package))
 650          (directory (dirname (uri-path uri))))
 651     (latest-html-release package
 652                          #:base-url %kernel.org-base
 653                          #:directory directory
 654                          #:file->signature file->signature)))
 655
 656 (define %gnu-updater
 657   ;; This is for everything at ftp.gnu.org.
 658   (upstream-updater
 659    (name 'gnu)
 660    (description "Updater for GNU packages")
 661    (pred gnu-hosted?)
 662    (latest latest-gnu-release)))
 663
 664 (define %gnu-ftp-updater
 665   ;; This is for GNU packages taken from alternate locations, such as
 666   ;; alpha.gnu.org, ftp.gnupg.org, etc.  It is obsolescent.
 667   (upstream-updater
 668    (name 'gnu-ftp)
 669    (description "Updater for GNU packages only available via FTP")
 670    (pred (lambda (package)
 671            (and (not (gnu-hosted? package))
 672                 (pure-gnu-package? package))))
 673    (latest latest-release*)))
 674
 675 (define %kde-updater
 676   (upstream-updater
 677     (name 'kde)
 678     (description "Updater for KDE packages")
 679     (pred (url-prefix-predicate "mirror://kde/"))
 680     (latest latest-kde-release)))
 681
 682 (define %xorg-updater
 683   (upstream-updater
 684    (name 'xorg)
 685    (description "Updater for X.org packages")
 686    (pred (url-prefix-predicate "mirror://xorg/"))
 687    (latest latest-xorg-release)))
 688
 689 (define %kernel.org-updater
 690   (upstream-updater
 691    (name 'kernel.org)
 692    (description "Updater for packages hosted on kernel.org")
 693    (pred (url-prefix-predicate "mirror://kernel.org/"))
 694    (latest latest-kernel.org-release)))
 695
 696 ;;; gnu-maintenance.scm ends here