From 548a5e85ec75678334c2ecbe34cccdb226dbc5a9 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov 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. (): Add it. (official-gnu-packages): Use . (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 ;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; ;;; 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 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