aboutsummaryrefslogtreecommitdiff
path: root/gnu/tests/audio.scm
blob: acb91293e8300c8d9b98e82d92ea61f12160534c (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
;;; Copyright © 2022 Bruno Victal <mirai@makinata.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu tests audio)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services audio)
  #:use-module (gnu services networking)
  #:use-module (gnu packages mpd)
  #:use-module (guix gexp)
  #:export (%test-mpd
            %test-mympd))

(define %mpd-os
  (simple-operating-system
   (service mpd-service-type)))

(define (run-mpd-test)
  "Run tests in %mpd-os, which has mpd running."
  (define os
    (marionette-operating-system
     %mpd-os
     #:imported-modules '((gnu services herd))))

  (define vm
    (virtual-machine os))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (gnu build marionette))
          (define marionette
            (make-marionette (list #$vm)))

          (test-runner-current (system-test-runner #$output))
          (test-begin "mpd")

          (test-assert "service is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'mpd))
             marionette))

          (test-assert "mpd listening"
            ;; Wait until mpd is actually listening before spawning 'mpc'.
            (wait-for-tcp-port 6600 marionette))

          (test-equal "mpc connect"
            0
            (marionette-eval
             '(system* #$(file-append mpd-mpc "/bin/mpc"))
             marionette))

          (test-end))))
  (gexp->derivation "mpd-test" test))

(define %test-mpd
  (system-test
   (name "mpd")
   (description "Test that the mpd can run and be connected to.")
   (value (run-mpd-test))))

(define (run-mympd-test)
  (define os (marionette-operating-system
              (simple-operating-system (service dhcp-client-service-type)
                                       (service mympd-service-type))
              #:imported-modules '((gnu services herd))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8080 . 80)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-64)
                       (srfi srfi-8)
                       (web client)
                       (web response)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (test-runner-current (system-test-runner #$output))
          (test-begin "mympd")
          (test-assert "service is running"
            (marionette-eval '(begin
                                (use-modules (gnu services herd))

                                (start-service 'mympd))
                             marionette))

          (test-assert "HTTP port ready"
            (wait-for-tcp-port 80 marionette))

          (test-equal "http-head"
            200
            (receive (x _) (http-head "http://localhost:8080") (response-code x)))

          (test-end))))
  (gexp->derivation "mympd-test" test))

(define %test-mympd
  (system-test
   (name "mympd")
   (description "Connect to a running myMPD service.")
   (value (run-mympd-test))))
(set! n 'a) (and (equal? (foo-bar x) 1) (eq? (foo-baz x) 'a) (begin (set! m 777) (equal? (foo-bar y) 1)) ;promise was already forced (eq? (foo-baz y) 'b))))) (test-assert "define-record-type* & sanitize" (begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default "bar") (sanitize (lambda (x) (string-append x "!"))))) (let* ((p (foo)) (q (foo (inherit p))) (r (foo (inherit p) (bar "baz"))) (s (foo (bar "baz")))) (and (string=? (foo-bar p) "bar!") (equal? q p) (string=? (foo-bar r) "baz!") (equal? s r))))) (test-equal "define-record-type* & sanitize without default value" 42 (begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (sanitize 1+))) (foo-bar (foo (bar 41))))) (test-assert "define-record-type* & sanitize & thunked" (let ((sanitized 0)) (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default "bar") (sanitize (lambda (x) (set! sanitized (+ 1 sanitized)) (string-append x "!"))))) (let ((p (foo))) (and (string=? (foo-bar p) "bar!") (string=? (foo-bar p) "bar!") ;twice (= sanitized 1) ;sanitizer was called at init time only (let ((q (foo (bar "baz")))) (and (string=? (foo-bar q) "baz!") (string=? (foo-bar q) "baz!") ;twice (= sanitized 2) (let ((r (foo (inherit q)))) (and (string=? (foo-bar r) "baz!") (= sanitized 2))))))))) ;no re-sanitization (test-assert "define-record-type* & wrong field specifier" (let ((exp '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo (baz 1 2 3 4 5)))) ;syntax error (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form subform . _) (and (eq? proc 'foo) (string-match "invalid field" message) (equal? subform '(baz 1 2 3 4 5)) (equal? form '(foo (baz 1 2 3 4 5))) ;; Make sure the location is that of the field specifier. ;; See <http://bugs.gnu.org/23969>. (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 1)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "define-record-type* & wrong field specifier, identifier" (let ((exp '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo baz))) ;syntax error (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form subform . _) (and (eq? proc 'foo) (string-match "invalid field" message) (equal? subform 'baz) (equal? form '(foo baz)) ;; Here the location is that of the parent form. (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 2)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "define-record-type* & missing initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo)) (test-module)) #f) (lambda (key proc message location form . args) (and (eq? proc 'foo) (string-match "missing .*initialize.*baz" message) (equal? form '(foo)))))) (test-assert "define-record-type* & extra initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42))) (foo (baz 'what?))) (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) (test-assert "define-record-type* & inherit & extra initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42))) (foo (inherit (foo)) (baz 'what?))) (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) (test-assert "define-record-type* & duplicate initializers" (let ((exp '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42))) (foo (bar 1) (bar 2)))) (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "duplicate.*initializer" message) (eq? proc 'foo) ;; Make sure the location is that of the field specifier. (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 1)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "ABI checks" (let ((module (test-module))) (eval '(begin (define-record-type* <foo> foo make-foo foo? (bar foo-bar (default 42))) (define (make-me-a-record) (foo))) module) (unless (eval '(foo? (make-me-a-record)) module) (error "what?" (eval '(make-me-a-record) module))) ;; Redefine <foo> with an additional field. (eval '(define-record-type* <foo> foo make-foo foo? (baz foo-baz) (bar foo-bar (default 42))) module) ;; Now 'make-me-a-record' is out of sync because it does an ;; 'allocate-struct' that corresponds to the previous definition of <foo>. (catch 'record-abi-mismatch-error (lambda () (eval '(foo? (make-me-a-record)) module) #f) (match-lambda* ((key 'abi-check (? string? message) (rtd) . _) (eq? rtd (eval '<foo> module))))))) (test-equal "recutils->alist" '((("Name" . "foo") ("Version" . "0.1") ("Synopsis" . "foo bar") ("Something_else" . "chbouib")) (("Name" . "bar") ("Version" . "1.5"))) (let ((p (open-input-string " # Comment following an empty line, and # preceding a couple of empty lines, all of # which should be silently consumed. Name: foo Version: 0.1 # Comment right in the middle, # spanning two lines. Synopsis: foo bar Something_else: chbouib # Comment right before. Name: bar Version: 1.5 # Comment at the end."))) (list (recutils->alist p) (recutils->alist p)))) (test-equal "recutils->alist with + lines" '(("Name" . "foo") ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space.")) (recutils->alist (open-input-string " Name: foo Description: 1st line, + 2nd line, + 3rd line with extra space, +4th line without space."))) (test-equal "alist->record" '((1 2) b c) (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2)) list '("a" "b" "c") '("a"))) (test-equal "match-record, simple" '((1 2) (a b)) (let () (define-record-type* <foo> foo make-foo foo? (first foo-first (default 1)) (second foo-second)) (list (match-record (foo (second 2)) <foo> (first second) (list first second)) (match-record (foo (first 'a) (second 'b)) <foo> (second (first first/new-var)) (list first/new-var second))))) (test-equal "match-record, unknown field" 'syntax-error (catch 'syntax-error (lambda () (eval '(begin (use-modules (guix records)) (define-record-type* <foo> foo make-foo foo? (first foo-first (default 1)) (second foo-second)) (match-record (foo (second 2)) <foo> (one two) #f)) (make-fresh-user-module))) (lambda (key . args) key))) (test-equal "match-record, delayed field" "foo bar bar foo" (begin (define-record-type* <with-delayed> with-delayed make-with-delayed with-delayed? (delayed with-delayed-delayed (delayed))) (let ((rec (with-delayed (delayed "foo bar bar foo")))) (match-record rec <with-delayed> (delayed) delayed)))) (test-equal "match-record, thunked field" '("foo" "foobar") (begin (define-record-type* <with-thunked> with-thunked make-with-thunked with-thunked? (normal with-thunked-normal) (thunked with-thunked-thunked (thunked))) (let ((rec (with-thunked (normal "foo") (thunked (string-append (with-thunked-normal this-record) "bar"))))) (match-record rec <with-thunked> (normal thunked) (list normal thunked))))) (test-equal "match-record, ellipsis in body" #t (begin (define-record-type* <foo> foo make-foo foo? (value foo-value)) (define bar (foo (value '(1 2 3)))) (match-record bar <foo> (value) (match value ((one two ...) #t) (_ #f))))) (test-equal "match-record-lambda" '("thing: foo" "thing: bar") (begin (define-record-type* <with-text> with-text make-with-text with-text? (text with-text-text)) (map (match-record-lambda <with-text> (text) (string-append "thing: " text)) (list (with-text (text "foo")) (with-text (text "bar")))))) (test-end)