diff options
| -rw-r--r-- | guix/gnu-maintenance.scm | 138 |
1 files changed, 136 insertions, 2 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 87ef427481..c934694147 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,10 +22,28 @@ #:use-module (web client) #:use-module (web response) #:use-module (ice-9 regex) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:export (official-gnu-packages)) + #:use-module (system foreign) + #:use-module (guix ftp-client) + #:export (official-gnu-packages + releases + latest-release + gnu-package-name->name+version)) + +;;; Commentary: +;;; +;;; Code for dealing with the maintenance of GNU packages, such as +;;; auto-updates. +;;; +;;; Code: + + +;;; +;;; List of GNU packages. +;;; (define (http-fetch uri) "Return a string containing the textual data at URI, a string." @@ -55,3 +73,119 @@ (and=> (regexp-exec %package-line-rx line) (cut match:substring <> 1))) lst))) + +;;; +;;; Latest release. +;;; + +(define (ftp-server/directory project) + "Return the FTP server and directory where PROJECT's tarball are +stored." + (define quirks + '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp") + ("ucommon" "ftp.gnu.org" "/gnu/commoncpp") + ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp") + ("libosip2" "ftp.gnu.org" "/gnu/osip") + ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt") + ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error") + ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan") + ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg") + ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont") + ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript") + ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") + ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") + ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") + ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) + + (match (assoc project quirks) + ((_ server directory) + (values server directory)) + (_ + (values "ftp.gnu.org" (string-append "/gnu/" project))))) + +(define (releases project) + "Return the list of releases of PROJECT as a list of release name/directory +pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). " + ;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp. + (define release-rx + (make-regexp (string-append "^" project + "-([0-9]|[^-])*(-src)?\\.tar\\."))) + + (define alpha-rx + (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) + + (define (sans-extension tarball) + (let ((end (string-contains tarball ".tar"))) + (substring tarball 0 end))) + + (let-values (((server directory) (ftp-server/directory project))) + (define conn (ftp-open server)) + + (let loop ((directories (list directory)) + (result '())) + (if (null? directories) + (begin + (ftp-close conn) + result) + (let* ((directory (car directories)) + (files (ftp-list conn directory)) + (subdirs (filter-map (lambda (file) + (match file + ((name 'directory . _) name) + (_ #f))) + files))) + (loop (append (map (cut string-append directory "/" <>) + subdirs) + (cdr directories)) + (append + ;; Filter out signatures, deltas, and files which + ;; are potentially not releases of PROJECT--e.g., + ;; in /gnu/guile, filter out guile-oops and + ;; guile-www; in mit-scheme, filter out binaries. + (filter-map (lambda (file) + (match file + ((file 'file . _) + (and (not (string-suffix? ".sig" file)) + (regexp-exec release-rx file) + (not (regexp-exec alpha-rx file)) + (let ((s (sans-extension file))) + (and (regexp-exec + %package-name-rx s) + (cons s directory))))) + (_ #f))) + files) + result))))))) + +(define version-string>? + (let ((strverscmp + (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) + (error "could not find `strverscmp' (from GNU libc)")))) + (pointer->procedure int sym (list '* '*))))) + (lambda (a b) + "Return #t when B denotes a newer version than A." + (> (strverscmp (string->pointer a) (string->pointer b)) 0)))) + +(define (latest-release project) + "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." + (let ((releases (releases project))) + (and (not (null? releases)) + (fold (lambda (release latest) + (if (version-string>? (car release) (car latest)) + release + latest)) + '("" . "") + releases)))) + +(define %package-name-rx + ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses + ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. + (make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?")) + +(define (gnu-package-name->name+version name+version) + "Return the package name and version number extracted from NAME+VERSION." + (let ((match (regexp-exec %package-name-rx name+version))) + (if (not match) + (values name+version #f) + (values (match:substring match 1) (match:substring match 2))))) + +;;; gnu-maintenance.scm ends here |