summaryrefslogtreecommitdiff
path: root/guix/lint.scm
diff options
context:
space:
mode:
authorEfraim Flashner <efraim@flashner.co.il>2023-01-30 11:33:18 +0200
committerEfraim Flashner <efraim@flashner.co.il>2023-01-30 12:39:40 +0200
commit4cf1acc7f3033b50b0bf19e02c9f522d522d338c (patch)
tree9fd64956ee60304c15387eb394cd649e49f01467 /guix/lint.scm
parentedb8c09addd186d9538d43b12af74d6c7aeea082 (diff)
parent595b53b74e3ef57a1c0c96108ba86d38a170a241 (diff)
Merge remote-tracking branch 'origin/master' into core-updates
Conflicts: doc/guix.texi gnu/local.mk gnu/packages/admin.scm gnu/packages/base.scm gnu/packages/chromium.scm gnu/packages/compression.scm gnu/packages/databases.scm gnu/packages/diffoscope.scm gnu/packages/freedesktop.scm gnu/packages/gnome.scm gnu/packages/gnupg.scm gnu/packages/guile.scm gnu/packages/inkscape.scm gnu/packages/llvm.scm gnu/packages/openldap.scm gnu/packages/pciutils.scm gnu/packages/ruby.scm gnu/packages/samba.scm gnu/packages/sqlite.scm gnu/packages/statistics.scm gnu/packages/syndication.scm gnu/packages/tex.scm gnu/packages/tls.scm gnu/packages/version-control.scm gnu/packages/xml.scm guix/build-system/copy.scm guix/scripts/home.scm
Diffstat (limited to 'guix/lint.scm')
-rw-r--r--guix/lint.scm64
1 files changed, 60 insertions, 4 deletions
diff --git a/guix/lint.scm b/guix/lint.scm
index 4ef3a46838..a8a375e502 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -34,6 +34,7 @@
#:use-module (guix store)
#:autoload (guix base16) (bytevector->base16-string)
#:use-module (guix base32)
+ #:autoload (guix base64) (base64-encode)
#:use-module (guix build-system)
#:use-module (guix diagnostics)
#:use-module (guix download)
@@ -46,7 +47,6 @@
gexp->approximate-sexp))
#:use-module (guix licenses)
#:use-module (guix records)
- #:use-module (guix grafts)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix memoization)
@@ -59,10 +59,20 @@
#:use-module ((guix swh) #:hide (origin?))
#:autoload (guix git-download) (git-reference?
git-reference-url git-reference-commit)
+ #:autoload (guix svn-download) (svn-reference?
+ svn-reference-url
+ svn-reference-user-name
+ svn-reference-password
+
+ svn-multi-reference?
+ svn-multi-reference-url
+ svn-multi-reference-user-name
+ svn-multi-reference-password)
#:use-module (guix import stackage)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
+ #:autoload (rnrs bytevectors) (string->utf8)
#:use-module (web client)
#:use-module (web uri)
#:use-module ((guix build download)
@@ -720,8 +730,14 @@ response from URI, and additional details, such as the actual HTTP response.
TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
for connections to complete; when TIMEOUT is #f, wait as long as needed."
(define headers
- '((User-Agent . "GNU Guile")
- (Accept . "*/*")))
+ `((User-Agent . "GNU Guile")
+ (Accept . "*/*")
+ ,@(match (uri-userinfo uri)
+ ((? string? str) ;"basic authentication"
+ `((Authorization . ,(string-append "Basic "
+ (base64-encode
+ (string->utf8 str))))))
+ (_ '()))))
(let loop ((uri uri)
(visited '()))
@@ -1129,6 +1145,40 @@ descriptions maintained upstream."
((uris ...)
uris)))
+(define (svn-reference-uri-with-userinfo ref)
+ "Return the URI of REF, an <svn-reference> or <svn-multi-reference> object,
+but with an additional 'userinfo' part corresponding to REF's user name and
+password, provided REF's URI is HTTP or HTTPS."
+ ;; XXX: For lack of record type inheritance.
+ (define ->url
+ (if (svn-reference? ref)
+ svn-reference-url
+ svn-multi-reference-url))
+ (define ->user-name
+ (if (svn-reference? ref)
+ svn-reference-user-name
+ svn-multi-reference-user-name))
+ (define ->password
+ (if (svn-reference? ref)
+ svn-reference-password
+ svn-multi-reference-password))
+
+ (let ((uri (string->uri (->url ref))))
+ (if (and (->user-name ref)
+ (memq (uri-scheme uri) '(http https)))
+ (build-uri (uri-scheme uri)
+ #:userinfo
+ (string-append (->user-name ref)
+ (if (->password ref)
+ (string-append
+ ":" (->password ref))
+ ""))
+ #:host (uri-host uri)
+ #:port (uri-port uri)
+ #:query (uri-query uri)
+ #:fragment (uri-fragment uri))
+ uri)))
+
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
@@ -1174,6 +1224,12 @@ descriptions maintained upstream."
((git-reference? (origin-uri origin))
(warnings-for-uris
(list (string->uri (git-reference-url (origin-uri origin))))))
+ ((or (svn-reference? (origin-uri origin))
+ (svn-multi-reference? (origin-uri origin)))
+ (let ((uri (svn-reference-uri-with-userinfo (origin-uri origin))))
+ (if (memq (uri-scheme uri) '(http https))
+ (warnings-for-uris (list uri))
+ '()))) ;TODO: handle svn:// URLs
(else
'()))
'())))