diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89a0174..3baa460 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,119 @@
(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 the list of records, which are GNU packages."
+ (define (group-package-fields port state)
+ (let ((line (read-line port)))
+ (define (match-field str)
+ (define empty-descriptor
+ (gnu-package-descriptor (name #f)
+ (mundane-name #f)
+ (copyright-holder #f)
+ (savannah #f)
+ (fsd #f)
+ (language #f)
+ (logo #f)
+ (doc-category #f)
+ (doc-summary #f)
+ (doc-url #f)
+ (download-url #f)
+ (gplv3-status #f)
+ (activity-status #f)
+ (last-contact #f)
+ (next-contact #f)
+ (note #f)))
+
+ (define field-setter-alist
+ (list (list "package" 'name)
+ (list "mundane-name" 'mundane-name)
+ (list "copyright-holder" 'copyright-holder)
+ (list "savannah" 'savannah)
+ (list "fsd" 'fsd)
+ (list "language" 'language)
+ (list "logo" 'logo)
+ (list "doc-category" 'doc-category)
+ (list "doc-summary" 'doc-summary)
+ (list "doc-url" 'doc-url)
+ (list "doc-category" 'doc-category)
+ (list "download-url" 'download-url)
+ (list "gplv3-status" 'gplv3-status)
+ (list "activity-status" 'activity-status)
+ (list "last-contact" 'last-contact)
+ (list "next-contact" 'next-contact)
+ (list "note" 'note)))
+
+ (define (find-setter str)
+ "Find the right setter for STR."
+ (define (field-prefix? lst str)
+ ;; Find the field which is a prefix of STR.
+ (false-if-exception (string-prefix? (first lst) str)))
+
+ (and=> (find (cut field-prefix? <> str) field-setter-alist)
+ last))
+
+ (match str
+ (""
+ (group-package-fields port (cons empty-descriptor state)))
+ (str
+ (group-package-fields
+ port
+ (cons (gnu-package-descriptor
+ (inherit (first state))
+ ((eval (match-field str)
+ (interaction-environment)) str))
+ (drop state 1))))))
+
+ (if (eof-object? line)
+ (remove null-list? state)
+ (match-field line))))
- (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)))
+ ;; XXX: 'reverse'?
+ (group-package-fields (http-fetch* %package-list-url)
+ '(())))
+;;; XXX: FIXME!
(define gnu-package?
(memoize
(lambda (package)