Add `guix refresh' and related auto-update tools.

* guix/gnu-maintenance.scm (ftp-server/directory)[quirks]: Add glib.
  (package-update-path, download-tarball, package-update,
  update-package-source): New procedures.
* guix/gnupg.scm, guix/scripts/refresh.scm: New files.
* Makefile.am (MODULES): Add them.
* guix/utils.scm (file-extension): New procedure.

5 files changed, 420 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index d1ae126f80..442e53e7f6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -33,6 +33,7 @@ MODULES =					\
   guix/scripts/hash.scm				\
   guix/scripts/pull.scm				\
   guix/scripts/substitute-binary.scm		\
+  guix/scripts/refresh.scm			\
   guix/base32.scm				\
   guix/utils.scm				\
   guix/serialization.scm			\
@@ -47,6 +48,7 @@ MODULES =					\
   guix/build-system/perl.scm			\
   guix/build-system/trivial.scm			\
   guix/ftp-client.scm				\
+  guix/gnupg.scm				\
   guix/store.scm				\
   guix/ui.scm					\
   guix/build/download.scm			\
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 0dc2fab092..619cb3106a 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -32,6 +32,12 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix packages)
+  #:use-module ((guix download) #:select (download-to-store))
+  #:use-module (guix gnupg)
+  #:use-module (rnrs io ports)
+  #:use-module (guix base32)
+  #:use-module ((guix build utils)
+                #:select (substitute))
   #:export (gnu-package-name
             gnu-package-mundane-name
             gnu-package-copyright-holder
@@ -50,7 +56,10 @@
 
             releases
             latest-release
-            gnu-package-name->name+version))
+            gnu-package-name->name+version
+            package-update-path
+            package-update
+            update-package-source))
 
 ;;; Commentary:
 ;;;
@@ -234,6 +243,7 @@ stored."
       ("mit-scheme"   "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
       ("icecat"       "ftp.gnu.org" "/gnu/gnuzilla")
       ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
+      ("glib"         "ftp.gnome.org" "/pub/gnome/sources/glib")
       ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))
 
   (match (assoc project quirks)
@@ -320,4 +330,116 @@ pairs.  Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
         (values name+version #f)
         (values (match:substring match 1) (match:substring match 2)))))
 
+
+;;;
+;;; Auto-update.
+;;;
+
+(define (package-update-path package)
+  "Return an update path for PACKAGE, or #f if no update is needed."
+  (and (gnu-package? package)
+       (match (latest-release (package-name package))
+         ((name+version . directory)
+          (let-values (((_ new-version)
+                        (package-name->name+version name+version)))
+            (and (version>? name+version (package-full-name package))
+                 `(,new-version . ,directory))))
+         (_ #f))))
+
+(define* (download-tarball store project directory version
+                           #:optional (archive-type "gz"))
+  "Download PROJECT's tarball over FTP and check its OpenPGP signature.  On
+success, return the tarball file name."
+  (let* ((server  (ftp-server/directory project))
+         (base    (string-append project "-" version ".tar." archive-type))
+         (url     (string-append "ftp://" server "/" directory "/" base))
+         (sig-url (string-append url ".sig"))
+         (tarball (download-to-store store url))
+         (sig     (download-to-store store sig-url)))
+    (let ((ret (gnupg-verify* sig tarball)))
+      (if ret
+          tarball
+          (begin
+            (warning (_ "signature verification failed for `~a'")
+                     base)
+            (warning (_ "(could be because the public key is not in your keyring)"))
+            #f)))))
+
+(define (package-update store package)
+  "Return the new version and the file name of the new version tarball for
+PACKAGE, or #f and #f when PACKAGE is up-to-date."
+  (match (package-update-path package)
+    ((version . directory)
+     (let-values (((name)
+                   (package-name package))
+                  ((archive-type)
+                   (let ((source (package-source package)))
+                     (or (and (origin? source)
+                              (file-extension (origin-uri source)))
+                         "gz"))))
+       (let ((tarball (download-tarball store name directory version
+                                        archive-type)))
+         (values version tarball))))
+    (_
+     (values #f #f))))
+
+(define (update-package-source package version hash)
+  "Modify the source file that defines PACKAGE to refer to VERSION,
+whose tarball has SHA256 HASH (a bytevector).  Return the new version string
+if an update was made, and #f otherwise."
+  (define (new-line line matches replacement)
+    ;; Iterate over MATCHES and return the modified line based on LINE.
+    ;; Replace each match with REPLACEMENT.
+    (let loop ((m* matches)                       ; matches
+               (o  0)                             ; offset in L
+               (r  '()))                          ; result
+      (match m*
+        (()
+         (let ((r (cons (substring line o) r)))
+           (string-concatenate-reverse r)))
+        ((m . rest)
+         (loop rest
+               (match:end m)
+               (cons* replacement
+                      (substring line o (match:start m))
+                      r))))))
+
+  (define (update-source file old-version version
+                         old-hash hash)
+    ;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
+    ;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
+
+    ;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
+    ;; different unrelated places, we may modify it more than needed, for
+    ;; instance.  We should try to make changes only within the sexp that
+    ;; corresponds to the definition of PACKAGE.
+    (let ((old-hash (bytevector->nix-base32-string old-hash))
+          (hash     (bytevector->nix-base32-string hash)))
+      (substitute file
+                  `((,(regexp-quote old-version)
+                     . ,(cut new-line <> <> version))
+                    (,(regexp-quote old-hash)
+                     . ,(cut new-line <> <> hash))))
+      version))
+
+  (let ((name (package-name package))
+        (loc  (package-field-location package 'version)))
+    (if loc
+        (let ((old-version (package-version package))
+              (old-hash    (origin-sha256 (package-source package)))
+              (file        (and=> (location-file loc)
+                                  (cut search-path %load-path <>))))
+          (if file
+              (update-source file
+                             old-version version
+                             old-hash hash)
+              (begin
+                (warning (_ "~a: could not locate source file")
+                         (location-file loc))
+                #f)))
+        (begin
+          (format (current-error-port)
+                  (_ "~a: ~a: no `version' field in source; skipping~%")
+                  name (package-location package))))))
+
 ;;; gnu-maintenance.scm ends here
diff --git a/guix/gnupg.scm b/guix/gnupg.scm
new file mode 100644
index 0000000000..ee67bea91b
--- /dev/null
+++ b/guix/gnupg.scm
@@ -0,0 +1,152 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2010, 2011, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix gnupg)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:export (gnupg-verify
+            gnupg-verify*
+            gnupg-status-good-signature?
+            gnupg-status-missing-key?))
+
+;;; Commentary:
+;;;
+;;; GnuPG interface.
+;;;
+;;; Code:
+
+(define %gpg-command "gpg2")
+(define %openpgp-key-server "keys.gnupg.net")
+
+(define (gnupg-verify sig file)
+  "Verify signature SIG for FILE.  Return a status s-exp if GnuPG failed."
+
+  (define (status-line->sexp line)
+    ;; See file `doc/DETAILS' in GnuPG.
+    (define sigid-rx
+      (make-regexp
+       "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)"))
+    (define goodsig-rx
+      (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$"))
+    (define validsig-rx
+      (make-regexp
+       "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$"))
+    (define expkeysig-rx                    ; good signature, but expired key
+      (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$"))
+    (define errsig-rx
+      (make-regexp
+       "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)"))
+
+    (cond ((regexp-exec sigid-rx line)
+           =>
+           (lambda (match)
+             `(signature-id ,(match:substring match 1) ; sig id
+                            ,(match:substring match 2) ; date
+                            ,(string->number           ; timestamp
+                              (match:substring match 3)))))
+          ((regexp-exec goodsig-rx line)
+           =>
+           (lambda (match)
+             `(good-signature ,(match:substring match 1)    ; key id
+                              ,(match:substring match 2)))) ; user name
+          ((regexp-exec validsig-rx line)
+           =>
+           (lambda (match)
+             `(valid-signature ,(match:substring match 1) ; fingerprint
+                               ,(match:substring match 2) ; sig creation date
+                               ,(string->number           ; timestamp
+                                 (match:substring match 3)))))
+          ((regexp-exec expkeysig-rx line)
+           =>
+           (lambda (match)
+             `(expired-key-signature ,(match:substring match 1) ; fingerprint
+                                     ,(match:substring match 2)))) ; user name
+          ((regexp-exec errsig-rx line)
+           =>
+           (lambda (match)
+             `(signature-error ,(match:substring match 1) ; key id or fingerprint
+                               ,(match:substring match 2) ; pubkey algo
+                               ,(match:substring match 3) ; hash algo
+                               ,(match:substring match 4) ; sig class
+                               ,(string->number           ; timestamp
+                                 (match:substring match 5))
+                               ,(let ((rc
+                                       (string->number ; return code
+                                        (match:substring match 6))))
+                                  (case rc
+                                    ((9) 'missing-key)
+                                    ((4) 'unknown-algorithm)
+                                    (else rc))))))
+          (else
+           `(unparsed-line ,line))))
+
+  (define (parse-status input)
+    (let loop ((line   (read-line input))
+               (result '()))
+      (if (eof-object? line)
+          (reverse result)
+          (loop (read-line input)
+                (cons (status-line->sexp line) result)))))
+
+  (let* ((pipe   (open-pipe* OPEN_READ %gpg-command "--status-fd=1"
+                             "--verify" sig file))
+         (status (parse-status pipe)))
+    ;; Ignore PIPE's exit status since STATUS above should contain all the
+    ;; info we need.
+    (close-pipe pipe)
+    status))
+
+(define (gnupg-status-good-signature? status)
+  "If STATUS, as returned by `gnupg-verify', denotes a good signature, return
+a key-id/user pair; return #f otherwise."
+  (any (lambda (sexp)
+         (match sexp
+           (((or 'good-signature 'expired-key-signature) key-id user)
+            (cons key-id user))
+           (_ #f)))
+       status))
+
+(define (gnupg-status-missing-key? status)
+  "If STATUS denotes a missing-key error, then return the key-id of the
+missing key."
+  (any (lambda (sexp)
+         (match sexp
+           (('signature-error key-id _ ...)
+            key-id)
+           (_ #f)))
+       status))
+
+(define (gnupg-receive-keys key-id server)
+  (system* %gpg-command "--keyserver" server "--recv-keys" key-id))
+
+(define* (gnupg-verify* sig file #:optional (server %openpgp-key-server))
+  "Like `gnupg-verify', but try downloading the public key if it's missing.
+Return #t if the signature was good, #f otherwise."
+  (let ((status (gnupg-verify sig file)))
+    (or (gnupg-status-good-signature? status)
+        (let ((missing (gnupg-status-missing-key? status)))
+          (and missing
+               (begin
+                 ;; Download the missing key and try again.
+                 (gnupg-receive-keys missing server)
+                 (gnupg-status-good-signature? (gnupg-verify sig file))))))))
+
+;;; gnupg.scm ends here
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
new file mode 100644
index 0000000000..036da38a3f
--- /dev/null
+++ b/guix/scripts/refresh.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts refresh)
+  #:use-module (guix ui)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix gnu-maintenance)
+  #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (rnrs io ports)
+  #:export (guix-refresh))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  '())
+
+(define %options
+  ;; Specification of the command-line options.
+  (list (option '(#\n "dry-run") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'dry-run? #t result)))
+
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix refresh")))))
+
+(define (show-help)
+  (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
+Update package definitions to match the latest upstream version.\n"))
+  (display (_ "
+  -n, --dry-run          do not build the derivations"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-refresh . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold args %options
+               (lambda (opt name arg result)
+                 (leave (_ "~A: unrecognized option~%") name))
+               (lambda (arg result)
+                 (alist-cons 'argument arg result))
+               %default-options))
+
+  (let* ((opts     (parse-options))
+         (dry-run? (assoc-ref opts 'dry-run?))
+         (packages (match (concatenate
+                           (filter-map (match-lambda
+                                        (('argument . value)
+                                         (let ((p (find-packages-by-name value)))
+                                           (unless p
+                                             (leave (_ "~a: no package by that name")
+                                                    value))
+                                           p))
+                                        (_ #f))
+                                       opts))
+                     (()                          ; default to all packages
+                      ;; TODO: Keep only the newest of each package.
+                      (fold-packages cons '()))
+                     (some                        ; user-specified packages
+                      some))))
+   (with-error-handling
+     (if dry-run?
+         (for-each (lambda (package)
+                     (match (false-if-exception (package-update-path package))
+                       ((new-version . directory)
+                        (let ((loc (or (package-field-location package 'version)
+                                       (package-location package))))
+                          (format (current-error-port)
+                                  (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                  (location->string loc)
+                                  (package-name package) (package-version package)
+                                  new-version)))
+                       (_ #f)))
+                   packages)
+         (let ((store (open-connection)))
+           (for-each (lambda (package)
+                       (let-values (((version tarball)
+                                     (catch #t
+                                       (lambda ()
+                                         (package-update store package))
+                                       (lambda _
+                                         (values #f #f))))
+                                    ((loc)
+                                     (or (package-field-location package
+                                                                 'version)
+                                         (package-location package))))
+                         (when version
+                           (format (current-error-port)
+                                   (_ "~a: ~a: updating from version ~a to version ~a...~%")
+                                   (location->string loc) (package-name package)
+                                   (package-version package) version)
+                           (let ((hash (call-with-input-file tarball
+                                         (compose sha256 get-bytevector-all))))
+                             (update-package-source package version hash)))))
+                     packages))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index 4f399b95c3..3cbed2fd0f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -60,6 +60,7 @@
             version-compare
             version>?
             package-name->name+version
+            file-extension
             call-with-temporary-output-file
             fold2))
 
@@ -465,6 +466,11 @@ introduce the version part."
       ((head tail ...)
        (loop tail (cons head prefix))))))
 
+(define (file-extension file)
+  "Return the extension of FILE or #f if there is none."
+  (let ((dot (string-rindex file #\.)))
+    (and dot (substring file (+ 1 dot) (string-length file)))))
+
 (define (call-with-temporary-output-file proc)
   "Call PROC with a name of a temporary file and open output port to that
 file; close the file and delete it when leaving the dynamic extent of this