tests/ui.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 (define-module (test-ui)
  21   #:use-module (guix ui)
  22   #:use-module (guix profiles)
  23   #:use-module (guix store)
  24   #:use-module (guix derivations)
  25   #:use-module ((gnu packages) #:select (specification->package))
  26   #:use-module (guix tests)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-11)
  29   #:use-module (srfi srfi-19)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-64)
  32   #:use-module (ice-9 regex))
  33
  34 ;; Test the (guix ui) module.
  35
  36 (define %paragraph
  37   "GNU Guile is an implementation of the Scheme programming language, with
  38 support for many SRFIs, packaged for use in a wide variety of environments.
  39 In addition to implementing the R5RS Scheme standard and a large subset of
  40 R6RS, Guile includes a module system, full access to POSIX system calls,
  41 networking support, multiple threads, dynamic linking, a foreign function call
  42 interface, and powerful string processing.")
  43
  44 (define guile-1.8.8
  45   (manifest-entry
  46     (name "guile")
  47     (version "1.8.8")
  48     (item "/gnu/store/...")
  49     (output "out")))
  50
  51 (define guile-2.0.9
  52   (manifest-entry
  53     (name "guile")
  54     (version "2.0.9")
  55     (item "/gnu/store/...")
  56     (output "out")))
  57
  58 \f
  59 (test-begin "ui")
  60
  61 (test-assert "fill-paragraph"
  62   (every (lambda (column)
  63            (every (lambda (width)
  64                     (every (lambda (line)
  65                              (<= (string-length line) width))
  66                            (string-split (fill-paragraph %paragraph
  67                                                          width column)
  68                                          #\newline)))
  69                   '(15 30 35 40 45 50 60 70 80 90 100)))
  70    '(0 5)))
  71
  72 (test-assert "fill-paragraph, consecutive newlines"
  73   (every (lambda (width)
  74            (any (lambda (line)
  75                   (string-prefix? "When STR" line))
  76                 (string-split
  77                  (fill-paragraph (procedure-documentation fill-paragraph)
  78                                  width)
  79                  #\newline)))
  80          '(15 20 25 30 40 50 60)))
  81
  82 (test-equal "fill-paragraph, large unbreakable word"
  83   '("Here is a" "very-very-long-word"
  84     "and that's" "it.")
  85   (string-split
  86    (fill-paragraph "Here is a very-very-long-word and that's it."
  87                    10)
  88    #\newline))
  89
  90 (test-equal "fill-paragraph, two spaces after period"
  91   "First line.  Second line"
  92   (fill-paragraph "First line.
  93 Second line" 24))
  94
  95 (test-equal "package-description-string vs. Unicode"
  96   "b•ll•t\n\n"                                ;see <http://bugs.gnu.org/21536>
  97   (with-fluids ((%default-port-encoding "ISO-8859-1"))
  98     (package-description-string
  99      (dummy-package "foo" (description "b•ll•t")))))
 100
 101 (test-equal "package-specification->name+version+output"
 102   '(("guile" #f "out")
 103     ("guile" "2.0.9" "out")
 104     ("guile" #f "debug")
 105     ("guile" "2.0.9" "debug")
 106     ("guile-cairo" "1.4.1" "out"))
 107   (map (lambda (spec)
 108          (call-with-values
 109              (lambda ()
 110                (package-specification->name+version+output spec))
 111            list))
 112        '("guile"
 113          "guile@2.0.9"
 114          "guile:debug"
 115          "guile@2.0.9:debug"
 116          "guile-cairo@1.4.1")))
 117
 118 (test-equal "integer"
 119   '(1)
 120   (string->generations "1"))
 121
 122 (test-equal "comma-separated integers"
 123   '(3 7 1 4 6)
 124   (string->generations "3,7,1,4,6"))
 125
 126 (test-equal "closed range"
 127   '(4 5 6 7 8 9 10 11 12)
 128   (string->generations "4..12"))
 129
 130 (test-equal "closed range, equal endpoints"
 131   '(3)
 132   (string->generations "3..3"))
 133
 134 (test-equal "indefinite end range"
 135   '(>= 7)
 136   (string->generations "7.."))
 137
 138 (test-equal "indefinite start range"
 139   '(<= 42)
 140   (string->generations "..42"))
 141
 142 (test-equal "integer, char"
 143   #f
 144   (string->generations "a"))
 145
 146 (test-equal "comma-separated integers, consecutive comma"
 147   #f
 148   (string->generations "1,,2"))
 149
 150 (test-equal "comma-separated integers, trailing comma"
 151   #f
 152   (string->generations "1,2,"))
 153
 154 (test-equal "comma-separated integers, chars"
 155   #f
 156   (string->generations "a,b"))
 157
 158 (test-equal "closed range, start > end"
 159   #f
 160   (string->generations "9..2"))
 161
 162 (test-equal "closed range, chars"
 163   #f
 164   (string->generations "a..b"))
 165
 166 (test-equal "indefinite end range, char"
 167   #f
 168   (string->generations "a.."))
 169
 170 (test-equal "indefinite start range, char"
 171   #f
 172   (string->generations "..a"))
 173
 174 (test-equal "duration, 1 day"
 175   (make-time time-duration 0 (* 3600 24))
 176   (string->duration "1d"))
 177
 178 (test-equal "duration, 1 week"
 179   (make-time time-duration 0 (* 3600 24 7))
 180   (string->duration "1w"))
 181
 182 (test-equal "duration, 1 month"
 183   (make-time time-duration 0 (* 3600 24 30))
 184   (string->duration "1m"))
 185
 186 (test-equal "duration, 1 week == 7 days"
 187   (string->duration "1w")
 188   (string->duration "7d"))
 189
 190 (test-equal "duration, 1 month == 30 days"
 191   (string->duration "1m")
 192   (string->duration "30d"))
 193
 194 (test-equal "duration, 2 hours"
 195   7200
 196   (time-second (string->duration "2h")))
 197
 198 (test-equal "duration, 1 second"
 199   (make-time time-duration 0 1)
 200   (string->duration "1s"))
 201
 202 (test-equal "duration, integer"
 203   #f
 204   (string->duration "1"))
 205
 206 (test-equal "duration, char"
 207   #f
 208   (string->duration "d"))
 209
 210 (test-equal "size->number, bytes"
 211   42
 212   (size->number "42"))
 213
 214 (test-equal "size->number, MiB"
 215   (* 42 (expt 2 20))
 216   (size->number "42MiB"))
 217
 218 (test-equal "size->number, GiB"
 219   (* 3 (expt 2 30))
 220   (size->number "3GiB"))
 221
 222 (test-equal "size->number, 1.2GiB"
 223   (inexact->exact (round (* 1.2 (expt 2 30))))
 224   (size->number "1.2GiB"))
 225
 226 (test-equal "size->number, 1T"
 227   (expt 2 40)
 228   (size->number "1T"))
 229
 230 (test-equal "size->number, 1.M"
 231   (expt 2 20)
 232   (size->number "1.M"))
 233
 234 (test-assert "size->number, invalid unit"
 235   (catch 'quit
 236     (lambda ()
 237       (size->number "9X"))
 238     (lambda args
 239       #t)))
 240
 241 (test-equal "show-what-to-build, zero outputs"
 242   ""
 243   (with-store store
 244     (let ((drv (derivation store "zero" "/bin/sh" '()
 245                            #:outputs '())))
 246       (with-error-to-string
 247        (lambda ()
 248          ;; This should print nothing.
 249          (show-what-to-build store (list drv)))))))
 250
 251 (test-assert "show-manifest-transaction"
 252   (let* ((m (manifest (list guile-1.8.8)))
 253          (t (manifest-transaction (install (list guile-2.0.9)))))
 254     (with-store store
 255       (and (string-match "guile +1.8.8 → 2.0.9"
 256                          (with-fluids ((%default-port-encoding "UTF-8"))
 257                            (with-error-to-string
 258                             (lambda ()
 259                               (show-manifest-transaction store m t)))))
 260            (string-match "guile +1.8.8 -> 2.0.9"
 261                          (with-error-to-string
 262                            (lambda ()
 263                              ;; In Guile 2.2, %DEFAULT-PORT-ENCODING doesn't
 264                              ;; influence the encoding of string ports.
 265                              (set-port-encoding! (current-error-port)
 266                                                  "ISO-8859-1")
 267                              (show-manifest-transaction store m t))))))))
 268
 269 (test-assert "package-relevance"
 270   (let ((guile  (specification->package "guile"))
 271         (gcrypt (specification->package "guile-gcrypt"))
 272         (go     (specification->package "go"))
 273         (gnugo  (specification->package "gnugo"))
 274         (libb2  (specification->package "libb2"))
 275         (rx     (cut make-regexp <> regexp/icase))
 276         (>0     (cut > <> 0))
 277         (=0     zero?))
 278     (and (>0 (package-relevance guile
 279                                 (map rx '("scheme"))))
 280          (>0 (package-relevance guile
 281                                 (map rx '("scheme" "implementation"))))
 282          (>0 (package-relevance gcrypt
 283                                 (map rx '("guile" "crypto"))))
 284          (=0 (package-relevance guile
 285                                 (map rx '("guile" "crypto"))))
 286          (>0 (package-relevance go
 287                                 (map rx '("go"))))
 288          (=0 (package-relevance go
 289                                 (map rx '("go" "game"))))
 290          (>0 (package-relevance gnugo
 291                                 (map rx '("go" "game"))))
 292          (>0 (package-relevance libb2
 293                                 (map rx '("crypto" "library")))))))
 294
 295 (test-end "ui")