gnu-maintenance: Add `latest-release' and related tools.
* guix/gnu-maintenance.scm (ftp-server/directory, releases, version-string>?, latest-release, gnu-package-name->name+version): New procedures. (%package-name-rx): New variable.
This commit is contained in:
Ludovic Courtès
parent
87009d8aa1
commit
98fefb210a
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue