guix/gnu-maintenance.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 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 (ice-9 regex)
  25   #:use-module (ice-9 match)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-11)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (system foreign)
  30   #:use-module (guix http-client)
  31   #:use-module (guix ftp-client)
  32   #:use-module (guix utils)
  33   #:use-module (guix combinators)
  34   #:use-module (guix records)
  35   #:use-module (guix upstream)
  36   #:use-module (guix packages)
  37   #:export (gnu-package-name
  38             gnu-package-mundane-name
  39             gnu-package-copyright-holder
  40             gnu-package-savannah
  41             gnu-package-fsd
  42             gnu-package-language
  43             gnu-package-logo
  44             gnu-package-doc-category
  45             gnu-package-doc-summary
  46             gnu-package-doc-description
  47             gnu-package-doc-urls
  48             gnu-package-download-url
  49
  50             official-gnu-packages
  51             find-package
  52             gnu-package?
  53
  54             release-file?
  55             releases
  56             latest-release
  57             gnu-release-archive-types
  58             gnu-package-name->name+version
  59
  60             %gnu-updater
  61             %gnome-updater
  62             %kde-updater
  63             %xorg-updater
  64             %kernel.org-updater))
  65
  66 ;;; Commentary:
  67 ;;;
  68 ;;; Code for dealing with the maintenance of GNU packages, such as
  69 ;;; auto-updates.
  70 ;;;
  71 ;;; Code:
  72
  73 \f
  74 ;;;
  75 ;;; List of GNU packages.
  76 ;;;
  77
  78 (define %gnumaint-base-url
  79   "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/")
  80
  81 (define %package-list-url
  82   (string->uri
  83    (string-append %gnumaint-base-url "gnupackages.txt")))
  84
  85 (define %package-description-url
  86   ;; This file contains package descriptions in recutils format.
  87   ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
  88   (string->uri
  89    (string-append %gnumaint-base-url "pkgblurbs.txt")))
  90
  91 (define-record-type* <gnu-package-descriptor>
  92   gnu-package-descriptor
  93   make-gnu-package-descriptor
  94
  95   gnu-package-descriptor?
  96
  97   (name             gnu-package-name)
  98   (mundane-name     gnu-package-mundane-name)
  99   (copyright-holder gnu-package-copyright-holder)
 100   (savannah         gnu-package-savannah)
 101   (fsd              gnu-package-fsd)
 102   (language         gnu-package-language)         ; list of strings
 103   (logo             gnu-package-logo)
 104   (doc-category     gnu-package-doc-category)
 105   (doc-summary      gnu-package-doc-summary)
 106   (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
 107   (doc-urls         gnu-package-doc-urls)         ; list of strings
 108   (download-url     gnu-package-download-url))
 109
 110 (define* (official-gnu-packages
 111           #:optional (fetch http-fetch/cached))
 112   "Return a list of records, which are GNU packages.  Use FETCH,
 113 to fetch the list of GNU packages over HTTP."
 114   (define (read-records port)
 115     ;; Return a list of alists.  Each alist contains fields of a GNU
 116     ;; package.
 117     (let loop ((alist  (recutils->alist port))
 118                (result '()))
 119       (if (null? alist)
 120           (reverse result)
 121           (loop (recutils->alist port)
 122                 (cons alist result)))))
 123
 124   (define official-description
 125     (let ((db (read-records (fetch %package-description-url #:text? #t))))
 126       (lambda (name)
 127         ;; Return the description found upstream for package NAME, or #f.
 128         (and=> (find (lambda (alist)
 129                        (equal? name (assoc-ref alist "package")))
 130                      db)
 131                (lambda (record)
 132                  (let ((field (assoc-ref record "blurb")))
 133                    ;; The upstream description file uses "redirect PACKAGE" as
 134                    ;; a blurb in cases where the description of the two
 135                    ;; packages should be considered the same (e.g., GTK+ has
 136                    ;; "redirect gnome".)  This is usually not acceptable for
 137                    ;; us because we prefer to have distinct descriptions in
 138                    ;; such cases.  Thus, ignore the 'blurb' field when that
 139                    ;; happens.
 140                    (and field
 141                         (not (string-prefix? "redirect " field))
 142                         field)))))))
 143
 144   (map (lambda (alist)
 145          (let ((name (assoc-ref alist "package")))
 146            (alist->record `(("description" . ,(official-description name))
 147                             ,@alist)
 148                           make-gnu-package-descriptor
 149                           (list "package" "mundane-name" "copyright-holder"
 150                                 "savannah" "fsd" "language" "logo"
 151                                 "doc-category" "doc-summary" "description"
 152                                 "doc-url"
 153                                 "download-url")
 154                           '("doc-url" "language"))))
 155        (let* ((port (fetch %package-list-url #:text? #t))
 156               (lst  (read-records port)))
 157          (close-port port)
 158          lst)))
 159
 160 (define (find-package name)
 161   "Find GNU package called NAME and return it.  Return #f if it was not
 162 found."
 163   (find (lambda (package)
 164           (string=? name (gnu-package-name package)))
 165         (official-gnu-packages)))
 166
 167 (define gnu-package?
 168   (memoize
 169    (let ((official-gnu-packages (memoize official-gnu-packages)))
 170      (lambda (package)
 171        "Return true if PACKAGE is a GNU package.  This procedure may access the
 172 network to check in GNU's database."
 173        (define (mirror-type url)
 174          (let ((uri (string->uri url)))
 175            (and (eq? (uri-scheme uri) 'mirror)
 176                 (cond
 177                  ((member (uri-host uri)
 178                           '("gnu" "gnupg" "gcc" "gnome"))
 179                   ;; Definitely GNU.
 180                   'gnu)
 181                  ((equal? (uri-host uri) "cran")
 182                   ;; Possibly GNU: mirror://cran could be either GNU R itself
 183                   ;; or a non-GNU package.
 184                   #f)
 185                  (else
 186                   ;; Definitely non-GNU.
 187                   'non-gnu)))))
 188
 189        (define (gnu-home-page? package)
 190          (letrec-syntax ((>> (syntax-rules ()
 191                                ((_ value proc)
 192                                 (and=> value proc))
 193                                ((_ value proc rest ...)
 194                                 (and=> value
 195                                        (lambda (next)
 196                                          (>> (proc next) rest ...)))))))
 197            (>> package package-home-page
 198                string->uri uri-host
 199                (lambda (host)
 200                  (member host '("www.gnu.org" "gnu.org"))))))
 201
 202        (or (gnu-home-page? package)
 203            (let ((url  (and=> (package-source package) origin-uri))
 204                  (name (package-upstream-name package)))
 205              (case (and (string? url) (mirror-type url))
 206                ((gnu) #t)
 207                ((non-gnu) #f)
 208                (else
 209                 (and (member name (map gnu-package-name (official-gnu-packages)))
 210                      #t)))))))))
 211
 212 \f
 213 ;;;
 214 ;;; Latest release.
 215 ;;;
 216
 217 (define (ftp-server/directory package)
 218   "Return the FTP server and directory where PACKAGE's tarball are stored."
 219   (let ((name (package-upstream-name package)))
 220     (values (or (assoc-ref (package-properties package) 'ftp-server)
 221                 "ftp.gnu.org")
 222             (or (assoc-ref (package-properties package) 'ftp-directory)
 223                 (string-append "/gnu/" name)))))
 224
 225 (define (sans-extension tarball)
 226   "Return TARBALL without its .tar.* or .zip extension."
 227   (let ((end (or (string-contains tarball ".tar")
 228                  (string-contains tarball ".zip"))))
 229     (substring tarball 0 end)))
 230
 231 (define %tarball-rx
 232   ;; The .zip extensions is notably used for freefont-ttf.
 233   ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
 234   ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2".
 235   (make-regexp "^([^.]+)-([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)"))
 236
 237 (define %alpha-tarball-rx
 238   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 239
 240 (define (release-file? project file)
 241   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 242 true."
 243   (and (not (string-suffix? ".sig" file))
 244        (and=> (regexp-exec %tarball-rx file)
 245               (lambda (match)
 246                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 247                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
 248                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
 249                 (and=> (match:substring match 1)
 250                        (lambda (name)
 251                          (or (string-ci=? name project)
 252                              (string-ci=? name
 253                                           (string-append project
 254                                                          "-src")))))))
 255        (not (regexp-exec %alpha-tarball-rx file))
 256        (let ((s (sans-extension file)))
 257          (regexp-exec %package-name-rx s))))
 258
 259 (define (tarball->version tarball)
 260   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 261 \"coreutils-8.23.tar.xz\"."
 262   (let-values (((name version)
 263                 (gnu-package-name->name+version (sans-extension tarball))))
 264     version))
 265
 266 (define* (releases project
 267                    #:key
 268                    (server "ftp.gnu.org")
 269                    (directory (string-append "/gnu/" project)))
 270   "Return the list of <upstream-release> of PROJECT as a list of release
 271 name/directory pairs."
 272   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 273   (define conn (ftp-open server))
 274
 275   (let loop ((directories (list directory))
 276              (result      '()))
 277     (match directories
 278       (()
 279        (ftp-close conn)
 280        (coalesce-sources result))
 281       ((directory rest ...)
 282        (let* ((files   (ftp-list conn directory))
 283               (subdirs (filter-map (match-lambda
 284                                      ((name 'directory . _) name)
 285                                      (_ #f))
 286                                    files)))
 287          (define (file->url file)
 288            (string-append "ftp://" server directory "/" file))
 289
 290          (define (file->source file)
 291            (let ((url (file->url file)))
 292              (upstream-source
 293               (package project)
 294               (version (tarball->version file))
 295               (urls (list url))
 296               (signature-urls (list (string-append url ".sig"))))))
 297
 298          (loop (append (map (cut string-append directory "/" <>)
 299                             subdirs)
 300                        rest)
 301                (append
 302                 ;; Filter out signatures, deltas, and files which
 303                 ;; are potentially not releases of PROJECT--e.g.,
 304                 ;; in /gnu/guile, filter out guile-oops and
 305                 ;; guile-www; in mit-scheme, filter out binaries.
 306                 (filter-map (match-lambda
 307                               ((file 'file . _)
 308                                (and (release-file? project file)
 309                                     (file->source file)))
 310                               (_ #f))
 311                             files)
 312                 result)))))))
 313
 314 (define* (latest-ftp-release project
 315                              #:key
 316                              (server "ftp.gnu.org")
 317                              (directory (string-append "/gnu/" project))
 318                              (keep-file? (const #t))
 319                              (file->signature (cut string-append <> ".sig"))
 320                              (ftp-open ftp-open) (ftp-close ftp-close))
 321   "Return an <upstream-source> for the latest release of PROJECT on SERVER
 322 under DIRECTORY, or #f.  Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP
 323 connections; this can be useful to reuse connections.
 324
 325 KEEP-FILE? is a predicate to decide whether to enter a directory and to
 326 consider a given file (source tarball) as a valid candidate based on its name.
 327
 328 FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
 329 return the corresponding signature URL, or #f it signatures are unavailable."
 330   (define (latest a b)
 331     (if (version>? a b) a b))
 332
 333   (define (latest-release a b)
 334     (if (version>? (upstream-source-version a) (upstream-source-version b))
 335         a b))
 336
 337   (define contains-digit?
 338     (cut string-any char-set:digit <>))
 339
 340   (define patch-directory-name?
 341     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 342     (cut string-suffix? "patches" <>))
 343
 344   (define conn (ftp-open server))
 345
 346   (define (file->url directory file)
 347     (string-append "ftp://" server directory "/" file))
 348
 349   (define (file->source directory file)
 350     (let ((url (file->url directory file)))
 351       (upstream-source
 352        (package project)
 353        (version (tarball->version file))
 354        (urls (list url))
 355        (signature-urls (match (file->signature url)
 356                          (#f #f)
 357                          (sig (list sig)))))))
 358
 359   (let loop ((directory directory)
 360              (result    #f))
 361     (let* ((entries (ftp-list conn directory))
 362
 363            ;; Filter out sub-directories that do not contain digits---e.g.,
 364            ;; /gnuzilla/lang and /gnupg/patches.  Filter out "w32"
 365            ;; directories as found on ftp.gnutls.org.
 366            (subdirs (filter-map (match-lambda
 367                                   (((? patch-directory-name? dir)
 368                                     'directory . _)
 369                                    #f)
 370                                   (("w32" 'directory . _)
 371                                    #f)
 372                                   (((? contains-digit? dir) 'directory . _)
 373                                    (and (keep-file? dir) dir))
 374                                   (_ #f))
 375                                 entries))
 376
 377            ;; Whether or not SUBDIRS is empty, compute the latest releases
 378            ;; for the current directory.  This is necessary for packages
 379            ;; such as 'sharutils' that have a sub-directory that contains
 380            ;; only an older release.
 381            (releases (filter-map (match-lambda
 382                                    ((file 'file . _)
 383                                     (and (release-file? project file)
 384                                          (keep-file? file)
 385                                          (file->source directory file)))
 386                                    (_ #f))
 387                                  entries)))
 388
 389       ;; Assume that SUBDIRS correspond to versions, and jump into the
 390       ;; one with the highest version number.
 391       (let* ((release  (reduce latest-release #f
 392                                (coalesce-sources releases)))
 393              (result   (if (and result release)
 394                            (latest-release release result)
 395                            (or release result)))
 396              (target   (reduce latest #f subdirs)))
 397         (if target
 398             (loop (string-append directory "/" target)
 399                   result)
 400             (begin
 401               (ftp-close conn)
 402               result))))))
 403
 404 (define* (latest-release package
 405                          #:key
 406                          (server "ftp.gnu.org")
 407                          (directory (string-append "/gnu/" package)))
 408   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 409 PACKAGE must be the canonical name of a GNU package."
 410   (latest-ftp-release package
 411                       #:server server
 412                       #:directory directory))
 413
 414 (define-syntax-rule (false-if-ftp-error exp)
 415   "Return #f if an FTP error is raise while evaluating EXP; return the result
 416 of EXP otherwise."
 417   (catch 'ftp-error
 418     (lambda ()
 419       exp)
 420     (lambda (key port . rest)
 421       (if (ftp-connection? port)
 422           (ftp-close port)
 423           (close-port port))
 424       #f)))
 425
 426 (define (latest-release* package)
 427   "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
 428 errors that might occur when PACKAGE is not actually a GNU package, or not
 429 hosted on ftp.gnu.org, or not under that name (this is the case for
 430 \"emacs-auctex\", for instance.)"
 431   (let-values (((server directory)
 432                 (ftp-server/directory package)))
 433     (false-if-ftp-error (latest-release (package-upstream-name package)
 434                                         #:server server
 435                                         #:directory directory))))
 436
 437 (define %package-name-rx
 438   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 439   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 440   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 441
 442 (define (gnu-package-name->name+version name+version)
 443   "Return the package name and version number extracted from NAME+VERSION."
 444   (let ((match (regexp-exec %package-name-rx name+version)))
 445     (if (not match)
 446         (values name+version #f)
 447         (values (match:substring match 1) (match:substring match 2)))))
 448
 449 (define (pure-gnu-package? package)
 450   "Return true if PACKAGE is a non-Emacs and non-GNOME GNU package.  This
 451 excludes AucTeX, for instance, whose releases are now uploaded to
 452 elpa.gnu.org, and all the GNOME packages; EMMS is included though, because its
 453 releases are on gnu.org."
 454   (and (or (not (string-prefix? "emacs-" (package-name package)))
 455            (gnu-hosted? package))
 456        (not (gnome-package? package))
 457        (gnu-package? package)))
 458
 459 (define (url-prefix-predicate prefix)
 460   "Return a predicate that returns true when passed a package where one of its
 461 source URLs starts with PREFIX."
 462   (lambda (package)
 463     (define matching-uri?
 464       (match-lambda
 465         ((? string? uri)
 466          (string-prefix? prefix uri))
 467         (_
 468          #f)))
 469
 470     (match (package-source package)
 471       ((? origin? origin)
 472        (match (origin-uri origin)
 473          ((? matching-uri?) #t)
 474          (_                 #f)))
 475       (_ #f))))
 476
 477 (define gnu-hosted?
 478   (url-prefix-predicate "mirror://gnu/"))
 479
 480 (define gnome-package?
 481   (url-prefix-predicate "mirror://gnome/"))
 482
 483 (define (latest-gnome-release package)
 484   "Return the latest release of PACKAGE, the name of a GNOME package."
 485   (define %not-dot
 486     (char-set-complement (char-set #\.)))
 487
 488   (define (even-minor-version? version)
 489     (match (string-tokenize version %not-dot)
 490       (((= string->number major) (= string->number minor) . rest)
 491        (and minor (even? minor)))
 492       (_
 493        #t)))                                      ;cross fingers
 494
 495   (define (even-numbered? file)
 496     ;; Return true if FILE somehow denotes an even-numbered file name.  The
 497     ;; trick here is that we want this to match both directories such as
 498     ;; "3.18.6" and actual file names such as "gtk+-3.18.6.tar.bz2".
 499     (let-values (((name version) (package-name->name+version file)))
 500       (even-minor-version? (or version name))))
 501
 502   (define upstream-name
 503     ;; Some packages like "NetworkManager" have camel-case names.
 504     (package-upstream-name package))
 505
 506   (false-if-ftp-error
 507    (latest-ftp-release upstream-name
 508                        #:server "ftp.gnome.org"
 509                        #:directory (string-append "/pub/gnome/sources/"
 510                                                   upstream-name)
 511
 512
 513                        ;; <https://www.gnome.org/gnome-3/source/> explains
 514                        ;; that odd minor version numbers represent development
 515                        ;; releases, which we are usually not interested in.
 516                        #:keep-file? even-numbered?
 517
 518                        ;; ftp.gnome.org provides no signatures, only
 519                        ;; checksums.
 520                        #:file->signature (const #f))))
 521
 522
 523 (define (latest-kde-release package)
 524   "Return the latest release of PACKAGE, the name of an KDE.org package."
 525   (let ((uri (string->uri (origin-uri (package-source package)))))
 526     (false-if-ftp-error
 527      (latest-ftp-release
 528       (package-upstream-name package)
 529       #:server "mirrors.mit.edu"
 530       #:directory
 531       (string-append "/kde" (dirname (dirname (uri-path uri))))
 532       #:file->signature (const #f)))))
 533
 534 (define (latest-xorg-release package)
 535   "Return the latest release of PACKAGE, the name of an X.org package."
 536   (let ((uri (string->uri (origin-uri (package-source package)))))
 537     (false-if-ftp-error
 538      (latest-ftp-release
 539       (package-name package)
 540       #:server "ftp.freedesktop.org"
 541       #:directory
 542       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 543
 544 (define (latest-kernel.org-release package)
 545   "Return the latest release of PACKAGE, the name of a kernel.org package."
 546   (let ((uri (string->uri (origin-uri (package-source package)))))
 547     (false-if-ftp-error
 548      (latest-ftp-release
 549       (package-name package)
 550       #:server "ftp.free.fr"                      ;a mirror reachable over FTP
 551       #:directory (string-append "/mirrors/ftp.kernel.org"
 552                                  (dirname (uri-path uri)))
 553
 554       ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of
 555       ;; the uncompressed tarball.
 556       #:file->signature (lambda (tarball)
 557                           (string-append (file-sans-extension tarball)
 558                                          ".sign"))))))
 559
 560 (define %gnu-updater
 561   (upstream-updater
 562    (name 'gnu)
 563    (description "Updater for GNU packages")
 564    (pred pure-gnu-package?)
 565    (latest latest-release*)))
 566
 567 (define %gnome-updater
 568   (upstream-updater
 569    (name 'gnome)
 570    (description "Updater for GNOME packages")
 571    (pred gnome-package?)
 572    (latest latest-gnome-release)))
 573
 574 (define %kde-updater
 575   (upstream-updater
 576     (name 'kde)
 577     (description "Updater for KDE packages")
 578     (pred (url-prefix-predicate "mirror://kde/"))
 579     (latest latest-kde-release)))
 580
 581 (define %xorg-updater
 582   (upstream-updater
 583    (name 'xorg)
 584    (description "Updater for X.org packages")
 585    (pred (url-prefix-predicate "mirror://xorg/"))
 586    (latest latest-xorg-release)))
 587
 588 (define %kernel.org-updater
 589   (upstream-updater
 590    (name 'kernel.org)
 591    (description "Updater for packages hosted on kernel.org")
 592    (pred (url-prefix-predicate "mirror://kernel.org/"))
 593    (latest latest-kernel.org-release)))
 594
 595 ;;; gnu-maintenance.scm ends here