From 187eb5f6430c5b8ba1dc1853e97533551f932b61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 29 Apr 2014 18:02:16 +0200 Subject: [PATCH] gnu-maintenance: Avoid network access in 'gnu-package?'. * guix/gnu-maintenance.scm (gnu-package?): Add 'mirror-type' procedure. Resort to 'official-gnu-packages' only when 'mirror-type' returns #f. --- guix/gnu-maintenance.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 14195da7ba..d8b6af9d31 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -167,13 +167,22 @@ (lambda (package) "Return true if PACKAGE is a GNU package. This procedure may access the network to check in GNU's database." - ;; TODO: Find a way to determine that a package is non-GNU without going - ;; through the network. + (define (mirror-type url) + (let ((uri (string->uri url))) + (and (eq? (uri-scheme uri) 'mirror) + (if (member (uri-host uri) '("gnu" "gnupg" "gcc")) + 'gnu + 'non-gnu)))) + (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) - (or (and (string? url) (string-prefix? "mirror://gnu" url)) - (and (member name (map gnu-package-name (official-gnu-packages))) - #t))))))) + (case (and url (mirror-type url)) + ((gnu) #t) + ((non-gnu) #f) + (else + ;; Last resort: resort to the network. + (and (member name (map gnu-package-name (official-gnu-packages))) + #t)))))))) ;;;