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 ui)
  33   #:use-module (guix utils)
  34   #:use-module (guix records)
  35   #:use-module (guix packages)
  36   #:use-module ((guix download) #:select (download-to-store))
  37   #:use-module (guix gnupg)
  38   #:use-module (rnrs io ports)
  39   #:use-module (guix base32)
  40   #:use-module ((guix build utils)
  41                 #:select (substitute))
  42   #:export (gnu-package-name
  43             gnu-package-mundane-name
  44             gnu-package-copyright-holder
  45             gnu-package-savannah
  46             gnu-package-fsd
  47             gnu-package-language
  48             gnu-package-logo
  49             gnu-package-doc-category
  50             gnu-package-doc-summary
  51             gnu-package-doc-description
  52             gnu-package-doc-urls
  53             gnu-package-download-url
  54
  55             official-gnu-packages
  56             find-packages
  57             gnu-package?
  58
  59             gnu-release?
  60             gnu-release-package
  61             gnu-release-version
  62             gnu-release-directory
  63             gnu-release-files
  64
  65             releases
  66             latest-release
  67             gnu-release-archive-types
  68             gnu-package-name->name+version
  69
  70             download-tarball
  71             package-update-path
  72             package-update
  73             update-package-source))
  74
  75 ;;; Commentary:
  76 ;;;
  77 ;;; Code for dealing with the maintenance of GNU packages, such as
  78 ;;; auto-updates.
  79 ;;;
  80 ;;; Code:
  81
  82 \f
  83 ;;;
  84 ;;; List of GNU packages.
  85 ;;;
  86
  87 (define %gnumaint-base-url
  88   "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/")
  89
  90 (define %package-list-url
  91   (string->uri
  92    (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
  93
  94 (define %package-description-url
  95   ;; This file contains package descriptions in recutils format.
  96   ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
  97   (string->uri
  98    (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
  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                 (cons alist 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-packages regexp)
 170   "Find GNU packages which satisfy REGEXP."
 171   (let ((name-rx (make-regexp regexp)))
 172     (filter (lambda (package)
 173               (false-if-exception
 174                (regexp-exec name-rx (gnu-package-name package))))
 175             (official-gnu-packages))))
 176
 177 (define gnu-package?
 178   (memoize
 179    (let ((official-gnu-packages (memoize official-gnu-packages)))
 180      (lambda (package)
 181        "Return true if PACKAGE is a GNU package.  This procedure may access the
 182 network to check in GNU's database."
 183        (define (mirror-type url)
 184          (let ((uri (string->uri url)))
 185            (and (eq? (uri-scheme uri) 'mirror)
 186                 (cond
 187                  ((member (uri-host uri)
 188                           '("gnu" "gnupg" "gcc" "gnome"))
 189                   ;; Definitely GNU.
 190                   'gnu)
 191                  ((equal? (uri-host uri) "cran")
 192                   ;; Possibly GNU: mirror://cran could be either GNU R itself
 193                   ;; or a non-GNU package.
 194                   #f)
 195                  (else
 196                   ;; Definitely non-GNU.
 197                   'non-gnu)))))
 198
 199        (define (gnu-home-page? package)
 200          (and=> (package-home-page package)
 201                 (lambda (url)
 202                   (and=> (uri-host (string->uri url))
 203                          (lambda (host)
 204                            (member host '("www.gnu.org" "gnu.org")))))))
 205
 206        (or (gnu-home-page? package)
 207            (let ((url  (and=> (package-source package) origin-uri))
 208                  (name (package-name package)))
 209              (case (and (string? url) (mirror-type url))
 210                ((gnu) #t)
 211                ((non-gnu) #f)
 212                (else
 213                 (and (member name (map gnu-package-name (official-gnu-packages)))
 214                      #t)))))))))
 215
 216 \f
 217 ;;;
 218 ;;; Latest release.
 219 ;;;
 220
 221 (define-record-type* <gnu-release> gnu-release make-gnu-release
 222   gnu-release?
 223   (package    gnu-release-package)
 224   (version    gnu-release-version)
 225   (directory  gnu-release-directory)
 226   (files      gnu-release-files))
 227
 228 (define (ftp-server/directory project)
 229   "Return the FTP server and directory where PROJECT's tarball are
 230 stored."
 231   (define quirks
 232     '(("commoncpp2"   "ftp.gnu.org"   "/gnu/commoncpp")
 233       ("ucommon"      "ftp.gnu.org"   "/gnu/commoncpp")
 234       ("libzrtpcpp"   "ftp.gnu.org"   "/gnu/ccrtp")
 235       ("libosip2"     "ftp.gnu.org"   "/gnu/osip")
 236       ("libgcrypt"    "ftp.gnupg.org" "/gcrypt/libgcrypt")
 237       ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
 238       ("libassuan"    "ftp.gnupg.org" "/gcrypt/libassuan")
 239       ("gnupg"        "ftp.gnupg.org" "/gcrypt/gnupg")
 240       ("freefont-ttf" "ftp.gnu.org"   "/gnu/freefont")
 241       ("gnu-ghostscript" "ftp.gnu.org"  "/gnu/ghostscript")
 242       ("mit-scheme"   "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
 243       ("icecat"       "ftp.gnu.org" "/gnu/gnuzilla")
 244       ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
 245       ("glib"         "ftp.gnome.org" "/pub/gnome/sources/glib")
 246       ("gnutls"       "ftp.gnutls.org" "/gcrypt/gnutls")
 247       ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))
 248
 249   (match (assoc project quirks)
 250     ((_ server directory)
 251      (values server directory))
 252     (_
 253      (values "ftp.gnu.org" (string-append "/gnu/" project)))))
 254
 255 (define (sans-extension tarball)
 256   "Return TARBALL without its .tar.* or .zip extension."
 257   (let ((end (or (string-contains tarball ".tar")
 258                  (string-contains tarball ".zip"))))
 259     (substring tarball 0 end)))
 260
 261 (define %tarball-rx
 262   ;; Note: .zip files are notably used for freefont-ttf.
 263   (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.(tar\\.|zip$)"))
 264
 265 (define %alpha-tarball-rx
 266   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 267
 268 (define (release-file? project file)
 269   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 270 true."
 271   (and (not (string-suffix? ".sig" file))
 272        (and=> (regexp-exec %tarball-rx file)
 273               (lambda (match)
 274                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 275                 (equal? project (match:substring match 1))))
 276        (not (regexp-exec %alpha-tarball-rx file))
 277        (let ((s (sans-extension file)))
 278          (regexp-exec %package-name-rx s))))
 279
 280 (define (tarball->version tarball)
 281   "Return the version TARBALL corresponds to.  TARBALL is a file name like
 282 \"coreutils-8.23.tar.xz\"."
 283   (let-values (((name version)
 284                 (gnu-package-name->name+version (sans-extension tarball))))
 285     version))
 286
 287 (define (coalesce-releases releases)
 288   "Coalesce the elements of RELEASES that correspond to the same version."
 289   (define (same-version? r1 r2)
 290     (string=? (gnu-release-version r1) (gnu-release-version r2)))
 291
 292   (define (release>? r1 r2)
 293     (version>? (gnu-release-version r1) (gnu-release-version r2)))
 294
 295   (fold (lambda (release result)
 296           (match result
 297             ((head . tail)
 298              (if (same-version? release head)
 299                  (cons (gnu-release
 300                         (inherit release)
 301                         (files (append (gnu-release-files release)
 302                                        (gnu-release-files head))))
 303                        tail)
 304                  (cons release result)))
 305             (()
 306              (list release))))
 307         '()
 308         (sort releases release>?)))
 309
 310 (define (releases project)
 311   "Return the list of releases of PROJECT as a list of release name/directory
 312 pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
 313   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 314   (let-values (((server directory) (ftp-server/directory project)))
 315     (define conn (ftp-open server))
 316
 317     (let loop ((directories (list directory))
 318                (result      '()))
 319       (match directories
 320         (()
 321          (ftp-close conn)
 322          (coalesce-releases result))
 323         ((directory rest ...)
 324          (let* ((files   (ftp-list conn directory))
 325                 (subdirs (filter-map (match-lambda
 326                                       ((name 'directory . _) name)
 327                                       (_ #f))
 328                                      files)))
 329            (loop (append (map (cut string-append directory "/" <>)
 330                               subdirs)
 331                          rest)
 332                  (append
 333                   ;; Filter out signatures, deltas, and files which
 334                   ;; are potentially not releases of PROJECT--e.g.,
 335                   ;; in /gnu/guile, filter out guile-oops and
 336                   ;; guile-www; in mit-scheme, filter out binaries.
 337                   (filter-map (match-lambda
 338                                ((file 'file . _)
 339                                 (if (release-file? project file)
 340                                     (gnu-release
 341                                      (package project)
 342                                      (version (tarball->version file))
 343                                      (directory directory)
 344                                      (files (list file)))
 345                                     #f))
 346                                (_ #f))
 347                               files)
 348                   result))))))))
 349
 350 (define* (latest-release project
 351                          #:key (ftp-open ftp-open) (ftp-close ftp-close))
 352   "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f.  Use FTP-OPEN and FTP-CLOSE to
 353 open (resp. close) FTP connections; this can be useful to reuse connections."
 354   (define (latest a b)
 355     (if (version>? a b) a b))
 356
 357   (define (latest-release a b)
 358     (if (version>? (gnu-release-version a) (gnu-release-version b))
 359         a b))
 360
 361   (define contains-digit?
 362     (cut string-any char-set:digit <>))
 363
 364   (define patch-directory-name?
 365     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 366     (cut string-suffix? "patches" <>))
 367
 368   (let-values (((server directory) (ftp-server/directory project)))
 369     (define conn (ftp-open server))
 370
 371     (let loop ((directory directory)
 372                (result    #f))
 373       (let* ((entries (ftp-list conn directory))
 374
 375              ;; Filter out sub-directories that do not contain digits---e.g.,
 376              ;; /gnuzilla/lang and /gnupg/patches.
 377              (subdirs (filter-map (match-lambda
 378                                    (((? patch-directory-name? dir)
 379                                      'directory . _)
 380                                     #f)
 381                                    (((? contains-digit? dir) 'directory . _)
 382                                     dir)
 383                                    (_ #f))
 384                                   entries))
 385
 386              ;; Whether or not SUBDIRS is empty, compute the latest releases
 387              ;; for the current directory.  This is necessary for packages
 388              ;; such as 'sharutils' that have a sub-directory that contains
 389              ;; only an older release.
 390              (releases (filter-map (match-lambda
 391                                      ((file 'file . _)
 392                                       (and (release-file? project file)
 393                                            (gnu-release
 394                                             (package project)
 395                                             (version
 396                                              (tarball->version file))
 397                                             (directory directory)
 398                                             (files (list file)))))
 399                                      (_ #f))
 400                                    entries)))
 401
 402         ;; Assume that SUBDIRS correspond to versions, and jump into the
 403         ;; one with the highest version number.
 404         (let* ((release  (reduce latest-release #f
 405                                  (coalesce-releases releases)))
 406                (result   (if (and result release)
 407                              (latest-release release result)
 408                              (or release result)))
 409                (target   (reduce latest #f subdirs)))
 410           (if target
 411               (loop (string-append directory "/" target)
 412                     result)
 413               (begin
 414                 (ftp-close conn)
 415                 result)))))))
 416
 417 (define (gnu-release-archive-types release)
 418   "Return the available types of archives for RELEASE---a list of strings such
 419 as \"gz\" or \"xz\"."
 420   (map file-extension (gnu-release-files release)))
 421
 422 (define %package-name-rx
 423   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 424   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 425   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 426
 427 (define (gnu-package-name->name+version name+version)
 428   "Return the package name and version number extracted from NAME+VERSION."
 429   (let ((match (regexp-exec %package-name-rx name+version)))
 430     (if (not match)
 431         (values name+version #f)
 432         (values (match:substring match 1) (match:substring match 2)))))
 433
 434 \f
 435 ;;;
 436 ;;; Auto-update.
 437 ;;;
 438
 439 (define (package-update-path package)
 440   "Return an update path for PACKAGE, or #f if no update is needed."
 441   (and (gnu-package? package)
 442        (match (latest-release (package-name package))
 443          (($ <gnu-release> name version directory)
 444           (and (version>? version (package-version package))
 445                `(,version . ,directory)))
 446          (_ #f))))
 447
 448 (define* (download-tarball store project directory version
 449                            #:key (archive-type "gz")
 450                                  (key-download 'interactive))
 451   "Download PROJECT's tarball over FTP and check its OpenPGP signature.  On
 452 success, return the tarball file name.  KEY-DOWNLOAD specifies a download
 453 policy for missing OpenPGP keys; allowed values: 'interactive' (default),
 454 'always', and 'never'."
 455   (let* ((server  (ftp-server/directory project))
 456          (base    (string-append project "-" version ".tar." archive-type))
 457          (url     (string-append "ftp://" server "/" directory "/" base))
 458          (sig-url (string-append url ".sig"))
 459          (tarball (download-to-store store url))
 460          (sig     (download-to-store store sig-url)))
 461     (let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
 462       (if ret
 463           tarball
 464           (begin
 465             (warning (_ "signature verification failed for `~a'~%")
 466                      base)
 467             (warning (_ "(could be because the public key is not in your keyring)~%"))
 468             #f)))))
 469
 470 (define* (package-update store package #:key (key-download 'interactive))
 471   "Return the new version and the file name of the new version tarball for
 472 PACKAGE, or #f and #f when PACKAGE is up-to-date.  KEY-DOWNLOAD specifies a
 473 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
 474 and 'interactive' (default)."
 475   (match (package-update-path package)
 476     ((version . directory)
 477      (let-values (((name)
 478                    (package-name package))
 479                   ((archive-type)
 480                    (let ((source (package-source package)))
 481                      (or (and (origin? source)
 482                               (file-extension (origin-uri source)))
 483                          "gz"))))
 484        (let ((tarball (download-tarball store name directory version
 485                                         #:archive-type archive-type
 486                                         #:key-download key-download)))
 487          (values version tarball))))
 488     (_
 489      (values #f #f))))
 490
 491 (define (update-package-source package version hash)
 492   "Modify the source file that defines PACKAGE to refer to VERSION,
 493 whose tarball has SHA256 HASH (a bytevector).  Return the new version string
 494 if an update was made, and #f otherwise."
 495   (define (new-line line matches replacement)
 496     ;; Iterate over MATCHES and return the modified line based on LINE.
 497     ;; Replace each match with REPLACEMENT.
 498     (let loop ((m* matches)                       ; matches
 499                (o  0)                             ; offset in L
 500                (r  '()))                          ; result
 501       (match m*
 502         (()
 503          (let ((r (cons (substring line o) r)))
 504            (string-concatenate-reverse r)))
 505         ((m . rest)
 506          (loop rest
 507                (match:end m)
 508                (cons* replacement
 509                       (substring line o (match:start m))
 510                       r))))))
 511
 512   (define (update-source file old-version version
 513                          old-hash hash)
 514     ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
 515     ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
 516
 517     ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
 518     ;; different unrelated places, we may modify it more than needed, for
 519     ;; instance.  We should try to make changes only within the sexp that
 520     ;; corresponds to the definition of PACKAGE.
 521     (let ((old-hash (bytevector->nix-base32-string old-hash))
 522           (hash     (bytevector->nix-base32-string hash)))
 523       (substitute file
 524                   `((,(regexp-quote old-version)
 525                      . ,(cut new-line <> <> version))
 526                     (,(regexp-quote old-hash)
 527                      . ,(cut new-line <> <> hash))))
 528       version))
 529
 530   (let ((name (package-name package))
 531         (loc  (package-field-location package 'version)))
 532     (if loc
 533         (let ((old-version (package-version package))
 534               (old-hash    (origin-sha256 (package-source package)))
 535               (file        (and=> (location-file loc)
 536                                   (cut search-path %load-path <>))))
 537           (if file
 538               (update-source file
 539                              old-version version
 540                              old-hash hash)
 541               (begin
 542                 (warning (_ "~a: could not locate source file")
 543                          (location-file loc))
 544                 #f)))
 545         (begin
 546           (format (current-error-port)
 547                   (_ "~a: ~a: no `version' field in source; skipping~%")
 548                   (location->string (package-location package))
 549                   name)))))
 550
 551 ;;; gnu-maintenance.scm ends here