> Yes please, that would be better. I apologize for the delay. What do you think about the attached patch?
I noticed that 'guile-gnome' has two 'doc-url' fields. How can I handle
this? (I ignored it for now.)
Also, is there a better way to create 'gnu-package-descriptor'? Note
that I don't want to use setters.
For example, it should be possible to match a list of regexps against a
list of fields. But I haven't found a way to do so because some fields
are optional and I also don't want to rely on their order.
> This code is run by the user’s Guile, which may be older than 2.0.7
> (‘http-get*’ was introduced in 2.0.7), so you can’t rely on it.
> What you can do is something along the lines of what (guix build
> download) does, but always return a port. Maybe there’s a way to share
> code.
But how can I return a port with 'http-get'? ('http-fetch*' is a
temporary function.)
> I’d rather change ‘group-packages’ to ‘read-package-fields’ or something
> like that.
I changed it to 'group-package-fields' and added some comments.
> identity
(identity sublst) won't work.
If (regexp-exec package-line-rx (first sublst)) returns #t,
'and=>' will call 'identity' with the result of 'regexp-exec'. But it
should return 'sublst' instead.
I also changed 'gnu-package?'. Please test.
From 548a5e85ec75678334c2ecbe34cccdb226dbc5a9 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nik...@karetnikov.org>
Date: Sat, 16 Mar 2013 18:33:07 +0000
Subject: [PATCH] gnu-maintenance: Improve 'official-gnu-packages'; add the
related procedures.
* guix/gnu-maintenance.scm (http-fetch*): Add it.
(<gnu-package-descriptor>): Add it.
(official-gnu-packages): Use <gnu-package-descriptor>.
(find-packages): Add it.
(gnu-package?): Adjust accordingly.
---
guix/gnu-maintenance.scm | 147 ++++++++++++++++++++++++++++++++++++++++++----
1 files changed, 136 insertions(+), 11 deletions(-)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 89a0174..ef91055 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 <nik...@karetnikov.org>
;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <l...@gnu.org>
+;;; Copyright © 2012, 2013 Nikita Karetnikov <nik...@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,7 +23,9 @@
#:use-module (web response)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (system foreign)
@@ -31,10 +33,27 @@
#:use-module (guix utils)
#:use-module (guix packages)
#:export (official-gnu-packages
+ find-packages
gnu-package?
releases
latest-release
- gnu-package-name->name+version))
+ gnu-package-name->name+version
+ get-gnu-package-name
+ get-gnu-package-mundane-name
+ get-gnu-package-copyright-holder
+ get-gnu-package-savannah
+ get-gnu-package-fsd
+ get-gnu-package-language
+ get-gnu-package-logo
+ get-gnu-package-doc-category
+ get-gnu-package-doc-summary
+ get-gnu-package-doc-url
+ get-gnu-package-download-url
+ get-gnu-package-gplv3-status
+ get-gnu-package-activity-status
+ get-gnu-package-last-contact
+ get-gnu-package-next-contact
+ get-gnu-package-note))
;;; Commentary:
;;;
@@ -74,21 +93,124 @@
(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>
+ (gnu-package-descriptor 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)
+ gnu-package-descriptor?
+ (package get-gnu-package-name)
+ (mundane-name get-gnu-package-mundane-name)
+ (copyright-holder get-gnu-package-copyright-holder)
+ (savannah get-gnu-package-savannah)
+ (fsd get-gnu-package-fsd)
+ (language get-gnu-package-language)
+ (logo get-gnu-package-logo)
+ (doc-category get-gnu-package-doc-category)
+ (doc-summary get-gnu-package-doc-summary)
+ (doc-url get-gnu-package-doc-url)
+ (download-url get-gnu-package-download-url)
+ (gplv3-status get-gnu-package-gplv3-status)
+ (activity-status get-gnu-package-activity-status)
+ (last-contact get-gnu-package-last-contact)
+ (next-contact get-gnu-package-next-contact)
+ (note get-gnu-package-note))
+
(define (official-gnu-packages)
"Return a list of GNU packages."
- (define %package-line-rx
- (make-regexp "^package: (.+)$"))
+ (define (group-package-fields port state)
+ ;; Return a list of lists where /most/ inner lists are the GNU
+ ;; packages. Note that some lists are not packages at all; they
+ ;; contain additional information. So it is necessary to filter
+ ;; the output.
+ (let ((line (read-line port)))
+ (define (match-field str)
+ ;; Packages are separated by empty strings. Each package is
+ ;; represented as a list. If STR is an empty string, create a new
+ ;; list to store fields of a different package. Otherwise, add STR to
+ ;; the same list.
+ (match str
+ ('""
+ (group-package-fields port (cons '() state)))
+ (str
+ (group-package-fields port (cons (cons str (first state))
+ (drop state 1))))))
+
+ (if (eof-object? line)
+ (remove null-list? state)
+ (match-field line))))
+
+ (reverse (map reverse
+ (group-package-fields (http-fetch* %package-list-url)
+ '(())))))
+
+(define (find-packages regexp)
+ "Find packages that match REGEXP."
+ (define (create-gnu-package-descriptor package)
+ (define (field-rx field)
+ (make-regexp (format #f "^~a: (.+)" field)))
+
+ (define (match-field-rx field str)
+ (and=> (regexp-exec (field-rx field) str)
+ (cut match:substring <> 1)))
+
+ (gnu-package-descriptor
+ (any (cut match-field-rx "package" <>) package)
+ (any (cut match-field-rx "mundane-name" <>) package)
+ (any (cut match-field-rx "copyright-holder" <>) package)
+ (any (cut match-field-rx "savannah" <>) package)
+ (any (cut match-field-rx "fsd" <>) package)
+ (any (cut match-field-rx "language" <>) package)
+ (any (cut match-field-rx "logo" <>) package)
+ (any (cut match-field-rx "doc-category" <>) package)
+ (any (cut match-field-rx "doc-summary" <>) package)
+ (any (cut match-field-rx "doc-url" <>) package)
+ (any (cut match-field-rx "download-url" <>) package)
+ (any (cut match-field-rx "gplv3-status" <>) package)
+ (any (cut match-field-rx "activity-status" <>) package)
+ (any (cut match-field-rx "last-contact" <>) package)
+ (any (cut match-field-rx "next-contact" <>) package)
+ (any (cut match-field-rx "note" <>) package)))
+
+ (define (package-line-rx)
+ (make-regexp (string-append "^package: " regexp "(.?)")))
- (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)))
+ (map (cut create-gnu-package-descriptor <>)
+ (filter-map (lambda (sublst)
+ (and=> (regexp-exec (package-line-rx) (first sublst))
+ (lambda _
+ sublst)))
+ (official-gnu-packages))))
(define gnu-package?
(memoize
@@ -97,9 +219,12 @@
network to check in GNU's database."
;; TODO: Find a way to determine that a package is non-GNU without going
;; through the network.
- (let ((url (and=> (package-source package) origin-uri)))
+ (let ((url (and=> (package-source package) origin-uri))
+ (pname (package-name package)))
(or (and (string? url) (string-prefix? "mirror://gnu" url))
- (and (member (package-name package) (official-gnu-packages))
+ (and (member pname
+ (map (cut get-gnu-package-name <>)
+ (find-packages pname)))
#t))))))
--
1.7.5.4
pgpgqKAFH7PN9.pgp
Description: PGP signature
