diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89a0174..a0e9da5 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
;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès
+;;; Copyright © 2012, 2013 Nikita Karetnikov
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +23,7 @@
#:use-module (web response)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim) ; http-fetch*
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -74,22 +75,100 @@
(error "download failed:" uri code
(response-reason-phrase resp))))))
+(define (http-fetch* uri)
+ "Return an input port with the textual data at URI, a string."
+ (let*-values (((resp port)
+ (http-get* (string->uri uri)))
+ ((code)
+ (response-code resp)))
+ (case code
+ ((200)
+ port)
+ (else
+ (error "download failed" uri code
+ (response-reason-phrase resp))))))
+
(define %package-list-url
(string-append "http://cvs.savannah.gnu.org/"
"viewvc/*checkout*/gnumaint/"
"gnupackages.txt?root=womb"))
+(define-record-type*
+ gnu-package-descriptor
+ make-gnu-package-descriptor
+
+ gnu-package-descriptor?
+
+ (name gnu-package-name)
+ (mundane-name gnu-package-mundane-name)
+ (copyright-holder gnu-package-copyright-holder)
+ (savannah gnu-package-savannah)
+ (fsd gnu-package-fsd)
+ (language gnu-package-language)
+ (logo gnu-package-logo)
+ (doc-category gnu-package-doc-category)
+ (doc-summary gnu-package-doc-summary)
+ (doc-url gnu-package-doc-url)
+ (download-url gnu-package-download-url)
+ (gplv3-status gnu-package-gplv3-status)
+ (activity-status gnu-package-activity-status)
+ (last-contact gnu-package-last-contact)
+ (next-contact gnu-package-next-contact)
+ (note gnu-package-note))
+
(define (official-gnu-packages)
- "Return a list of GNU packages."
- (define %package-line-rx
- (make-regexp "^package: (.+)$"))
+ "Return a list of records, which are GNU packages."
+ (define (group-package-fields port state)
+ ;; Return a list of alists. Each alist contains fields of a GNU
+ ;; package.
+ (let ((line (read-line port))
+ (field-rx (make-regexp "^([[:graph:]]+): (.*)$"))
+ (end-rx (make-regexp "^# End. .+Do not remove this line.+")))
+
+ (define (match-field str)
+ ;; Packages are separated by empty strings. If STR is an
+ ;; empty string, create a new list to store fields of a
+ ;; different package. Otherwise, match and create a key-value
+ ;; pair.
+ (match str
+ (""
+ (group-package-fields port (cons '() state)))
+ (str
+ (cond ((regexp-exec field-rx str)
+ =>
+ (lambda (match)
+ (group-package-fields
+ port (cons (cons (cons (match:substring match 1)
+ (match:substring match 2))
+ (first state))
+ (drop state 1)))))
+ (else (group-package-fields port state))))))
+
+ (if (or (eof-object? line)
+ (regexp-exec end-rx line)) ; don't include dummy fields
+ (remove null-list? state)
+ (match-field line))))
+
+ (define (alist->record alist make keys)
+ ;; Apply MAKE, which should be a syntactic constructor, to the
+ ;; values associated with KEYS in ALIST.
+ (let ((args (map (cut assoc-ref alist <>) keys)))
+ (apply make args)))
- (let ((lst (string-split (http-fetch %package-list-url) #\nl)))
- (filter-map (lambda (line)
- (and=> (regexp-exec %package-line-rx line)
- (cut match:substring <> 1)))
- lst)))
+ (reverse
+ (map (lambda (alist)
+ (alist->record alist
+ make-gnu-package-descriptor
+ (list "package" "mundane-name" "copyright-holder"
+ "savannah" "fsd" "language" "logo"
+ "doc-category" "doc-summary" "doc-url"
+ "download-url" "gplv3-status"
+ "activity-status" "last-contact" "next-contact"
+ "note")))
+ (group-package-fields (http-fetch* %package-list-url)
+ '(())))))
+;;; XXX: FIXME!
(define gnu-package?
(memoize
(lambda (package)