summaryrefslogtreecommitdiff
path: root/guix/gnu-maintenance.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-24 23:48:36 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-25 00:13:56 +0200
commit0fdd3bea58a872f2734c7d8747d7dbdd108d97d8 (patch)
tree368a1a86567c24d201c312efa2198b9d9246b9aa /guix/gnu-maintenance.scm
parentf903dc056a5176033daca7a69d5b2c8376ff0677 (diff)
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.
Diffstat (limited to 'guix/gnu-maintenance.scm')
-rw-r--r--guix/gnu-maintenance.scm124
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