projects/guix·blob master · refs

460 lines · 14.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2017, 2019-2020, 2022, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2022 Taiju HIGASHI <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20
21(define-module (test-ui)
22 #:use-module (guix ui)
23 #:use-module (guix profiles)
24 #:use-module (guix store)
25 #:use-module (guix derivations)
26 #:use-module ((gnu packages) #:select (specification->package))
27 #:use-module (guix tests)
28 #:use-module (guix utils)
29 #:use-module ((guix channels)
30 #:select (channel->code
31 %default-guix-channel
32 guix-channel?
33 channel-introduction))
34 #:use-module (srfi srfi-1)
35 #:use-module (srfi srfi-11)
36 #:use-module (srfi srfi-19)
37 #:use-module (srfi srfi-26)
38 #:use-module (srfi srfi-64)
39 #:use-module (rnrs bytevectors)
40 #:use-module (ice-9 binary-ports)
41 #:use-module (ice-9 match)
42 #:use-module (ice-9 regex))
43
44;; Test the (guix ui) module.
45
46(define %paragraph
47 "GNU Guile is an implementation of the Scheme programming language, with
48support for many SRFIs, packaged for use in a wide variety of environments.
49In addition to implementing the R5RS Scheme standard and a large subset of
50R6RS, Guile includes a module system, full access to POSIX system calls,
51networking support, multiple threads, dynamic linking, a foreign function call
52interface, and powerful string processing.")
53
54(define guile-1.8.8
55 (manifest-entry
56 (name "guile")
57 (version "1.8.8")
58 (item "/gnu/store/...")
59 (output "out")))
60
61(define guile-2.0.9
62 (manifest-entry
63 (name "guile")
64 (version "2.0.9")
65 (item "/gnu/store/...")
66 (output "out")))
67
68
69(test-begin "ui")
70
71(test-assert "fill-paragraph"
72 (every (lambda (column)
73 (every (lambda (width)
74 (every (lambda (line)
75 (<= (string-length line) width))
76 (string-split (fill-paragraph %paragraph
77 width column)
78 #\newline)))
79 '(15 30 35 40 45 50 60 70 80 90 100)))
80 '(0 5)))
81
82(test-assert "fill-paragraph, consecutive newlines"
83 (every (lambda (width)
84 (any (lambda (line)
85 (string-prefix? "When STR" line))
86 (string-split
87 (fill-paragraph (procedure-documentation fill-paragraph)
88 width)
89 #\newline)))
90 '(15 20 25 30 40 50 60)))
91
92(test-equal "fill-paragraph, large unbreakable word"
93 '("Here is a" "very-very-long-word"
94 "and that's" "it.")
95 (string-split
96 (fill-paragraph "Here is a very-very-long-word and that's it."
97 10)
98 #\newline))
99
100(test-equal "fill-paragraph, two spaces after period"
101 "First line. Second line"
102 (fill-paragraph "First line.
103Second line" 24))
104
105(test-equal "package-description-string vs. Unicode"
106 "b•ll•t\n\n" ;see <http://bugs.gnu.org/21536>
107 (with-fluids ((%default-port-encoding "ISO-8859-1"))
108 (package-description-string
109 (dummy-package "foo" (description "b•ll•t")))))
110
111(test-equal "package-specification->name+version+output"
112 '(("guile" #f "out")
113 ("guile" "2.0.9" "out")
114 ("guile" #f "debug")
115 ("guile" "2.0.9" "debug")
116 ("guile-cairo" "1.4.1" "out"))
117 (map (lambda (spec)
118 (call-with-values
119 (lambda ()
120 (package-specification->name+version+output spec))
121 list))
122 '("guile"
123 "[email protected]"
124 "guile:debug"
125 "[email protected]:debug"
126 "[email protected]")))
127
128(test-equal "integer"
129 '(1)
130 (string->generations "1"))
131
132(test-equal "comma-separated integers"
133 '(3 7 1 4 6)
134 (string->generations "3,7,1,4,6"))
135
136(test-equal "closed range"
137 '(4 5 6 7 8 9 10 11 12)
138 (string->generations "4..12"))
139
140(test-equal "closed range, equal endpoints"
141 '(3)
142 (string->generations "3..3"))
143
144(test-equal "indefinite end range"
145 '(>= 7)
146 (string->generations "7.."))
147
148(test-equal "indefinite start range"
149 '(<= 42)
150 (string->generations "..42"))
151
152(test-equal "integer, char"
153 #f
154 (string->generations "a"))
155
156(test-equal "comma-separated integers, consecutive comma"
157 #f
158 (string->generations "1,,2"))
159
160(test-equal "comma-separated integers, trailing comma"
161 #f
162 (string->generations "1,2,"))
163
164(test-equal "comma-separated integers, chars"
165 #f
166 (string->generations "a,b"))
167
168(test-equal "closed range, start > end"
169 #f
170 (string->generations "9..2"))
171
172(test-equal "closed range, chars"
173 #f
174 (string->generations "a..b"))
175
176(test-equal "indefinite end range, char"
177 #f
178 (string->generations "a.."))
179
180(test-equal "indefinite start range, char"
181 #f
182 (string->generations "..a"))
183
184(test-equal "duration, 1 day"
185 (make-time time-duration 0 (* 3600 24))
186 (string->duration "1d"))
187
188(test-equal "duration, 1 week"
189 (make-time time-duration 0 (* 3600 24 7))
190 (string->duration "1w"))
191
192(test-equal "duration, 1 month"
193 (make-time time-duration 0 (* 3600 24 30))
194 (string->duration "1m"))
195
196(test-equal "duration, 1 week == 7 days"
197 (string->duration "1w")
198 (string->duration "7d"))
199
200(test-equal "duration, 1 month == 30 days"
201 (string->duration "1m")
202 (string->duration "30d"))
203
204(test-equal "duration, 2 hours"
205 7200
206 (time-second (string->duration "2h")))
207
208(test-equal "duration, 1 second"
209 (make-time time-duration 0 1)
210 (string->duration "1s"))
211
212(test-equal "duration, integer"
213 #f
214 (string->duration "1"))
215
216(test-equal "duration, char"
217 #f
218 (string->duration "d"))
219
220(test-equal "size->number, bytes"
221 42
222 (size->number "42"))
223
224(test-equal "size->number, MiB"
225 (* 42 (expt 2 20))
226 (size->number "42MiB"))
227
228(test-equal "size->number, GiB"
229 (* 3 (expt 2 30))
230 (size->number "3GiB"))
231
232(test-equal "size->number, 1.2GiB"
233 (inexact->exact (round (* 1.2 (expt 2 30))))
234 (size->number "1.2GiB"))
235
236(test-equal "size->number, 1T"
237 (expt 2 40)
238 (size->number "1T"))
239
240(test-equal "size->number, 1.M"
241 (expt 2 20)
242 (size->number "1.M"))
243
244(test-assert "size->number, invalid unit"
245 (catch 'quit
246 (lambda ()
247 (size->number "9X"))
248 (lambda args
249 #t)))
250
251(test-equal "show-what-to-build, zero outputs"
252 ""
253 (with-store store
254 (let ((drv (derivation store "zero" "/bin/sh" '()
255 #:outputs '())))
256 (with-error-to-string
257 (lambda ()
258 ;; This should print nothing.
259 (show-what-to-build store (list drv)))))))
260
261(test-assert "show-manifest-transaction"
262 (let* ((m (manifest (list guile-1.8.8)))
263 (t (manifest-transaction (install (list guile-2.0.9)))))
264 (with-store store
265 (and (string-match "guile +1.8.8 → 2.0.9"
266 (with-fluids ((%default-port-encoding "UTF-8"))
267 (with-error-to-string
268 (lambda ()
269 (show-manifest-transaction store m t)))))
270 (string-match "guile +1.8.8 -> 2.0.9"
271 (with-error-to-string
272 (lambda ()
273 ;; In Guile 2.2, %DEFAULT-PORT-ENCODING doesn't
274 ;; influence the encoding of string ports.
275 (set-port-encoding! (current-error-port)
276 "ISO-8859-1")
277 (show-manifest-transaction store m t))))))))
278
279(test-assert "package-relevance"
280 (let ((guile (specification->package "guile"))
281 (gcrypt (specification->package "guile-gcrypt"))
282 (go (specification->package "go"))
283 (gnugo (specification->package "gnugo"))
284 (libb2 (specification->package "libb2"))
285 (rx (cut make-regexp <> regexp/icase))
286 (>0 (cut > <> 0))
287 (=0 zero?))
288 (and (>0 (package-relevance guile
289 (map rx '("scheme"))))
290 (>0 (package-relevance guile
291 (map rx '("scheme" "implementation"))))
292 (>0 (package-relevance gcrypt
293 (map rx '("guile" "crypto"))))
294 (=0 (package-relevance guile
295 (map rx '("guile" "crypto"))))
296 (>0 (package-relevance go
297 (map rx '("go"))))
298 (=0 (package-relevance go
299 (map rx '("go" "game"))))
300 (>0 (package-relevance gnugo
301 (map rx '("go" "game"))))
302 (>0 (package-relevance libb2
303 (map rx '("crypto" "library")))))))
304
305(test-assert "package-relevance and upstream name"
306 ;; https://issues.guix.gnu.org/58136
307 (let ((ggplot2 (specification->package "r-ggplot2"))
308 (ggstance (specification->package "r-ggstance"))
309 (rx (make-regexp "ggplot2" regexp/icase)))
310 (> (package-relevance ggplot2 (list rx))
311 (package-relevance ggstance (list rx))
312 0)))
313
314(define (make-empty-file directory file)
315 ;; Create FILE in DIRECTORY.
316 (close-port (open-output-file (in-vicinity directory file))))
317
318(define (assert-equals-find-available-pager expected)
319 ;; Use 'with-paginated-output-port' and return true if it invoked EXPECTED.
320 (define used-command "")
321 (mock ((ice-9 popen) open-pipe*
322 (lambda (mode command . args)
323 (unless (string-null? used-command)
324 (error "open-pipe* should only be called once"))
325 (set! used-command command)
326 (%make-void-port "")))
327 (mock ((ice-9 popen) close-pipe (const 'ok))
328 (mock ((guix colors) isatty?* (const #t))
329 (with-paginated-output-port port 'ok)
330 (string=? expected used-command)))))
331
332
333(test-assert "find-available-pager, GUIX_PAGER takes precedence"
334 (call-with-temporary-directory
335 (lambda (dir)
336 (with-environment-variables `(("PATH" ,dir)
337 ("GUIX_PAGER" "guix-pager")
338 ("PAGER" "pager"))
339 (make-empty-file dir "less")
340 (make-empty-file dir "more")
341 (assert-equals-find-available-pager "guix-pager")))))
342
343(test-assert "find-available-pager, PAGER takes precedence"
344 (call-with-temporary-directory
345 (lambda (dir)
346 (with-environment-variables `(("PATH" ,dir)
347 ("GUIX_PAGER" #false)
348 ("PAGER" "pager"))
349 (make-empty-file dir "less")
350 (make-empty-file dir "more")
351 (assert-equals-find-available-pager "pager")))))
352
353(test-assert "find-available-pager, 'less' takes precedence"
354 (call-with-temporary-directory
355 (lambda (dir)
356 (with-environment-variables `(("PATH" ,dir)
357 ("GUIX_PAGER" #false)
358 ("PAGER" #false))
359 (make-empty-file dir "less")
360 (make-empty-file dir "more")
361 (assert-equals-find-available-pager (in-vicinity dir "less"))))))
362
363(test-assert "find-available-pager, 'more' takes precedence"
364 (call-with-temporary-directory
365 (lambda (dir)
366 (with-environment-variables `(("PATH" ,dir)
367 ("GUIX_PAGER" #false)
368 ("PAGER" #false))
369 (make-empty-file dir "more")
370 (assert-equals-find-available-pager (in-vicinity dir "more"))))))
371
372(test-assert "find-available-pager, no pager"
373 (call-with-temporary-directory
374 (lambda (dir)
375 (with-environment-variables `(("PATH" ,dir)
376 ("GUIX_PAGER" #false)
377 ("PAGER" #false))
378 (assert-equals-find-available-pager "")))))
379
380(test-equal "load/isolated, reading exceeds limits"
381 'quit ;'limit-exceeded is raised, caught, and then 'quit is raised
382 (let ((port (make-custom-binary-input-port
383 "infinite-paren-stream"
384 (lambda (bv start count)
385 (bytevector-u8-set! bv start (char->integer #\())
386 1)
387 #f #f #f)))
388 (catch #t
389 (lambda ()
390 (load* port '() #:isolated? #t)
391 #f)
392 (lambda (key . args)
393 key))))
394
395(test-equal "load/isolated, attempt to import module"
396 'quit
397 (call-with-input-string (object->string
398 '(begin
399 (use-modules (system foreign))
400 (dereference-pointer (make-pointer 123))))
401 (lambda (port)
402 (catch #t
403 (lambda ()
404 (load* port '() #:isolated? #t)
405 #f)
406 (lambda (key . args)
407 key)))))
408
409(test-equal "load/isolated, attempt to allocate with 'cons'"
410 'quit
411 ;; 'make-list' is not available in the environment so try to allocate memory
412 ;; via macro expansion or repeated calls to 'cons'.
413 (call-with-input-string
414 (object->string
415 '(letrec-syntax ((make-list
416 (lambda (s)
417 (syntax-case s ()
418 ((_ 0) #''())
419 ((_ n)
420 #`(cons #f
421 (make-list
422 #,(- (syntax->datum #'n) 1))))))))
423 (make-list 100000)))
424 (lambda (port)
425 (catch #t
426 (lambda ()
427 (load* port '() #:isolated? #t)
428 #f)
429 (lambda (key . args)
430 key)))))
431
432(test-equal "load/isolated, attempt to allocate with 'make-vector'"
433 'quit
434 ;; 'make-vector' is not available in the environment.
435 (call-with-input-string (object->string '(make-vector 123123123))
436 (lambda (port)
437 (catch #t
438 (lambda ()
439 (load* port '() #:isolated? #t)
440 #f)
441 (lambda (key . args)
442 key)))))
443
444(test-assert "load/isolated, use of allowed bindings"
445 (call-with-input-string
446 (object->string
447 `(list ,(channel->code %default-guix-channel)))
448 (lambda (port)
449 (match (load* port
450 '(((guix channels)
451 channel make-channel-introduction openpgp-fingerprint))
452 #:isolated? #t)
453 ((channel)
454 ;; The channels have a different 'location' field value hence this
455 ;; limited comparison.
456 (and (guix-channel? channel)
457 (equal? (channel-introduction channel)
458 (channel-introduction %default-guix-channel))))))))
459
460(test-end "ui")