tests/ui.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013-2017, 2019-2020, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
   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 (srfi srfi-1)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-19)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-64)
  34   #:use-module (ice-9 regex))
  35
  36 ;; Test the (guix ui) module.
  37
  38 (define %paragraph
  39   "GNU Guile is an implementation of the Scheme programming language, with
  40 support for many SRFIs, packaged for use in a wide variety of environments.
  41 In addition to implementing the R5RS Scheme standard and a large subset of
  42 R6RS, Guile includes a module system, full access to POSIX system calls,
  43 networking support, multiple threads, dynamic linking, a foreign function call
  44 interface, and powerful string processing.")
  45
  46 (define guile-1.8.8
  47   (manifest-entry
  48     (name "guile")
  49     (version "1.8.8")
  50     (item "/gnu/store/...")
  51     (output "out")))
  52
  53 (define guile-2.0.9
  54   (manifest-entry
  55     (name "guile")
  56     (version "2.0.9")
  57     (item "/gnu/store/...")
  58     (output "out")))
  59
  60 \f
  61 (test-begin "ui")
  62
  63 (test-assert "fill-paragraph"
  64   (every (lambda (column)
  65            (every (lambda (width)
  66                     (every (lambda (line)
  67                              (<= (string-length line) width))
  68                            (string-split (fill-paragraph %paragraph
  69                                                          width column)
  70                                          #\newline)))
  71                   '(15 30 35 40 45 50 60 70 80 90 100)))
  72    '(0 5)))
  73
  74 (test-assert "fill-paragraph, consecutive newlines"
  75   (every (lambda (width)
  76            (any (lambda (line)
  77                   (string-prefix? "When STR" line))
  78                 (string-split
  79                  (fill-paragraph (procedure-documentation fill-paragraph)
  80                                  width)
  81                  #\newline)))
  82          '(15 20 25 30 40 50 60)))
  83
  84 (test-equal "fill-paragraph, large unbreakable word"
  85   '("Here is a" "very-very-long-word"
  86     "and that's" "it.")
  87   (string-split
  88    (fill-paragraph "Here is a very-very-long-word and that's it."
  89                    10)
  90    #\newline))
  91
  92 (test-equal "fill-paragraph, two spaces after period"
  93   "First line.  Second line"
  94   (fill-paragraph "First line.
  95 Second line" 24))
  96
  97 (test-equal "package-description-string vs. Unicode"
  98   "b•ll•t\n\n"                                ;see <http://bugs.gnu.org/21536>
  99   (with-fluids ((%default-port-encoding "ISO-8859-1"))
 100     (package-description-string
 101      (dummy-package "foo" (description "b•ll•t")))))
 102
 103 (test-equal "package-specification->name+version+output"
 104   '(("guile" #f "out")
 105     ("guile" "2.0.9" "out")
 106     ("guile" #f "debug")
 107     ("guile" "2.0.9" "debug")
 108     ("guile-cairo" "1.4.1" "out"))
 109   (map (lambda (spec)
 110          (call-with-values
 111              (lambda ()
 112                (package-specification->name+version+output spec))
 113            list))
 114        '("guile"
 115          "guile@2.0.9"
 116          "guile:debug"
 117          "guile@2.0.9:debug"
 118          "guile-cairo@1.4.1")))
 119
 120 (test-equal "integer"
 121   '(1)
 122   (string->generations "1"))
 123
 124 (test-equal "comma-separated integers"
 125   '(3 7 1 4 6)
 126   (string->generations "3,7,1,4,6"))
 127
 128 (test-equal "closed range"
 129   '(4 5 6 7 8 9 10 11 12)
 130   (string->generations "4..12"))
 131
 132 (test-equal "closed range, equal endpoints"
 133   '(3)
 134   (string->generations "3..3"))
 135
 136 (test-equal "indefinite end range"
 137   '(>= 7)
 138   (string->generations "7.."))
 139
 140 (test-equal "indefinite start range"
 141   '(<= 42)
 142   (string->generations "..42"))
 143
 144 (test-equal "integer, char"
 145   #f
 146   (string->generations "a"))
 147
 148 (test-equal "comma-separated integers, consecutive comma"
 149   #f
 150   (string->generations "1,,2"))
 151
 152 (test-equal "comma-separated integers, trailing comma"
 153   #f
 154   (string->generations "1,2,"))
 155
 156 (test-equal "comma-separated integers, chars"
 157   #f
 158   (string->generations "a,b"))
 159
 160 (test-equal "closed range, start > end"
 161   #f
 162   (string->generations "9..2"))
 163
 164 (test-equal "closed range, chars"
 165   #f
 166   (string->generations "a..b"))
 167
 168 (test-equal "indefinite end range, char"
 169   #f
 170   (string->generations "a.."))
 171
 172 (test-equal "indefinite start range, char"
 173   #f
 174   (string->generations "..a"))
 175
 176 (test-equal "duration, 1 day"
 177   (make-time time-duration 0 (* 3600 24))
 178   (string->duration "1d"))
 179
 180 (test-equal "duration, 1 week"
 181   (make-time time-duration 0 (* 3600 24 7))
 182   (string->duration "1w"))
 183
 184 (test-equal "duration, 1 month"
 185   (make-time time-duration 0 (* 3600 24 30))
 186   (string->duration "1m"))
 187
 188 (test-equal "duration, 1 week == 7 days"
 189   (string->duration "1w")
 190   (string->duration "7d"))
 191
 192 (test-equal "duration, 1 month == 30 days"
 193   (string->duration "1m")
 194   (string->duration "30d"))
 195
 196 (test-equal "duration, 2 hours"
 197   7200
 198   (time-second (string->duration "2h")))
 199
 200 (test-equal "duration, 1 second"
 201   (make-time time-duration 0 1)
 202   (string->duration "1s"))
 203
 204 (test-equal "duration, integer"
 205   #f
 206   (string->duration "1"))
 207
 208 (test-equal "duration, char"
 209   #f
 210   (string->duration "d"))
 211
 212 (test-equal "size->number, bytes"
 213   42
 214   (size->number "42"))
 215
 216 (test-equal "size->number, MiB"
 217   (* 42 (expt 2 20))
 218   (size->number "42MiB"))
 219
 220 (test-equal "size->number, GiB"
 221   (* 3 (expt 2 30))
 222   (size->number "3GiB"))
 223
 224 (test-equal "size->number, 1.2GiB"
 225   (inexact->exact (round (* 1.2 (expt 2 30))))
 226   (size->number "1.2GiB"))
 227
 228 (test-equal "size->number, 1T"
 229   (expt 2 40)
 230   (size->number "1T"))
 231
 232 (test-equal "size->number, 1.M"
 233   (expt 2 20)
 234   (size->number "1.M"))
 235
 236 (test-assert "size->number, invalid unit"
 237   (catch 'quit
 238     (lambda ()
 239       (size->number "9X"))
 240     (lambda args
 241       #t)))
 242
 243 (test-equal "show-what-to-build, zero outputs"
 244   ""
 245   (with-store store
 246     (let ((drv (derivation store "zero" "/bin/sh" '()
 247                            #:outputs '())))
 248       (with-error-to-string
 249        (lambda ()
 250          ;; This should print nothing.
 251          (show-what-to-build store (list drv)))))))
 252
 253 (test-assert "show-manifest-transaction"
 254   (let* ((m (manifest (list guile-1.8.8)))
 255          (t (manifest-transaction (install (list guile-2.0.9)))))
 256     (with-store store
 257       (and (string-match "guile +1.8.8 → 2.0.9"
 258                          (with-fluids ((%default-port-encoding "UTF-8"))
 259                            (with-error-to-string
 260                             (lambda ()
 261                               (show-manifest-transaction store m t)))))
 262            (string-match "guile +1.8.8 -> 2.0.9"
 263                          (with-error-to-string
 264                            (lambda ()
 265                              ;; In Guile 2.2, %DEFAULT-PORT-ENCODING doesn't
 266                              ;; influence the encoding of string ports.
 267                              (set-port-encoding! (current-error-port)
 268                                                  "ISO-8859-1")
 269                              (show-manifest-transaction store m t))))))))
 270
 271 (test-assert "package-relevance"
 272   (let ((guile  (specification->package "guile"))
 273         (gcrypt (specification->package "guile-gcrypt"))
 274         (go     (specification->package "go"))
 275         (gnugo  (specification->package "gnugo"))
 276         (libb2  (specification->package "libb2"))
 277         (rx     (cut make-regexp <> regexp/icase))
 278         (>0     (cut > <> 0))
 279         (=0     zero?))
 280     (and (>0 (package-relevance guile
 281                                 (map rx '("scheme"))))
 282          (>0 (package-relevance guile
 283                                 (map rx '("scheme" "implementation"))))
 284          (>0 (package-relevance gcrypt
 285                                 (map rx '("guile" "crypto"))))
 286          (=0 (package-relevance guile
 287                                 (map rx '("guile" "crypto"))))
 288          (>0 (package-relevance go
 289                                 (map rx '("go"))))
 290          (=0 (package-relevance go
 291                                 (map rx '("go" "game"))))
 292          (>0 (package-relevance gnugo
 293                                 (map rx '("go" "game"))))
 294          (>0 (package-relevance libb2
 295                                 (map rx '("crypto" "library")))))))
 296
 297 (test-assert "package-relevance and upstream name"
 298   ;; https://issues.guix.gnu.org/58136
 299   (let ((ggplot2  (specification->package "r-ggplot2"))
 300         (ggstance (specification->package "r-ggstance"))
 301         (rx       (make-regexp "ggplot2" regexp/icase)))
 302     (> (package-relevance ggplot2 (list rx))
 303        (package-relevance ggstance (list rx))
 304        0)))
 305
 306 (define (make-empty-file directory file)
 307   ;; Create FILE in DIRECTORY.
 308   (close-port (open-output-file (in-vicinity directory file))))
 309
 310 (define (assert-equals-find-available-pager expected)
 311   ;; Use 'with-paginated-output-port' and return true if it invoked EXPECTED.
 312   (define used-command "")
 313   (mock ((ice-9 popen) open-pipe*
 314          (lambda (mode command . args)
 315            (unless (string-null? used-command)
 316              (error "open-pipe* should only be called once"))
 317            (set! used-command command)
 318            (%make-void-port "")))
 319         (mock ((ice-9 popen) close-pipe (const 'ok))
 320               (mock ((guix colors) isatty?* (const #t))
 321                     (with-paginated-output-port port 'ok)
 322                     (string=? expected used-command)))))
 323
 324
 325 (test-assert "find-available-pager, GUIX_PAGER takes precedence"
 326   (call-with-temporary-directory
 327    (lambda (dir)
 328      (with-environment-variables `(("PATH" ,dir)
 329                                    ("GUIX_PAGER" "guix-pager")
 330                                    ("PAGER" "pager"))
 331        (make-empty-file dir "less")
 332        (make-empty-file dir "more")
 333        (assert-equals-find-available-pager "guix-pager")))))
 334
 335 (test-assert "find-available-pager, PAGER takes precedence"
 336   (call-with-temporary-directory
 337    (lambda (dir)
 338      (with-environment-variables `(("PATH" ,dir)
 339                                    ("GUIX_PAGER" #false)
 340                                    ("PAGER" "pager"))
 341        (make-empty-file dir "less")
 342        (make-empty-file dir "more")
 343        (assert-equals-find-available-pager "pager")))))
 344
 345 (test-assert "find-available-pager, 'less' takes precedence"
 346   (call-with-temporary-directory
 347    (lambda (dir)
 348      (with-environment-variables `(("PATH" ,dir)
 349                                    ("GUIX_PAGER" #false)
 350                                    ("PAGER" #false))
 351        (make-empty-file dir "less")
 352        (make-empty-file dir "more")
 353        (assert-equals-find-available-pager (in-vicinity dir "less"))))))
 354
 355 (test-assert "find-available-pager, 'more' takes precedence"
 356   (call-with-temporary-directory
 357    (lambda (dir)
 358      (with-environment-variables `(("PATH" ,dir)
 359                                    ("GUIX_PAGER" #false)
 360                                    ("PAGER" #false))
 361        (make-empty-file dir "more")
 362        (assert-equals-find-available-pager (in-vicinity dir "more"))))))
 363
 364 (test-assert "find-available-pager, no pager"
 365   (call-with-temporary-directory
 366    (lambda (dir)
 367      (with-environment-variables `(("PATH" ,dir)
 368                                    ("GUIX_PAGER" #false)
 369                                    ("PAGER" #false))
 370        (assert-equals-find-available-pager "")))))
 371
 372 (test-end "ui")