From 187eb5f6430c5b8ba1dc1853e97533551f932b61 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
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 14195da7ba3..d8b6af9d316 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -167,13 +167,22 @@ (define gnu-package?
(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))))))))
;;;
--
GitLab