tests/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   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 (define-module (test-utils)
  21   #:use-module ((guix config) #:select (%gzip))
  22   #:use-module (guix utils)
  23   #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-64)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (rnrs io ports)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 vlist))
  31
  32 (define temp-file
  33   (string-append "t-utils-" (number->string (getpid))))
  34
  35 (test-begin "utils")
  36
  37 (test-assert "bytevector->base16-string->bytevector"
  38   (every (lambda (bv)
  39            (equal? (base16-string->bytevector
  40                     (bytevector->base16-string bv))
  41                    bv))
  42          (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
  43
  44 (test-assert "gnu-triplet->nix-system"
  45   (let ((samples '(("i586-gnu0.3" "i686-gnu")
  46                    ("x86_64-unknown-linux-gnu" "x86_64-linux")
  47                    ("i386-pc-linux-gnu" "i686-linux")
  48                    ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
  49                    ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
  50                    ("i686-pc-cygwin" "i686-cygwin"))))
  51     (let-values (((gnu nix) (unzip2 samples)))
  52       (every (lambda (gnu nix)
  53                (equal? nix (gnu-triplet->nix-system gnu)))
  54              gnu nix))))
  55
  56 (test-assert "package-name->name+version"
  57   (every (match-lambda
  58           ((name version)
  59            (let*-values (((full-name)
  60                           (if version
  61                               (string-append name "-" version)
  62                               name))
  63                          ((name* version*)
  64                           (package-name->name+version full-name)))
  65              (and (equal? name* name)
  66                   (equal? version* version)))))
  67          '(("foo" "0.9.1b")
  68            ("foo-bar" "1.0")
  69            ("foo-bar2" #f)
  70            ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
  71            ("nixpkgs" "1.0pre22125_a28fe19")
  72            ("gtk2" "2.38.0"))))
  73
  74 (test-assert "guile-version>? 1.8"
  75   (guile-version>? "1.8"))
  76
  77 (test-assert "guile-version>? 10.5"
  78   (not (guile-version>? "10.5")))
  79
  80 (test-equal "string-tokenize*"
  81   '(("foo")
  82     ("foo" "bar" "baz")
  83     ("foo" "bar" "")
  84     ("foo" "bar" "baz"))
  85   (list (string-tokenize* "foo" ":")
  86         (string-tokenize* "foo;bar;baz" ";")
  87         (string-tokenize* "foo!bar!" "!")
  88         (string-tokenize* "foo+-+bar+-+baz" "+-+")))
  89
  90 (test-equal "string-replace-substring"
  91   '("foo BAR! baz"
  92     "/gnu/store/chbouib"
  93     "")
  94   (list (string-replace-substring "foo bar baz" "bar" "BAR!")
  95         (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
  96         (string-replace-substring "" "foo" "bar")))
  97
  98 (test-equal "fold2, 1 list"
  99     (list (reverse (iota 5))
 100           (map - (reverse (iota 5))))
 101   (call-with-values
 102       (lambda ()
 103         (fold2 (lambda (i r1 r2)
 104                  (values (cons i r1)
 105                          (cons (- i) r2)))
 106                '() '()
 107                (iota 5)))
 108     list))
 109
 110 (test-equal "fold2, 2 lists"
 111     (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3)))
 112           (reverse '((a . 0) (b . -1) (c . -2) (d . -3))))
 113   (call-with-values
 114       (lambda ()
 115         (fold2 (lambda (k v r1 r2)
 116                  (values (alist-cons k v r1)
 117                          (alist-cons k (- v) r2)))
 118                '() '()
 119                '(a b c d)
 120                '(0 1 2 3)))
 121     list))
 122
 123 (test-equal "strip-keyword-arguments"
 124   '(a #:b b #:c c)
 125   (strip-keyword-arguments '(#:foo #:bar #:baz)
 126                            '(a #:foo 42 #:b b #:baz 3
 127                                #:c c #:bar 4)))
 128
 129 (let* ((tree (alist->vhash
 130               '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6))
 131               hashq))
 132        (add-one (lambda (_ r) (1+ r)))
 133        (tree-lookup (lambda (n) (cdr (vhash-assq n tree)))))
 134   (test-equal "fold-tree, single root"
 135     5 (fold-tree add-one 0 tree-lookup '(0)))
 136   (test-equal "fold-tree, two roots"
 137     7 (fold-tree add-one 0 tree-lookup '(0 1)))
 138   (test-equal "fold-tree, sum"
 139     16 (fold-tree + 0 tree-lookup '(0)))
 140   (test-equal "fold-tree, internal"
 141     18 (fold-tree + 0 tree-lookup '(3 4)))
 142   (test-equal "fold-tree, cons"
 143     '(1 3 4 5 6)
 144     (sort (fold-tree cons '() tree-lookup '(1)) <))
 145   (test-equal "fold-tree, overlapping paths"
 146     '(1 3 4 5 6)
 147     (sort (fold-tree cons '() tree-lookup '(1 4)) <))
 148   (test-equal "fold-tree, cons, two roots"
 149     '(0 2 3 4 5 6)
 150     (sort (fold-tree cons '() tree-lookup '(0 4)) <))
 151   (test-equal "fold-tree-leaves, single root"
 152     2 (fold-tree-leaves add-one 0 tree-lookup '(1)))
 153   (test-equal "fold-tree-leaves, single root, sum"
 154     11 (fold-tree-leaves + 0 tree-lookup '(1)))
 155   (test-equal "fold-tree-leaves, two roots"
 156     3 (fold-tree-leaves add-one 0 tree-lookup '(0 1)))
 157   (test-equal "fold-tree-leaves, two roots, sum"
 158     13 (fold-tree-leaves + 0 tree-lookup '(0 1))))
 159
 160 (test-assert "filtered-port, file"
 161   (let* ((file  (search-path %load-path "guix.scm"))
 162          (input (open-file file "r0b")))
 163     (let*-values (((compressed pids1)
 164                    (filtered-port `(,%gzip "-c" "--fast") input))
 165                   ((decompressed pids2)
 166                    (filtered-port `(,%gzip "-d") compressed)))
 167       (and (every (compose zero? cdr waitpid)
 168                   (append pids1 pids2))
 169            (equal? (get-bytevector-all decompressed)
 170                    (call-with-input-file file get-bytevector-all))))))
 171
 172 (test-assert "filtered-port, non-file"
 173   (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 174                 get-bytevector-all)))
 175     (let*-values (((compressed pids1)
 176                    (filtered-port `(,%gzip "-c" "--fast")
 177                                   (open-bytevector-input-port data)))
 178                   ((decompressed pids2)
 179                    (filtered-port `(,%gzip "-d") compressed)))
 180       (and (pk (every (compose zero? cdr waitpid)
 181                    (append pids1 pids2)))
 182            (equal? (get-bytevector-all decompressed) data)))))
 183
 184 (test-assert "filtered-port, does not exist"
 185   (let* ((file  (search-path %load-path "guix.scm"))
 186          (input (open-file file "r0b")))
 187     (let-values (((port pids)
 188                   (filtered-port '("/does/not/exist") input)))
 189       (any (compose (negate zero?) cdr waitpid)
 190            pids))))
 191
 192 (test-assert "compressed-port, decompressed-port, non-file"
 193   (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 194                 get-bytevector-all)))
 195     (let*-values (((compressed pids1)
 196                    (compressed-port 'xz (open-bytevector-input-port data)))
 197                   ((decompressed pids2)
 198                    (decompressed-port 'xz compressed)))
 199       (and (every (compose zero? cdr waitpid)
 200                   (append pids1 pids2))
 201            (equal? (get-bytevector-all decompressed) data)))))
 202
 203 (false-if-exception (delete-file temp-file))
 204 (test-assert "compressed-output-port + decompressed-port"
 205   (let* ((file (search-path %load-path "guix/derivations.scm"))
 206          (data (call-with-input-file file get-bytevector-all))
 207          (port (open-file temp-file "w0b")))
 208     (call-with-compressed-output-port 'xz port
 209       (lambda (compressed)
 210         (put-bytevector compressed data)))
 211     (close-port port)
 212
 213     (bytevector=? data
 214                   (call-with-decompressed-port 'xz (open-file temp-file "r0b")
 215                     get-bytevector-all))))
 216
 217 (false-if-exception (delete-file temp-file))
 218 (test-equal "fcntl-flock wait"
 219   42                                              ; the child's exit status
 220   (let ((file (open-file temp-file "w0b")))
 221     ;; Acquire an exclusive lock.
 222     (fcntl-flock file 'write-lock)
 223     (match (primitive-fork)
 224       (0
 225        (dynamic-wind
 226          (const #t)
 227          (lambda ()
 228            ;; Reopen FILE read-only so we can have a read lock.
 229            (let ((file (open-file temp-file "r0b")))
 230              ;; Wait until we can acquire the lock.
 231              (fcntl-flock file 'read-lock)
 232              (primitive-exit (read file)))
 233            (primitive-exit 1))
 234          (lambda ()
 235            (primitive-exit 2))))
 236       (pid
 237        ;; Write garbage and wait.
 238        (display "hello, world!"  file)
 239        (force-output file)
 240        (sleep 1)
 241
 242        ;; Write the real answer.
 243        (seek file 0 SEEK_SET)
 244        (truncate-file file 0)
 245        (write 42 file)
 246        (force-output file)
 247
 248        ;; Unlock, which should let the child continue.
 249        (fcntl-flock file 'unlock)
 250
 251        (match (waitpid pid)
 252          ((_  . status)
 253           (let ((result (status:exit-val status)))
 254             (close-port file)
 255             result)))))))
 256
 257 (test-equal "fcntl-flock non-blocking"
 258   EAGAIN                                          ; the child's exit status
 259   (match (pipe)
 260     ((input . output)
 261      (match (primitive-fork)
 262        (0
 263         (dynamic-wind
 264           (const #t)
 265           (lambda ()
 266             (close-port output)
 267
 268             ;; Wait for the green light.
 269             (read-char input)
 270
 271             ;; Open FILE read-only so we can have a read lock.
 272             (let ((file (open-file temp-file "w0")))
 273               (catch 'flock-error
 274                 (lambda ()
 275                   ;; This attempt should throw EAGAIN.
 276                   (fcntl-flock file 'write-lock #:wait? #f))
 277                 (lambda (key errno)
 278                   (primitive-exit (pk 'errno errno)))))
 279             (primitive-exit -1))
 280           (lambda ()
 281             (primitive-exit -2))))
 282        (pid
 283         (close-port input)
 284         (let ((file (open-file temp-file "w0")))
 285           ;; Acquire an exclusive lock.
 286           (fcntl-flock file 'write-lock)
 287
 288           ;; Tell the child to continue.
 289           (write 'green-light output)
 290           (force-output output)
 291
 292           (match (waitpid pid)
 293             ((_  . status)
 294              (let ((result (status:exit-val status)))
 295                (fcntl-flock file 'unlock)
 296                (close-port file)
 297                result)))))))))
 298
 299 ;; This is actually in (guix store).
 300 (test-equal "store-path-package-name"
 301   "bash-4.2-p24"
 302   (store-path-package-name
 303    (string-append (%store-prefix)
 304                   "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
 305
 306 (test-end)
 307
 308 (false-if-exception (delete-file temp-file))
 309
 310 \f
 311 (exit (= (test-runner-fail-count (test-runner-current)) 0))