aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/cpan.scm11
-rw-r--r--tests/gexp.scm100
-rw-r--r--tests/grafts.scm16
-rw-r--r--tests/lint.scm52
-rw-r--r--tests/packages.scm1
-rw-r--r--tests/publish.scm59
-rw-r--r--tests/records.scm29
-rw-r--r--tests/system.scm43
-rw-r--r--tests/zlib.scm63
9 files changed, 324 insertions, 50 deletions
diff --git a/tests/cpan.scm b/tests/cpan.scm
index 5d56f0bd2b..898081b3e5 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -97,4 +98,14 @@
(x
(pk 'fail x #f)))))
+(test-equal "source-url-http"
+ ((@@ (guix import cpan) fix-source-url)
+ "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+ "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+
+(test-equal "source-url-https"
+ ((@@ (guix import cpan) fix-source-url)
+ "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+ "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+
(test-end "cpan")
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f44f0eaf9a..03a64fa6bb 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -526,6 +526,18 @@
get-bytevector-all))))
files))))))
+(test-equal "gexp-modules & ungexp"
+ '((bar) (foo))
+ ((@@ (guix gexp) gexp-modules)
+ #~(foo #$(with-imported-modules '((foo)) #~+)
+ #+(with-imported-modules '((bar)) #~-))))
+
+(test-equal "gexp-modules & ungexp-splicing"
+ '((foo) (bar))
+ ((@@ (guix gexp) gexp-modules)
+ #~(foo #$@(list (with-imported-modules '((foo)) #~+)
+ (with-imported-modules '((bar)) #~-)))))
+
(test-assertm "gexp->derivation #:modules"
(mlet* %store-monad
((build -> #~(begin
@@ -540,31 +552,75 @@
(s (stat (string-append p "/guile/guix/nix"))))
(return (eq? (stat:type s) 'directory))))))
+(test-assertm "gexp->derivation & with-imported-modules"
+ ;; Same test as above, but using 'with-imported-modules'.
+ (mlet* %store-monad
+ ((build -> (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p (string-append #$output "/guile/guix/nix"))
+ #t)))
+ (drv (gexp->derivation "test-with-modules" build)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((p (derivation->output-path drv))
+ (s (stat (string-append p "/guile/guix/nix"))))
+ (return (eq? (stat:type s) 'directory))))))
+
+(test-assertm "gexp->derivation & nested with-imported-modules"
+ (mlet* %store-monad
+ ((build1 -> (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p (string-append #$output "/guile/guix/nix"))
+ #t)))
+ (build2 -> (with-imported-modules '((guix build bournish))
+ #~(begin
+ (use-modules (guix build bournish)
+ (system base compile))
+ #+build1
+ (call-with-output-file (string-append #$output "/b")
+ (lambda (port)
+ (write
+ (read-and-compile (open-input-string "cd /foo")
+ #:from %bournish-language
+ #:to 'scheme)
+ port))))))
+ (drv (gexp->derivation "test-with-modules" build2)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((p (derivation->output-path drv))
+ (s (stat (string-append p "/guile/guix/nix")))
+ (b (string-append p "/b")))
+ (return (and (eq? (stat:type s) 'directory)
+ (equal? '(chdir "/foo")
+ (call-with-input-file b read))))))))
+
(test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad
((one (text-file "one" (random-text)))
(two (gexp->derivation "two"
#~(symlink #$one #$output:chbouib)))
- (drv (gexp->derivation "ref-graphs"
- #~(begin
- (use-modules (guix build store-copy))
- (with-output-to-file #$output
- (lambda ()
- (write (call-with-input-file "guile"
- read-reference-graph))))
- (with-output-to-file #$output:one
- (lambda ()
- (write (call-with-input-file "one"
- read-reference-graph))))
- (with-output-to-file #$output:two
- (lambda ()
- (write (call-with-input-file "two"
- read-reference-graph)))))
+ (build -> (with-imported-modules '((guix build store-copy)
+ (guix build utils))
+ #~(begin
+ (use-modules (guix build store-copy))
+ (with-output-to-file #$output
+ (lambda ()
+ (write (call-with-input-file "guile"
+ read-reference-graph))))
+ (with-output-to-file #$output:one
+ (lambda ()
+ (write (call-with-input-file "one"
+ read-reference-graph))))
+ (with-output-to-file #$output:two
+ (lambda ()
+ (write (call-with-input-file "two"
+ read-reference-graph)))))))
+ (drv (gexp->derivation "ref-graphs" build
#:references-graphs `(("one" ,one)
("two" ,two "chbouib")
- ("guile" ,%bootstrap-guile))
- #:modules '((guix build store-copy)
- (guix build utils))))
+ ("guile" ,%bootstrap-guile))))
(ok? (built-derivations (list drv)))
(guile-drv (package->derivation %bootstrap-guile))
(bash (interned-file (search-bootstrap-binary "bash"
@@ -676,11 +732,11 @@
(test-assertm "program-file"
(let* ((n (random (expt 2 50)))
- (exp (gexp (begin
- (use-modules (guix build utils))
- (display (ungexp n)))))
+ (exp (with-imported-modules '((guix build utils))
+ (gexp (begin
+ (use-modules (guix build utils))
+ (display (ungexp n))))))
(file (program-file "program" exp
- #:modules '((guix build utils))
#:guile %bootstrap-guile)))
(mlet* %store-monad ((drv (lower-object file))
(out -> (derivation->output-path drv)))
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 8cd048552c..13c56750ed 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -135,14 +135,14 @@
(replacement fake)))
(drv (gexp->derivation
"to-graft"
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p (string-append #$output
- "/a/b/c/d"))
- (symlink #$%bash
- (string-append #$output
- "/bash")))
- #:modules '((guix build utils))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p (string-append #$output
+ "/a/b/c/d"))
+ (symlink #$%bash
+ (string-append #$output
+ "/bash"))))))
(grafted ((store-lift graft-derivation) drv
(list graft)))
(_ (built-derivations (list grafted)))
diff --git a/tests/lint.scm b/tests/lint.scm
index 1f1b0c95e9..ce751c42c9 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -102,14 +102,14 @@
http-write
(@@ (web server http) http-close))
-(define (call-with-http-server code thunk)
- "Call THUNK with an HTTP server running and returning CODE on HTTP
-requests."
+(define (call-with-http-server code data thunk)
+ "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
(define (server-body)
(define (handle request body)
(values (build-response #:code code
#:reason-phrase "Such is life")
- "Hello, world."))
+ data))
(catch 'quit
(lambda ()
@@ -123,8 +123,11 @@ requests."
;; Normally SERVER exits automatically once it has received a request.
(thunk))))
-(define-syntax-rule (with-http-server code body ...)
- (call-with-http-server code (lambda () body ...)))
+(define-syntax-rule (with-http-server code data body ...)
+ (call-with-http-server code data (lambda () body ...)))
+
+(define %long-string
+ (make-string 2000 #\a))
(test-begin "lint")
@@ -402,18 +405,30 @@ requests."
(test-equal "home-page: 200"
""
(with-warnings
- (with-http-server 200
+ (with-http-server 200 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page %local-url))))
(check-home-page pkg)))))
(test-skip (if %http-server-socket 0 1))
+(test-assert "home-page: 200 but short length"
+ (->bool
+ (string-contains
+ (with-warnings
+ (with-http-server 200 "This is too small."
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page %local-url))))
+ (check-home-page pkg))))
+ "suspiciously small")))
+
+(test-skip (if %http-server-socket 0 1))
(test-assert "home-page: 404"
(->bool
(string-contains
(with-warnings
- (with-http-server 404
+ (with-http-server 404 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page %local-url))))
@@ -501,7 +516,7 @@ requests."
(test-equal "source: 200"
""
(with-warnings
- (with-http-server 200
+ (with-http-server 200 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -511,11 +526,26 @@ requests."
(check-source pkg)))))
(test-skip (if %http-server-socket 0 1))
+(test-assert "source: 200 but short length"
+ (->bool
+ (string-contains
+ (with-warnings
+ (with-http-server 200 "This is too small."
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (source (origin
+ (method url-fetch)
+ (uri %local-url)
+ (sha256 %null-sha256))))))
+ (check-source pkg))))
+ "suspiciously small")))
+
+(test-skip (if %http-server-socket 0 1))
(test-assert "source: 404"
(->bool
(string-contains
(with-warnings
- (with-http-server 404
+ (with-http-server 404 %long-string
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
@@ -617,6 +647,6 @@ requests."
(test-end "lint")
;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 1)
+;; eval: (put 'with-http-server 'scheme-indent-function 2)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End:
diff --git a/tests/packages.scm b/tests/packages.scm
index 94f5ea71a5..fc75e38730 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -335,7 +335,6 @@
("patch" ,%bootstrap-coreutils&co)))
(patch-guile %bootstrap-guile)
(modules '((guix build utils)))
- (imported-modules modules)
(snippet '(begin
;; We end up in 'bin', because it's the first
;; directory, alphabetically. Not a very good
diff --git a/tests/publish.scm b/tests/publish.scm
index d6d537c58a..9bf181f1fc 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -28,12 +28,15 @@
#:use-module (guix store)
#:use-module (guix base32)
#:use-module (guix base64)
+ #:use-module ((guix records) #:select (recutils->alist))
#:use-module ((guix serialization) #:select (restore-file))
#:use-module (guix pk-crypto)
+ #:use-module (guix zlib)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
@@ -52,20 +55,28 @@
(call-with-values (lambda () (http-get uri))
(lambda (response body) body)))
+(define (http-get-port uri)
+ (call-with-values (lambda () (http-get uri #:streaming? #t))
+ (lambda (response port) port)))
+
(define (publish-uri route)
(string-append "http://localhost:6789" route))
;; Run a local publishing server in a separate thread.
(call-with-new-thread
(lambda ()
- (guix-publish "--port=6789"))) ; attempt to avoid port collision
+ (guix-publish "--port=6789" "-C0"))) ;attempt to avoid port collision
+
+(define (wait-until-ready port)
+ ;; Wait until the server is accepting connections.
+ (let ((conn (socket PF_INET SOCK_STREAM 0)))
+ (let loop ()
+ (unless (false-if-exception
+ (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
+ (loop)))))
-;; Wait until the server is accepting connections.
-(let ((conn (socket PF_INET SOCK_STREAM 0)))
- (let loop ()
- (unless (false-if-exception
- (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789))
- (loop))))
+;; Wait until the two servers are ready.
+(wait-until-ready 6789)
(test-begin "publish")
@@ -145,6 +156,40 @@ References: ~%"
(call-with-input-string nar (cut restore-file <> temp)))
(call-with-input-file temp read-string))))
+(unless (zlib-available?)
+ (test-skip 1))
+(test-equal "/nar/gzip/*"
+ "bar"
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((nar (http-get-port
+ (publish-uri
+ (string-append "/nar/gzip/" (basename %item))))))
+ (call-with-gzip-input-port nar
+ (cut restore-file <> temp)))
+ (call-with-input-file temp read-string))))
+
+(unless (zlib-available?)
+ (test-skip 1))
+(test-equal "/*.narinfo with compression"
+ `(("StorePath" . ,%item)
+ ("URL" . ,(string-append "nar/gzip/" (basename %item)))
+ ("Compression" . "gzip"))
+ (let ((thread (call-with-new-thread
+ (lambda ()
+ (guix-publish "--port=6799" "-C5")))))
+ (wait-until-ready 6799)
+ (let* ((url (string-append "http://localhost:6799/"
+ (store-path-hash-part %item) ".narinfo"))
+ (body (http-get-port url)))
+ (filter (lambda (item)
+ (match item
+ (("Compression" . _) #t)
+ (("StorePath" . _) #t)
+ (("URL" . _) #t)
+ (_ #f)))
+ (recutils->alist body)))))
+
(test-equal "/nar/ with properly encoded '+' sign"
"Congrats!"
(let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
diff --git a/tests/records.scm b/tests/records.scm
index c6f85d4a81..d6d27bb96a 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-records)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -214,6 +215,32 @@
(equal? (foo-bar y) 1)) ;promise was already forced
(eq? (foo-baz y) 'b)))))
+(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 . args)
+ (and (eq? proc 'foo)
+ (string-match "invalid field" message)
+ (equal? form '(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)))))))
+
(test-assert "define-record-type* & missing initializers"
(catch 'syntax-error
(lambda ()
diff --git a/tests/system.scm b/tests/system.scm
index b935bd07eb..b5bb9af016 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -41,6 +41,25 @@
(users %base-user-accounts)))
+(define %luks-device
+ (mapped-device
+ (source "/dev/foo") (target "my-luks-device")
+ (type luks-device-mapping)))
+
+(define %os-with-mapped-device
+ (operating-system
+ (host-name "komputilo")
+ (timezone "Europe/Berlin")
+ (locale "en_US.utf8")
+ (bootloader (grub-configuration (device "/dev/sdX")))
+ (mapped-devices (list %luks-device))
+ (file-systems (cons (file-system
+ (inherit %root-fs)
+ (dependencies (list %luks-device)))
+ %base-file-systems))
+ (users %base-user-accounts)))
+
+
(test-begin "system")
(test-assert "operating-system-store-file-system"
@@ -71,4 +90,28 @@
%base-file-systems)))))
(eq? gnu (operating-system-store-file-system os))))
+(test-equal "operating-system-user-mapped-devices"
+ '()
+ (operating-system-user-mapped-devices %os-with-mapped-device))
+
+(test-equal "operating-system-boot-mapped-devices"
+ (list %luks-device)
+ (operating-system-boot-mapped-devices %os-with-mapped-device))
+
+(test-equal "operating-system-boot-mapped-devices, implicit dependency"
+ (list %luks-device)
+
+ ;; Here we expect the implicit dependency between "/" and
+ ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
+ ;; 'dependencies' field in the root file system.
+ (operating-system-boot-mapped-devices
+ (operating-system
+ (inherit %os-with-mapped-device)
+ (file-systems (cons (file-system
+ (device "/dev/mapper/my-luks-device")
+ (title 'device)
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems)))))
+
(test-end)
diff --git a/tests/zlib.scm b/tests/zlib.scm
new file mode 100644
index 0000000000..5455240a71
--- /dev/null
+++ b/tests/zlib.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 (test-zlib)
+ #:use-module (guix zlib)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match))
+
+;; Test the (guix zlib) module.
+
+(unless (zlib-available?)
+ (exit 77))
+
+(test-begin "zlib")
+
+(test-assert "compression/decompression pipe"
+ (let ((data (random-bytevector (+ (random 10000)
+ (* 20 1024)))))
+ (match (pipe)
+ ((parent . child)
+ (match (primitive-fork)
+ (0 ;compress
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port parent)
+ (call-with-gzip-output-port child
+ (lambda (port)
+ (put-bytevector port data))))
+ (lambda ()
+ (primitive-exit 0))))
+ (pid ;decompress
+ (begin
+ (close-port child)
+ (let ((received (call-with-gzip-input-port parent
+ (lambda (port)
+ (get-bytevector-all port))
+ #:buffer-size (* 64 1024))))
+ (match (waitpid pid)
+ ((_ . status)
+ (and (zero? status)
+ (port-closed? parent)
+ (bytevector=? received data))))))))))))
+
+(test-end)
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-20 03:33:45 +0000