me
/
guix
Archived
1
0
Fork 0
Code

lint: Extract logic of 'check-mirror-url'. 

It will be useful for fixing <https://issues.guix.gnu.org/57477>.

* 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 <ludo@gnu.org>
Maxime Devos 2022-09-01 11:01:48 +02:00 committed by Ludovic Courtès
parent b6274a20e8
commit fc5c4ce4ec
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 30 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
guix/gnu-maintenance.scm
View File

@ -33,6 +33,8 @@
#:use-module (rnrs io ports)
#:use-module (system foreign)
#:use-module ((guix http-client) #:hide (open-socket-for-uri))
;; not required in many cases, so autoloaded to reduce start-up costs.
#:autoload (guix download) (%mirrors)
#:use-module (guix ftp-client)
#:use-module (guix utils)
#:use-module (guix memoization)
@ -58,6 +60,8 @@
find-package
gnu-package?
uri-mirror-rewrite
release-file?
releases
latest-release
@ -658,6 +662,23 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
(string-append new (string-drop url (string-length old)))
url)))
(define (uri-mirror-rewrite uri)
"Rewrite URI to a mirror:// URI if possible, or return URI unmodified."
(if (string-prefix? "mirror://" uri)
uri ;nothing to do, it's already a mirror URI
(let loop ((mirrors %mirrors))
(match mirrors
(()
uri)
(((mirror-id mirror-urls ...) rest ...)
(match (find (cut string-prefix? <> uri) mirror-urls)
(#f
(loop rest))
(prefix
(format #f "mirror://~a/~a"
mirror-id
(string-drop uri (string-length prefix))))))))))
(define (adjusted-upstream-source source rewrite-url)
"Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
(upstream-source

26
guix/lint.scm
View File

@ -12,7 +12,7 @@
;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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)