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)