guix/gnu-maintenance.scm

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