From fdbda64e75e31782a7f08ade46b1ea01a5fd06d3 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Thu, 28 Mar 2013 01:50:31 +0000 Subject: [PATCH] gnu-maintenance: Improve 'official-gnu-packages'; add related procedures. * guix/gnu-maintenance.scm (http-fetch): Return an input port. (): Add it. (official-gnu-packages): Use . (find-packages): Add it. (gnu-package?): Adjust accordingly. --- guix/gnu-maintenance.scm | 161 +++++++++++++++++++++++++++++++++++++-------- 1 files changed, 132 insertions(+), 29 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 89a0174..28c301f 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. ;;; @@ -22,6 +22,7 @@ #:use-module (web client) #:use-module (web response) #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -30,8 +31,22 @@ #:use-module (guix ftp-client) #:use-module (guix utils) #:use-module (guix packages) - #:export (official-gnu-packages + #:export (gnu-package-name + gnu-package-mundane-name + gnu-package-copyright-holder + gnu-package-savannah + gnu-package-fsd + gnu-package-language + gnu-package-logo + gnu-package-doc-category + gnu-package-doc-summary + gnu-package-doc-urls + gnu-package-download-url + + official-gnu-packages + find-packages gnu-package? + releases latest-release gnu-package-name->name+version)) @@ -49,29 +64,32 @@ ;;; (define (http-fetch uri) - "Return a string containing the textual data at URI, a string." + "Return an input port containing the textual data at URI, a string." (let*-values (((resp data) (http-get (string->uri uri))) ((code) (response-code resp))) (case code ((200) - (if data - data - (begin - ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer - ;; encoding, which is required when fetching %PACKAGE-LIST-URL - ;; (see ). - ;; Since users may still be using these versions, warn them and - ;; bail out. - (format (current-error-port) - "warning: using Guile ~a, which does not support HTTP ~s encoding~%" - (version) - (response-transfer-encoding resp)) - (error "download failed; use a newer Guile" - uri resp)))) + (cond ((string<=? (version) "2.0.5") + (begin + ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer + ;; encoding, which is required when fetching %PACKAGE-LIST-URL + ;; (see ). + ;; Since users may still be using these versions, warn them and + ;; bail out. + (format (current-error-port) + "warning: using Guile ~a, ~a ~s encoding~%" + (version) + "which does not support HTTP" + (response-transfer-encoding resp)) + (error "download failed; use a newer Guile" + uri resp))) + ((string<=? (version) "2.0.7") + (open-input-string data)) + (else data))) (else - (error "download failed:" uri code + (error "download failed" uri code (response-reason-phrase resp)))))) (define %package-list-url @@ -79,16 +97,101 @@ "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-urls gnu-package-doc-urls) + (download-url gnu-package-download-url)) + (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:]]+): (.*)$")) + (doc-urls-rx (make-regexp "^doc-url: (.*)$")) + (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 doc-urls-rx str) + => + (lambda (match) + (if (equal? (assoc-ref (first state) "doc-urls") #f) + (group-package-fields + port (cons (cons (cons "doc-urls" + (list + (match:substring match 1))) + (first state)) + (drop state 1))) + (group-package-fields + port (cons (cons (cons "doc-urls" + (cons (match:substring match 1) + (assoc-ref (first state) + "doc-urls"))) + (assoc-remove! (first state) + "doc-urls")) + (drop state 1)))))) + ((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))) + + (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-urls" + "download-url"))) + (group-package-fields (http-fetch %package-list-url) + '(()))))) - (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))) +(define (find-packages regexp) + "Find GNU packages which satisfy REGEXP." + (let ((name-rx (make-regexp regexp))) + (filter (lambda (package) + (and=> (false-if-exception + (regexp-exec name-rx (gnu-package-name package))) + (const package))) + (official-gnu-packages)))) (define gnu-package? (memoize @@ -97,10 +200,10 @@ 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)) + (name (package-name package))) (or (and (string? url) (string-prefix? "mirror://gnu" url)) - (and (member (package-name package) (official-gnu-packages)) - #t)))))) + (not (null-list? (find-packages (format #f "^~a$" name))))))))) ;;; -- 1.7.5.4