tests/utils.scm

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