guix/gnu-maintenance.scm

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