diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/build-emacs-utils.scm | 7 | ||||
| -rw-r--r-- | tests/graph.scm | 24 | ||||
| -rw-r--r-- | tests/guix-home.sh | 8 | ||||
| -rw-r--r-- | tests/inferior.scm | 39 | ||||
| -rw-r--r-- | tests/monads.scm | 15 | ||||
| -rw-r--r-- | tests/profiles.scm | 80 | ||||
| -rw-r--r-- | tests/records.scm | 12 | ||||
| -rw-r--r-- | tests/services/telephony.scm | 391 | ||||
| -rw-r--r-- | tests/style.scm | 19 |
9 files changed, 185 insertions, 410 deletions
diff --git a/tests/build-emacs-utils.scm b/tests/build-emacs-utils.scm index 081032285a..4e851ed959 100644 --- a/tests/build-emacs-utils.scm +++ b/tests/build-emacs-utils.scm @@ -23,6 +23,7 @@ #:use-module (guix build utils) #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (ice-9 regex) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) @@ -36,8 +37,10 @@ (test-assert "emacs-batch-script: raise &emacs-batch-error on failure" (guard (c ((emacs-batch-error? c) - (string-contains (emacs-batch-error-message c) - "Lisp error: (wrong-type-argument numberp \"three\")"))) + ;; The error message format changed between Emacs 27 and Emacs + ;; 28. + (string-match "[Ww]rong.*argument.*numberp.*\"three\"" + (emacs-batch-error-message c)))) (emacs-batch-script '(mapcar 'number-to-string (list 1 2 "three"))))) (call-with-temporary-directory diff --git a/tests/graph.scm b/tests/graph.scm index baa08a6be2..6aa2d0e0ff 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -244,10 +244,10 @@ edges." edges))))))))) (test-assert "reverse bag DAG" - (let-values (((dune bap ocaml-base) - (values (specification->package "ocaml4.07-dune") - (specification->package "bap") - (specification->package "ocaml4.07-base"))) + (let-values (((dune camomile utop) + (values (specification->package "dune") + (specification->package "ocaml-camomile") + (specification->package "ocaml-utop"))) ((backend nodes+edges) (make-recording-backend))) (run-with-store %store (export-graph (list dune) 'port @@ -256,17 +256,17 @@ edges." (run-with-store %store (mlet %store-monad ((dune-drv (package->derivation dune)) - (bap-drv (package->derivation bap)) - (ocaml-base-drv (package->derivation ocaml-base))) - ;; OCAML-BASE uses 'dune-build-system' so DUNE is a direct dependency. - ;; BAP is much higher in the stack but it should be there. + (camomile-drv (package->derivation camomile)) + (utop-drv (package->derivation utop))) + ;; CAMOMILE uses 'dune-build-system' so DUNE is a direct dependency. + ;; UTOP is much higher in the stack but it should be there. (let-values (((nodes edges) (nodes+edges))) (return - (and (member `(,(derivation-file-name bap-drv) - ,(package-full-name bap)) + (and (member `(,(derivation-file-name camomile-drv) + ,(package-full-name camomile)) nodes) (->bool (member (map derivation-file-name - (list dune-drv ocaml-base-drv)) + (list dune-drv utop-drv)) edges))))))))) (test-assert "derivation DAG" diff --git a/tests/guix-home.sh b/tests/guix-home.sh index 8a7048a9ca..1d1acbfd6e 100644 --- a/tests/guix-home.sh +++ b/tests/guix-home.sh @@ -79,9 +79,15 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT (guix-defaults? #t) (bashrc (list (local-file "dot-bashrc"))))) + (simple-service 'add-environment-variable + home-environment-variables-service-type + '(("TODAY" . "26 messidor"))) + (simple-service 'home-bash-service-extension-test home-bash-service-type (home-bash-extension + (environment-variables + '(("PS1" . "$GUIX_ENVIRONMENT λ "))) (bashrc (list (plain-file @@ -138,6 +144,8 @@ EOF # dot-bashrc test file for guix home # the content of bashrc-test-config.sh" grep -q "the content of ~/.config/test.conf" "${HOME}/.config/test.conf" + grep '^export PS1="\$GUIX_ENVIRONMENT λ "$' "${HOME}/.bash_profile" + ( . "${HOME}/.guix-home/setup-environment"; test "$TODAY" = "26 messidor" ) # This one should still be here. grep "stay around" "$HOME/.config/random-file" diff --git a/tests/inferior.scm b/tests/inferior.scm index 56b2fcb7bc..963d405e33 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -30,7 +30,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) - #:use-module (ice-9 match)) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -315,4 +316,40 @@ (close-inferior inferior) (map manifest-entry->list (manifest-entries manifest)))) +(test-equal "#:error-port stderr" + 42 + ;; There's a special case in open-bidirectional-pipe for + ;; (current-error-port) being stderr, so this test just checks that + ;; open-inferior doesn't raise an exception + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix" + #:error-port (current-error-port)))) + (and (inferior? inferior) + (inferior-eval '(display "test" (current-error-port)) inferior) + (let ((result (inferior-eval '(apply * '(6 7)) inferior))) + (close-inferior inferior) + result)))) + +(test-equal "#:error-port pipe" + "42" + (match (pipe) + ((port-to-read-from . port-to-write-to) + + (setvbuf port-to-read-from 'line) + (setvbuf port-to-write-to 'line) + + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix" + #:error-port port-to-write-to))) + (and (inferior? inferior) + (begin + (inferior-eval '(display "42\n" (current-error-port)) inferior) + + (let loop ((line (read-line port-to-read-from))) + (if (string=? line "42") + (begin + (close-inferior inferior) + line) + (loop (read-line port-to-read-from)))))))))) + (test-end "inferior") diff --git a/tests/monads.scm b/tests/monads.scm index 18bf4119be..19b74f4fb9 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -137,6 +137,19 @@ %monads %monad-run)) +(test-assert "mparameterize" + (let ((parameter (make-parameter 'outside))) + (every (lambda (monad run) + (equal? + (run (mlet monad ((outer (return (parameter))) + (inner + (mparameterize monad ((parameter 'inside)) + (return (parameter))))) + (return (list outer inner (parameter))))) + '(outside inside outside))) + %monads + %monad-run))) + (test-assert "mlet* + text-file + package-file" (run-with-store %store (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) diff --git a/tests/profiles.scm b/tests/profiles.scm index 7418b7470f..7bed946bf3 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -286,6 +286,34 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "profile-derivation format version 3" + ;; Make sure we can create and read a version 3 manifest. + (mlet* %store-monad + ((entry -> (package->manifest-entry %bootstrap-guile + #:properties '((answer . 42)))) + (manifest -> (manifest (list entry))) + (drv1 (profile-derivation manifest + #:format-version 3 ;old version + #:hooks '() + #:locales? #f)) + (drv2 (profile-derivation manifest + #:hooks '() + #:locales? #f)) + (profile1 -> (derivation->output-path drv1)) + (profile2 -> (derivation->output-path drv2)) + (_ (built-derivations (list drv1 drv2)))) + (return (let ((manifest1 (profile-manifest profile1)) + (manifest2 (profile-manifest profile2))) + (match (manifest-entries manifest1) + ((entry1) + (match (manifest-entries manifest2) + ((entry2) + (and (manifest-entry=? entry1 entry2) + (equal? (manifest-entry-properties entry1) + '((answer . 42))) + (equal? (manifest-entry-properties entry2) + '((answer . 42)))))))))))) + (test-assertm "profile-derivation, ordering & collisions" ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure ;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>. @@ -556,14 +584,20 @@ (return #f))))) (test-equal "collision of propagated inputs" - '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) + '(("guile-bootstrap" "2.0") "p1" + <> ("guile-bootstrap" "42") "p2") (guard (c ((profile-collision-error? c) (let ((entry1 (profile-collision-error-entry c)) (entry2 (profile-collision-error-conflict c))) (list (list (manifest-entry-name entry1) (manifest-entry-version entry1)) + (manifest-entry-name + (force (manifest-entry-parent entry1))) + '<> (list (manifest-entry-name entry2) - (manifest-entry-version entry2)))))) + (manifest-entry-version entry2)) + (manifest-entry-name + (force (manifest-entry-parent entry2))))))) (run-with-store %store (mlet* %store-monad ((p0 -> (package (inherit %bootstrap-guile) @@ -580,6 +614,48 @@ #:locales? #f))) (return #f))))) +(test-assertm "deduplication of repeated entries" + ;; Make sure the 'manifest' file does not duplicate identical entries. + ;; See <https://issues.guix.gnu.org/55499>. + (mlet* %store-monad ((p0 -> (dummy-package "p0" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (mkdir (assoc-ref %outputs "out")))) + (propagated-inputs + `(("guile" ,%bootstrap-guile))))) + (p1 -> (package + (inherit p0) + (name "p1"))) + (drv (profile-derivation (packages->manifest + (list p0 p1)) + #:hooks '() + #:locales? #f))) + (mbegin %store-monad + (built-derivations (list drv)) + (let ((file (string-append (derivation->output-path drv) + "/manifest")) + (manifest (profile-manifest (derivation->output-path drv)))) + (define (contains-repeated? sexp) + (match sexp + (('repeated _ ...) #t) + ((lst ...) (any contains-repeated? sexp)) + (_ #f))) + + (return (and (contains-repeated? (call-with-input-file file read)) + + ;; MANIFEST has two entries for %BOOTSTRAP-GUILE since + ;; it's propagated both from P0 and from P1. When + ;; reading a 'repeated' node, 'read-manifest' should + ;; reuse the previously-read entry so the two + ;; %BOOTSTRAP-GUILE entries must be 'eq?'. + (match (manifest-entries manifest) + (((= manifest-entry-dependencies (dep0)) + (= manifest-entry-dependencies (dep1))) + (and (string=? (manifest-entry-name dep0) + (package-name %bootstrap-guile)) + (eq? dep0 dep1)))))))))) + (test-assertm "no collision" ;; Here we have an entry that is "lowered" (its 'item' field is a store file ;; name) and another entry (its 'item' field is a package) that is diff --git a/tests/records.scm b/tests/records.scm index d014e7a995..00c58b0736 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -300,6 +300,15 @@ (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 @@ -321,6 +330,7 @@ (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 diff --git a/tests/services/telephony.scm b/tests/services/telephony.scm index b4a0f120d4..52c2a63cd6 100644 --- a/tests/services/telephony.scm +++ b/tests/services/telephony.scm @@ -25,400 +25,9 @@ (test-begin "jami-service") -(define parse-dbus-reply - (@@ (gnu build jami-service) parse-dbus-reply)) - -(define parse-account-ids - (@@ (gnu build jami-service) parse-account-ids)) - -(define parse-account-details - (@@ (gnu build jami-service) parse-account-details)) - -(define parse-contacts - (@@ (gnu build jami-service) parse-contacts)) - (define jami-account->alist (@@ (gnu services telephony) jami-account->alist)) -;; $ dbus-send --print-reply --dest="cx.ring.Ring" \ -;; "/cx/ring/Ring/ConfigurationManager" \ -;; "cx.ring.Ring.ConfigurationManager.getAccountList" -(define getAccountList-reply "\ -method return time=1622217253.386711 sender=:1.7 -> destination=:1.14 serial=140 reply_serial=2 - array [ - string \"addf37fbb558d6a0\" - string \"d5cbeb7d08c98a65\" - string \"398af0c6b74ce101\" - ] -") - -(test-equal "parse-account-ids" - '("addf37fbb558d6a0" "d5cbeb7d08c98a65" "398af0c6b74ce101") - (parse-account-ids getAccountList-reply)) - -;; $ dbus-send --print-reply --dest="cx.ring.Ring" \ -;; "/cx/ring/Ring/ConfigurationManager" \ -;; "cx.ring.Ring.ConfigurationManager.getAccountDetails" \ -;; 'string:398af0c6b74ce101' -(define getAccountDetails-reply "\ -method return time=1622254991.789588 sender=:1.7 -> destination=:1.19 serial=145 reply_serial=2 - array [ - dict entry( - string \"Account.accountDiscovery\" - string \"false\" - ) - dict entry( - string \"Account.accountPublish\" - string \"false\" - ) - dict entry( - string \"Account.activeCallLimit\" - string \"-1\" - ) - dict entry( - string \"Account.alias\" - string \"some-rendezvous-point-name\" - ) - dict entry( - string \"Account.allModeratorEnabled\" - string \"true\" - ) - dict entry( - string \"Account.allowCertFromContact\" - string \"true\" - ) - dict entry( - string \"Account.allowCertFromHistory\" - string \"true\" - ) - dict entry( - string \"Account.allowCertFromTrusted\" - string \"true\" - ) - dict entry( - string \"Account.archiveHasPassword\" - string \"false\" - ) - dict entry( - string \"Account.audioPortMax\" - string \"32766\" - ) - dict entry( - string \"Account.audioPortMin\" - string \"16384\" - ) - dict entry( - string \"Account.autoAnswer\" - string \"false\" - ) - dict entry( - string \"Account.defaultModerators\" - string \"\" - ) - dict entry( - string \"Account.deviceID\" - string \"94b4070fc7a8afa8482c777a9822c52e6af2e1bd\" - ) - dict entry( - string \"Account.deviceName\" - string \"some-device\" - ) - dict entry( - string \"Account.dhtProxyListUrl\" - string \"https://config.jami.net/proxyList\" - ) - dict entry( - string \"Account.displayName\" - string \"some-rendezvous-point-name\" - ) - dict entry( - string \"Account.dtmfType\" - string \"overrtp\" - ) - dict entry( - string \"Account.enable\" - string \"true\" - ) - dict entry( - string \"Account.hasCustomUserAgent\" - string \"false\" - ) - dict entry( - string \"Account.hostname\" - string \"bootstrap.jami.net\" - ) - dict entry( - string \"Account.localInterface\" - string \"default\" - ) - dict entry( - string \"Account.localModeratorsEnabled\" - string \"true\" - ) - dict entry( - string \"Account.mailbox\" - string \"\" - ) - dict entry( - string \"Account.managerUri\" - string \"\" - ) - dict entry( - string \"Account.managerUsername\" - string \"\" - ) - dict entry( - string \"Account.peerDiscovery\" - string \"false\" - ) - dict entry( - string \"Account.presenceSubscribeSupported\" - string \"true\" - ) - dict entry( - string \"Account.proxyEnabled\" - string \"false\" - ) - dict entry( - string \"Account.proxyPushToken\" - string \"\" - ) - dict entry( - string \"Account.proxyServer\" - string \"dhtproxy.jami.net:[80-95]\" - ) - dict entry( - string \"Account.publishedAddress\" - string \"\" - ) - dict entry( - string \"Account.publishedPort\" - string \"5060\" - ) - dict entry( - string \"Account.publishedSameAsLocal\" - string \"true\" - ) - dict entry( - string \"Account.rendezVous\" - string \"true\" - ) - dict entry( - string \"Account.ringtoneEnabled\" - string \"true\" - ) - dict entry( - string \"Account.ringtonePath\" - string \"/usr/share/ring/ringtones/default.opus\" - ) - dict entry( - string \"Account.type\" - string \"RING\" - ) - dict entry( - string \"Account.upnpEnabled\" - string \"true\" - ) - dict entry( - string \"Account.useragent\" - string \"\" - ) - dict entry( - string \"Account.username\" - string \"ccb8bbe2382343f7feb140710ab48aaf1b55634e\" - ) - dict entry( - string \"Account.videoEnabled\" - string \"true\" - ) - dict entry( - string \"Account.videoPortMax\" - string \"65534\" - ) - dict entry( - string \"Account.videoPortMin\" - string \"49152\" - ) - dict entry( - string \"DHT.PublicInCalls\" - string \"true\" - ) - dict entry( - string \"DHT.port\" - string \"7766\" - ) - dict entry( - string \"RingNS.account\" - string \"3989b55313a911b6f0c004748b49b254f35c9ef6\" - ) - dict entry( - string \"RingNS.uri\" - string \"\" - ) - dict entry( - string \"SRTP.enable\" - string \"true\" - ) - dict entry( - string \"SRTP.keyExchange\" - string \"sdes\" - ) - dict entry( - string \"SRTP.rtpFallback\" - string \"false\" - ) - dict entry( - string \"STUN.enable\" - string \"false\" - ) - dict entry( - string \"STUN.server\" - string \"\" - ) - dict entry( - string \"TLS.certificateFile\" - string \"/var/lib/jami/.local/share/jami/398af0c6b74ce101/ring_device.crt\" - ) - dict entry( - string \"TLS.certificateListFile\" - string \"\" - ) - dict entry( - string \"TLS.ciphers\" - string \"\" - ) - dict entry( - string \"TLS.method\" - string \"Automatic\" - ) - dict entry( - string \"TLS.negotiationTimeoutSec\" - string \"-1\" - ) - dict entry( - string \"TLS.password\" - string \"\" - ) - dict entry( - string \"TLS.privateKeyFile\" - string \"/var/lib/jami/.local/share/jami/398af0c6b74ce101/ring_device.key\" - ) - dict entry( - string \"TLS.requireClientCertificate\" - string \"true\" - ) - dict entry( - string \"TLS.serverName\" - string \"\" - ) - dict entry( - string \"TLS.verifyClient\" - string \"true\" - ) - dict entry( - string \"TLS.verifyServer\" - string \"true\" - ) - dict entry( - string \"TURN.enable\" - string \"true\" - ) - dict entry( - string \"TURN.password\" - string \"ring\" - ) - dict entry( - string \"TURN.realm\" - string \"ring\" - ) - dict entry( - string \"TURN.server\" - string \"turn.jami.net\" - ) - dict entry( - string \"TURN.username\" - string \"ring\" - ) - ] -") - -(test-equal "parse-account-details; username, alias and display name" - '("ccb8bbe2382343f7feb140710ab48aaf1b55634e" ;username - "some-rendezvous-point-name" ;alias - "some-rendezvous-point-name") ;displayName - (let ((account-details (parse-account-details getAccountDetails-reply))) - (list (assoc-ref account-details "Account.username") - (assoc-ref account-details "Account.alias") - (assoc-ref account-details "Account.displayName")))) - -(define getContacts-reply "\ -method return time=1627014042.752673 sender=:1.113 -> destination=:1.186 serial=220 reply_serial=2 - array [ - array [ - dict entry( - string \"added\" - string \"1578883327\" - ) - dict entry( - string \"confirmed\" - string \"true\" - ) - dict entry( - string \"id\" - string \"1c7d5a09464223442549fef172a3cf6f4de9b01c\" - ) - ] - array [ - dict entry( - string \"added\" - string \"1623107941\" - ) - dict entry( - string \"confirmed\" - string \"true\" - ) - dict entry( - string \"id\" - string \"5903c6c9ac5cb863c64e559add3d5d1c8c563449\" - ) - ] - array [ - dict entry( - string \"added\" - string \"1595996256\" - ) - dict entry( - string \"confirmed\" - string \"true\" - ) - dict entry( - string \"id\" - string \"ff2d72a548693214fb3a0f0f7a943b5e2bb9be03\" - ) - ] - ]") - -(test-equal "parse-account-contacts" - '((("added" . "1578883327") - ("confirmed" . "true") - ("id" . "1c7d5a09464223442549fef172a3cf6f4de9b01c")) - (("added" . "1623107941") - ("confirmed" . "true") - ("id" . "5903c6c9ac5cb863c64e559add3d5d1c8c563449")) - (("added" . "1595996256") - ("confirmed" . "true") - ("id" . "ff2d72a548693214fb3a0f0f7a943b5e2bb9be03"))) - (parse-contacts getContacts-reply)) - -(define getContacts-empty-reply "\ -method return time=1627400787.873988 sender=:1.1197 -> destination=:1.1463 serial=2127 reply_serial=2 - array [ - ]") - -(test-equal "parse-account-contacts, empty array" - '() - (parse-contacts getContacts-empty-reply)) - (define %dummy-jami-account (jami-account (archive "/tmp/dummy.gz"))) diff --git a/tests/style.scm b/tests/style.scm index 48d975df94..55bad2b3ba 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -504,6 +504,25 @@ mnopqrstuvwxyz.\")" #:make-flags #~'(\"ANSWER=42\") #:tests? #f)))") +(test-pretty-print "\ +(let ((x 1) + (y 2) + (z (let* ((a 3) + (b 4)) + (+ a b)))) + (list x y z))") + +(test-pretty-print "\ +(substitute-keyword-arguments (package-arguments x) + ((#:phases phases) + `(modify-phases ,phases + (add-before 'build 'do-things + (lambda _ + #t)))) + ((#:configure-flags flags) + `(cons \"--without-any-problem\" + ,flags)))") + (test-equal "pretty-print-with-comments, canonicalize-comment" "\ (list abc |