From fc5c4ce4ec2ecf6b7d9e227617777d8dd10b903a Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Thu, 1 Sep 2022 11:01:48 +0200 Subject: lint: Extract logic of 'check-mirror-url'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It will be useful for fixing . * guix/lint.scm (check-mirror-url): Extract mirror://-constructing code to ... * guix/gnu-maintenance.scm (uri-mirror-rewrite): ... here, tweaking the API and implementation in anticipation of future users. Co-authored-by: Ludovic Courtès --- guix/lint.scm | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) (limited to 'guix/lint.scm') diff --git a/guix/lint.scm b/guix/lint.scm index edba1c2663..7ee3a3122f 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -12,7 +12,7 @@ ;;; Copyright © 2020 Chris Marusich ;;; Copyright © 2020 Timothy Sample ;;; Copyright © 2021 Xinglu Chen -;;; Copyright © 2021 Maxime Devos +;;; Copyright © 2021, 2022 Maxime Devos ;;; Copyright © 2021 Brice Waegeneire ;;; ;;; This file is part of GNU Guix. @@ -1222,22 +1222,14 @@ descriptions maintained upstream." (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) + (define (check-mirror-uri uri) + (define rewritten-uri + (uri-mirror-rewrite uri)) + + (and (not (string=? uri rewritten-uri)) + (make-warning package (G_ "URL should be '~a'") + (list rewritten-uri) + #:field 'source))) (let ((origin (package-source package))) (if (and (origin? origin) -- cgit v1.2.3