projects/guix·blob sysadmin-team · refs

295 lines · 10.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015, 2021, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2022 Maxime Devos <[email protected]>
4;;; Copyright © 2023-2024 Maxim Cournoyer <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (test-gnu-maintenance)
22 #:use-module (guix gnu-maintenance)
23 #:use-module (guix tests)
24 #:use-module (guix tests http)
25 #:use-module (guix upstream)
26 #:use-module (guix utils)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-64)
29 #:use-module ((web client) #:select (current-http-proxy))
30 #:use-module ((web uri) #:select (uri? uri->string string->uri uri-path))
31 #:use-module (ice-9 match))
32
33(test-begin "gnu-maintenance")
34
35(test-assert "release-file?"
36 (and (every (lambda (project+file)
37 (apply release-file? project+file))
38 '(("gcc" "gcc-5.3.0.tar.bz2")
39 ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz")
40 ("icecat" "icecat-38.4.0-gnu1.tar.bz2")
41 ("mit-scheme" "mit-scheme-9.2.tar.gz")
42 ("mediainfo" "mediainfo_20.09.tar.xz")
43 ("exiv2" "exiv2-0.27.3-Source.tar.gz")
44 ("mpg321" "mpg321_0.3.2.orig.tar.gz")
45 ("bvi" "bvi-1.4.1.src.tar.gz")
46 ("hostscope" "hostscope-V2.1.tgz")
47 ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz")
48 ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz")
49 ("qt-creator" "qt-creator-opensource-src-11.0.1.tar.xz")))
50 (every (lambda (project+file)
51 (not (apply release-file? project+file)))
52 '(("guile" "guile-www-1.1.1.tar.gz")
53 ("guile" "guile-2.0.11.tar.gz.sig")
54 ("mit-scheme" "mit-scheme-9.2-i386.tar.gz")
55 ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz")
56 ("gnutls" "gnutls-3.2.18-w32.zip")
57 ("valgrind" "valgrind-3.20.0.RC1.tar.bz2")))))
58
59(test-assert "tarball->version"
60 (let ((tarball->version (@@ (guix gnu-maintenance) tarball->version)))
61 (every (match-lambda
62 ((file version)
63 (equal? (tarball->version file) version)))
64 '(("coreutils-8.32.tar.gz" "8.32")
65 ("mediainfo_20.09.tar.xz" "20.09")
66 ("exiv2-0.27.3-Source.tar.gz" "0.27.3")
67 ("mpg321_0.3.2.orig.tar.gz" "0.3.2")
68 ("bvi-1.4.1.src.tar.gz" "1.4.1")))))
69
70(test-assert "latest-html-release, scheme-less URIs"
71 (with-http-server
72 `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
73<head>
74<title>Releases (on another domain)!</title>
75</head>
76<body
77<a href=\"//another-site/foo-2.tar.gz\">version 1</a>
78</body>
79</html>"))
80 (let ()
81 (define package
82 (dummy-package "foo"
83 (source
84 (dummy-origin
85 (uri (string-append (%local-url) "/foo-1.tar.gz"))))
86 (properties
87 `((release-monitoring-url . ,(%local-url))))))
88 (define update ((upstream-updater-import %generic-html-updater) package))
89 (define expected-new-url "http://another-site/foo-2.tar.gz")
90 (and (pk 'u update)
91 (equal? (upstream-source-version update) "2")
92 (equal? (list expected-new-url) (upstream-source-urls update))))))
93
94(test-equal "latest-html-release, 'release-file-regexp' property"
95 '("foo"
96 "1.2.3"
97 ("/dl/FOO1.2.3.tgz"))
98 (with-http-server
99 `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
100<head>
101<title>Releases with unusual file names</title>
102</head>
103<body
104<a href=\"FOO1.2.3.tgz\">version 1.2</a>
105</body>
106</html>"))
107 (let ()
108 (define package
109 (dummy-package "foo"
110 (source
111 (dummy-origin
112 (uri (string-append (%local-url #:path "/dl")
113 "/FOO1.0.0.tar.gz"))))
114 (properties
115 `((release-monitoring-url . ,(%local-url #:path "/dl/"))
116 (release-file-regexp . "FOO([0-9\\.]+)\\.tgz")))))
117 (define update
118 ((upstream-updater-import %generic-html-updater) package))
119
120 (list (upstream-source-package update)
121 (upstream-source-version update)
122 (map (compose uri-path string->uri)
123 (upstream-source-urls update))))))
124
125(test-assert "latest-html-release, invalid 'release-file-regexp' property"
126 (with-http-server
127 `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
128<head>
129<title>Releases with unusual file names</title>
130</head>
131<body
132<a href=\"FOO1.2.3.tgz\">version 1.2</a>
133</body>
134</html>"))
135 (let ()
136 (define package
137 (dummy-package "foo"
138 (source
139 (dummy-origin
140 (uri (string-append (%local-url #:path "/dl")
141 "/FOO1.0.0.tar.gz"))))
142 (properties
143 `((release-monitoring-url . ,(%local-url #:path "/dl/"))
144 (release-file-regexp . "FOO[0-9\\.]+\\.tgz")))))
145 (not ((upstream-updater-import %generic-html-updater) package)))))
146
147
148(test-assert "latest-html-release, no signature"
149 (with-http-server
150 `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
151<head>
152<title>Releases!</title>
153</head>
154<body>
155<a href=\"bar/foo-1.tar.gz\">version 1</a>
156<a href=\"bar/foo-2.tar.gz\">version 2</a>
157</body>
158</html>"))
159 (let ()
160 (define package
161 (dummy-package "foo"
162 (source
163 (dummy-origin
164 (uri (string-append (%local-url) "/foo-1.tar.gz"))))
165 (properties
166 `((release-monitoring-url . ,(%local-url))))))
167 (define update ((upstream-updater-import %generic-html-updater) package))
168 (define expected-new-url
169 (string-append (%local-url) "/foo-2.tar.gz"))
170 (and (pk 'u update)
171 (equal? (upstream-source-version update) "2")
172 (equal? (list expected-new-url)
173 (upstream-source-urls update))
174 (null? ;; both #false and the empty list are acceptable
175 (or (upstream-source-signature-urls update) '()))))))
176
177(test-assert "latest-html-release, signature"
178 (with-http-server
179 `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\">
180<head>
181<title>Signed releases!</title>
182</head>
183<body>
184<a href=\"bar/foo-1.tar.gz\">version 1</a>
185<a href=\"bar/foo-2.tar.gz\">version 2</a>
186<a href=\"bar/foo-1.tar.gz.sig\">version 1 signature</a>
187<a href=\"bar/foo-2.tar.gz.sig\">version 2 signature</a>
188</body>
189</html>"))
190 (let ()
191 (define package
192 (dummy-package "foo"
193 (source
194 (dummy-origin
195 (uri (string-append (%local-url) "/foo-1.tar.gz"))))
196 (properties
197 `((release-monitoring-url . ,(%local-url))))))
198 (define update ((upstream-updater-import %generic-html-updater) package))
199 (define expected-new-url
200 (string-append (%local-url) "/foo-2.tar.gz"))
201 (define expected-signature-url
202 (string-append (%local-url) "/foo-2.tar.gz.sig"))
203 (and (pk 'u update)
204 (equal? (upstream-source-version update) "2")
205 (equal? (list expected-new-url)
206 (upstream-source-urls update))
207 (equal? (list expected-signature-url)
208 (upstream-source-signature-urls update))))))
209
210(test-equal "rewrite-url, to-version specified"
211 "https://download.qt.io/official_releases/qt/6.5/6.5.2/\
212submodules/qtbase-everywhere-src-6.5.2.tar.xz"
213 (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\
214submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
215
216(define (mock-http-fetch/cached testcase)
217 (lambda (url . rest)
218 (let* ((url (if (uri? url)
219 (uri->string url)
220 url))
221 (body (assoc-ref testcase url)))
222 (if body
223 (open-input-string body)
224 (error "mocked http-fetch Unexpected URL: " url)))))
225
226(define libuv-dist-html "\
227<!DOCTYPE html>
228<html>
229<head><title>Index of dist</title></head>
230<body>
231<a href=\"../\">../</a>
232<a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a>
233<a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a>
234<a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a>
235<a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a>
236<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
237</body>
238</html>")
239
240(define libuv-dist-1.46.0-html "\
241<!DOCTYPE html>
242<html>
243<head><title>Index of dist/v1.46.0</title></head>
244<body>
245<a href=\"../\">../</a>
246<a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\">
247 libuv-v1.46.0-dist.tar.gz</a>
248<a href=\"libuv-v1.46.0-dist.tar.gz.sign\"
249 title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a>
250<a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\">
251 libuv-v1.46.0.tar.gz</a>
252<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\">
253 libuv-v1.46.0.tar.gz.sign</a>
254</body>
255</html>")
256
257(define libuv-dist-1.44.2-html "\
258<!DOCTYPE html>
259<html>
260<head><title>Index of dist/v1.44.2</title></head>
261<body>
262<a href=\"../\">../</a>
263<a href=\"libuv-v1.44.2-dist.tar.gz\" title=\"libuv-v1.44.2-dist.tar.gz\">
264 libuv-v1.44.2-dist.tar.gz</a>
265<a href=\"libuv-v1.44.2-dist.tar.gz.sign\" title=\"libuv-v1.44.2-dist.tar.gz.sign\">
266 libuv-v1.44.2-dist.tar.gz.sign</a>
267<a href=\"libuv-v1.44.2.tar.gz\" title=\"libuv-v1.44.2.tar.gz\">
268 libuv-v1.44.2.tar.gz</a>
269<a href=\"libuv-v1.44.2.tar.gz.sign\" title=\"libuv-v1.44.2.tar.gz.sign\">
270 libuv-v1.44.2.tar.gz.sign</a>
271</body>
272</html>")
273
274(define libuv-html-data
275 `(("http://dist.libuv.example.org/dist" . ,libuv-dist-html)
276 ("http://dist.libuv.example.org/dist/v1.44.2" . ,libuv-dist-1.44.2-html)
277 ("http://dist.libuv.example.org/dist/v1.46.0" . ,libuv-dist-1.46.0-html)))
278
279(test-equal "rewrite-url, without to-version"
280 "http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
281 (mock ((guix http-client) http-fetch/cached
282 (mock-http-fetch/cached libuv-html-data))
283 (rewrite-url
284 "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
285 "1.45.0")))
286
287(test-equal "rewrite-url, partial to-version"
288 "http://dist.libuv.example.org/dist/v1.44.2/libuv-v1.44.2.tar.gz"
289 (mock ((guix http-client) http-fetch/cached
290 (mock-http-fetch/cached libuv-html-data))
291 (rewrite-url
292 "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
293 "1.45.0" #:to-version "1.44" #:partial-version? #t)))
294
295(test-end)