guix/gnu-maintenance.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2010, 2011, 2012, 2013, 2014 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             releases
  60             latest-release
  61             gnu-package-name->name+version
  62             package-update-path
  63             package-update
  64             update-package-source))
  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*/gnumaint/")
  80
  81 (define %package-list-url
  82   (string->uri
  83    (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
  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?root=womb")))
  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   "Return a list of records, which are GNU packages."
 112   (define (read-records port)
 113     ;; Return a list of alists.  Each alist contains fields of a GNU
 114     ;; package.
 115     (let loop ((alist  (recutils->alist port))
 116                (result '()))
 117       (if (null? alist)
 118           (reverse result)
 119           (loop (recutils->alist port)
 120                 (cons alist result)))))
 121
 122   (define official-description
 123     (let ((db (read-records (http-fetch %package-description-url
 124                                         #:text? #t))))
 125       (lambda (name)
 126         ;; Return the description found upstream for package NAME, or #f.
 127         (and=> (find (lambda (alist)
 128                        (equal? name (assoc-ref alist "package")))
 129                      db)
 130                (lambda (record)
 131                  (let ((field (assoc-ref record "blurb")))
 132                    ;; The upstream description file uses "redirect PACKAGE" as
 133                    ;; a blurb in cases where the description of the two
 134                    ;; packages should be considered the same (e.g., GTK+ has
 135                    ;; "redirect gnome".)  This is usually not acceptable for
 136                    ;; us because we prefer to have distinct descriptions in
 137                    ;; such cases.  Thus, ignore the 'blurb' field when that
 138                    ;; happens.
 139                    (and field
 140                         (not (string-prefix? "redirect " field))
 141                         field)))))))
 142
 143   (map (lambda (alist)
 144          (let ((name (assoc-ref alist "package")))
 145            (alist->record `(("description" . ,(official-description name))
 146                             ,@alist)
 147                           make-gnu-package-descriptor
 148                           (list "package" "mundane-name" "copyright-holder"
 149                                 "savannah" "fsd" "language" "logo"
 150                                 "doc-category" "doc-summary" "description"
 151                                 "doc-url"
 152                                 "download-url")
 153                           '("doc-url" "language"))))
 154        (read-records (http-fetch %package-list-url #:text? #t))))
 155
 156 (define (find-packages regexp)
 157   "Find GNU packages which satisfy REGEXP."
 158   (let ((name-rx (make-regexp regexp)))
 159     (filter (lambda (package)
 160               (false-if-exception
 161                (regexp-exec name-rx (gnu-package-name package))))
 162             (official-gnu-packages))))
 163
 164 (define gnu-package?
 165   (memoize
 166    (let ((official-gnu-packages (memoize official-gnu-packages)))
 167      (lambda (package)
 168        "Return true if PACKAGE is a GNU package.  This procedure may access the
 169 network to check in GNU's database."
 170        ;; TODO: Find a way to determine that a package is non-GNU without going
 171        ;; through the network.
 172        (let ((url  (and=> (package-source package) origin-uri))
 173              (name (package-name package)))
 174          (or (and (string? url) (string-prefix? "mirror://gnu" url))
 175              (and (member name (map gnu-package-name (official-gnu-packages)))
 176                   #t)))))))
 177
 178 \f
 179 ;;;
 180 ;;; Latest release.
 181 ;;;
 182
 183 (define (ftp-server/directory project)
 184   "Return the FTP server and directory where PROJECT's tarball are
 185 stored."
 186   (define quirks
 187     '(("commoncpp2"   "ftp.gnu.org"   "/gnu/commoncpp")
 188       ("ucommon"      "ftp.gnu.org"   "/gnu/commoncpp")
 189       ("libzrtpcpp"   "ftp.gnu.org"   "/gnu/ccrtp")
 190       ("libosip2"     "ftp.gnu.org"   "/gnu/osip")
 191       ("libgcrypt"    "ftp.gnupg.org" "/gcrypt/libgcrypt")
 192       ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
 193       ("libassuan"    "ftp.gnupg.org" "/gcrypt/libassuan")
 194       ("gnupg"        "ftp.gnupg.org" "/gcrypt/gnupg")
 195       ("freefont-ttf" "ftp.gnu.org"   "/gnu/freefont")
 196       ("gnu-ghostscript" "ftp.gnu.org"  "/gnu/ghostscript")
 197       ("mit-scheme"   "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
 198       ("icecat"       "ftp.gnu.org" "/gnu/gnuzilla")
 199       ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
 200       ("glib"         "ftp.gnome.org" "/pub/gnome/sources/glib")
 201       ("gnutls"       "ftp.gnutls.org" "/gcrypt/gnutls")
 202       ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))
 203
 204   (match (assoc project quirks)
 205     ((_ server directory)
 206      (values server directory))
 207     (_
 208      (values "ftp.gnu.org" (string-append "/gnu/" project)))))
 209
 210 (define (sans-extension tarball)
 211   "Return TARBALL without its .tar.* extension."
 212   (let ((end (string-contains tarball ".tar")))
 213     (substring tarball 0 end)))
 214
 215 (define %tarball-rx
 216   (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\."))
 217
 218 (define %alpha-tarball-rx
 219   (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 220
 221 (define (release-file project file)
 222   "Return #f if FILE is not a release tarball of PROJECT, otherwise return
 223 PACKAGE-VERSION."
 224   (and (not (string-suffix? ".sig" file))
 225        (and=> (regexp-exec %tarball-rx file)
 226               (lambda (match)
 227                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
 228                 (equal? project (match:substring match 1))))
 229        (not (regexp-exec %alpha-tarball-rx file))
 230        (let ((s (sans-extension file)))
 231          (and (regexp-exec %package-name-rx s) s))))
 232
 233 (define (releases project)
 234   "Return the list of releases of PROJECT as a list of release name/directory
 235 pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
 236   ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
 237   (let-values (((server directory) (ftp-server/directory project)))
 238     (define conn (ftp-open server))
 239
 240     (let loop ((directories (list directory))
 241                (result      '()))
 242       (match directories
 243         (()
 244          (ftp-close conn)
 245          result)
 246         ((directory rest ...)
 247          (let* ((files   (ftp-list conn directory))
 248                 (subdirs (filter-map (match-lambda
 249                                       ((name 'directory . _) name)
 250                                       (_ #f))
 251                                      files)))
 252            (loop (append (map (cut string-append directory "/" <>)
 253                               subdirs)
 254                          rest)
 255                  (append
 256                   ;; Filter out signatures, deltas, and files which
 257                   ;; are potentially not releases of PROJECT--e.g.,
 258                   ;; in /gnu/guile, filter out guile-oops and
 259                   ;; guile-www; in mit-scheme, filter out binaries.
 260                   (filter-map (match-lambda
 261                                 ((file 'file . _)
 262                                  (and=> (release-file project file)
 263                                         (cut cons <> directory)))
 264                                 (_ #f))
 265                               files)
 266                   result))))))))
 267
 268 (define* (latest-release project
 269                          #:key (ftp-open ftp-open) (ftp-close ftp-close))
 270   "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f.  Use FTP-OPEN and FTP-CLOSE to
 271 open (resp. close) FTP connections; this can be useful to reuse connections."
 272   (define (latest a b)
 273     (if (version>? a b) a b))
 274
 275   (define contains-digit?
 276     (cut string-any char-set:digit <>))
 277
 278   (define patch-directory-name?
 279     ;; Return #t for patch directory names such as 'bash-4.2-patches'.
 280     (cut string-suffix? "patches" <>))
 281
 282   (let-values (((server directory) (ftp-server/directory project)))
 283     (define conn (ftp-open server))
 284
 285     (let loop ((directory directory))
 286       (let* ((entries (ftp-list conn directory))
 287
 288              ;; Filter out sub-directories that do not contain digits---e.g.,
 289              ;; /gnuzilla/lang and /gnupg/patches.
 290              (subdirs (filter-map (match-lambda
 291                                    (((? patch-directory-name? dir)
 292                                      'directory . _)
 293                                     #f)
 294                                    (((? contains-digit? dir) 'directory . _)
 295                                     dir)
 296                                    (_ #f))
 297                                   entries)))
 298         (match subdirs
 299           (()
 300            ;; No sub-directories, so assume that tarballs are here.
 301            (let ((files (filter-map (match-lambda
 302                                      ((file 'file . _)
 303                                       (release-file project file))
 304                                      (_ #f))
 305                                     entries)))
 306              (ftp-close conn)
 307              (and=> (reduce latest #f files)
 308                     (cut cons <> directory))))
 309           ((subdirs ...)
 310            ;; Assume that SUBDIRS correspond to versions, and jump into the
 311            ;; one with the highest version number.
 312            (let ((target (reduce latest #f subdirs)))
 313              (if target
 314                  (loop (string-append directory "/" target))
 315                  (begin
 316                    (ftp-close conn)
 317                    #f)))))))))
 318
 319 (define %package-name-rx
 320   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
 321   ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
 322   (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
 323
 324 (define (gnu-package-name->name+version name+version)
 325   "Return the package name and version number extracted from NAME+VERSION."
 326   (let ((match (regexp-exec %package-name-rx name+version)))
 327     (if (not match)
 328         (values name+version #f)
 329         (values (match:substring match 1) (match:substring match 2)))))
 330
 331 \f
 332 ;;;
 333 ;;; Auto-update.
 334 ;;;
 335
 336 (define (package-update-path package)
 337   "Return an update path for PACKAGE, or #f if no update is needed."
 338   (and (gnu-package? package)
 339        (match (latest-release (package-name package))
 340          ((name+version . directory)
 341           (let-values (((_ new-version)
 342                         (package-name->name+version name+version)))
 343             (and (version>? name+version (package-full-name package))
 344                  `(,new-version . ,directory))))
 345          (_ #f))))
 346
 347 (define* (download-tarball store project directory version
 348                            #:key (archive-type "gz")
 349                                  (key-download 'interactive))
 350   "Download PROJECT's tarball over FTP and check its OpenPGP signature.  On
 351 success, return the tarball file name.  KEY-DOWNLOAD specifies a download
 352 policy for missing OpenPGP keys; allowed values: 'interactive' (default),
 353 'always', and 'never'."
 354   (let* ((server  (ftp-server/directory project))
 355          (base    (string-append project "-" version ".tar." archive-type))
 356          (url     (string-append "ftp://" server "/" directory "/" base))
 357          (sig-url (string-append url ".sig"))
 358          (tarball (download-to-store store url))
 359          (sig     (download-to-store store sig-url)))
 360     (let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
 361       (if ret
 362           tarball
 363           (begin
 364             (warning (_ "signature verification failed for `~a'~%")
 365                      base)
 366             (warning (_ "(could be because the public key is not in your keyring)~%"))
 367             #f)))))
 368
 369 (define* (package-update store package #:key (key-download 'interactive))
 370   "Return the new version and the file name of the new version tarball for
 371 PACKAGE, or #f and #f when PACKAGE is up-to-date.  KEY-DOWNLOAD specifies a
 372 download policy for missing OpenPGP keys; allowed values: 'always', 'never',
 373 and 'interactive' (default)."
 374   (match (package-update-path package)
 375     ((version . directory)
 376      (let-values (((name)
 377                    (package-name package))
 378                   ((archive-type)
 379                    (let ((source (package-source package)))
 380                      (or (and (origin? source)
 381                               (file-extension (origin-uri source)))
 382                          "gz"))))
 383        (let ((tarball (download-tarball store name directory version
 384                                         #:archive-type archive-type
 385                                         #:key-download key-download)))
 386          (values version tarball))))
 387     (_
 388      (values #f #f))))
 389
 390 (define (update-package-source package version hash)
 391   "Modify the source file that defines PACKAGE to refer to VERSION,
 392 whose tarball has SHA256 HASH (a bytevector).  Return the new version string
 393 if an update was made, and #f otherwise."
 394   (define (new-line line matches replacement)
 395     ;; Iterate over MATCHES and return the modified line based on LINE.
 396     ;; Replace each match with REPLACEMENT.
 397     (let loop ((m* matches)                       ; matches
 398                (o  0)                             ; offset in L
 399                (r  '()))                          ; result
 400       (match m*
 401         (()
 402          (let ((r (cons (substring line o) r)))
 403            (string-concatenate-reverse r)))
 404         ((m . rest)
 405          (loop rest
 406                (match:end m)
 407                (cons* replacement
 408                       (substring line o (match:start m))
 409                       r))))))
 410
 411   (define (update-source file old-version version
 412                          old-hash hash)
 413     ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
 414     ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
 415
 416     ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
 417     ;; different unrelated places, we may modify it more than needed, for
 418     ;; instance.  We should try to make changes only within the sexp that
 419     ;; corresponds to the definition of PACKAGE.
 420     (let ((old-hash (bytevector->nix-base32-string old-hash))
 421           (hash     (bytevector->nix-base32-string hash)))
 422       (substitute file
 423                   `((,(regexp-quote old-version)
 424                      . ,(cut new-line <> <> version))
 425                     (,(regexp-quote old-hash)
 426                      . ,(cut new-line <> <> hash))))
 427       version))
 428
 429   (let ((name (package-name package))
 430         (loc  (package-field-location package 'version)))
 431     (if loc
 432         (let ((old-version (package-version package))
 433               (old-hash    (origin-sha256 (package-source package)))
 434               (file        (and=> (location-file loc)
 435                                   (cut search-path %load-path <>))))
 436           (if file
 437               (update-source file
 438                              old-version version
 439                              old-hash hash)
 440               (begin
 441                 (warning (_ "~a: could not locate source file")
 442                          (location-file loc))
 443                 #f)))
 444         (begin
 445           (format (current-error-port)
 446                   (_ "~a: ~a: no `version' field in source; skipping~%")
 447                   (location->string (package-location package))
 448                   name)))))
 449
 450 ;;; gnu-maintenance.scm ends here