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.

1 files changed, 123 insertions, 1 deletions

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