kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

gnu-maintenance: Support // URLs in latest-html-release.

Browse Source 
This makes "./pre-inst-env guix refresh -u" download the release tarball from
the right place -- previously, it downloaded from

https://www.libreoffice.org//download.documentfoundation.org/libreoffice/src/7.4.0/libreoffice-7.4.0.3.tar.xz?idx=1

whereas it should download from

https://download.documentfoundation.org/libreoffice/src/7.4.0/libreoffice-7.4.0.3.tar.xz?idx=1

instead.

* guix/gnu-maintenance.scm (latest-html-release)[url-release]: Adjust
computation in the case of an absolute URI-reference without a scheme.
* tests/gnu-maintenance.scm ("latest-html-release, scheme-less URIs"):
Test it.

Signed-off-by: Christopher Baines <mail@cbaines.net>
This commit is contained in:
Maxime Devos 2022-09-11 16:23:37 +02:00 committed by Christopher Baines
parent c00e1c87f2
commit c967d1153c
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
2 changed files with 36 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
guix/gnu-maintenance.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -499,6 +500,12 @@ are unavailable."
(base-url (string-append base-url directory)) (base-url (string-append base-url directory))
(url (cond ((and=> (string->uri url) uri-scheme) ;full URL? (url (cond ((and=> (string->uri url) uri-scheme) ;full URL?
url) url)
;; full URL, except for URI scheme. Reuse the URI
;; scheme of the document that contains the link.
((string-prefix? "//" url)
(string-append
(symbol->string (uri-scheme (string->uri base-url)))
":" url))
((string-prefix? "/" url) ;absolute path? ((string-prefix? "/" url) ;absolute path?
(let ((uri (string->uri base-url))) (let ((uri (string->uri base-url)))
(uri->string (uri->string

29
tests/gnu-maintenance.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,6 +19,10 @@
(define-module (test-gnu-maintenance) (define-module (test-gnu-maintenance)
#:use-module (guix gnu-maintenance) #:use-module (guix gnu-maintenance)
#:use-module (guix tests)
#:use-module (guix tests http)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
@ -55,4 +60,28 @@
("mpg321_0.3.2.orig.tar.gz" "0.3.2") ("mpg321_0.3.2.orig.tar.gz" "0.3.2")
("bvi-1.4.1.src.tar.gz" "1.4.1"))))) ("bvi-1.4.1.src.tar.gz" "1.4.1")))))
(test-assert "latest-html-release, scheme-less URIs"
(with-http-server
`((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
<head>
<title>Releases (on another domain)!</title>
</head>
<body
<a href=\"//another-site/foo-2.tar.gz\">version 1</a>
</body>
</html>"))
(let ()
(define package
(dummy-package "foo"
(source
(dummy-origin
(uri (string-append (%local-url) "/foo-1.tar.gz"))))
(properties
`((release-monitoring-url . ,(%local-url))))))
(define update ((upstream-updater-latest %generic-html-updater) package))
(define expected-new-url "http://another-site/foo-2.tar.gz")
(and (pk 'u update)
(equal? (upstream-source-version update) "2")
(equal? (list expected-new-url) (upstream-source-urls update))))))
(test-end) (test-end)