aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/cpan.scm2
-rw-r--r--tests/file-systems.scm26
-rw-r--r--tests/guix-system.sh6
-rw-r--r--tests/import-utils.scm40
-rw-r--r--tests/print.scm64
-rw-r--r--tests/substitute.scm193
-rw-r--r--tests/uuid.scm60
7 files changed, 347 insertions, 44 deletions
diff --git a/tests/cpan.scm b/tests/cpan.scm
index de865b22be..8900716cb0 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -100,7 +100,7 @@
('home-page "http://search.cpan.org/dist/Foo-Bar")
('synopsis "Fizzle Fuzz")
('description 'fill-in-yourself!)
- ('license (package-license perl)))
+ ('license 'perl-license))
(string=? (bytevector->nix-base32-string
(call-with-input-string test-source port-sha256))
hash))
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 12f4f09c57..4c28d0ebc5 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -22,38 +22,12 @@
#:use-module (gnu system file-systems)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
- #:use-module (rnrs bytevectors)
#:use-module (ice-9 match))
;; Test the (gnu system file-systems) module.
(test-begin "file-systems")
-(test-equal "uuid->string"
- "c5307e6b-d1ba-499d-89c5-cb0b143577c4"
- (uuid->string
- #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196)))
-
-(test-equal "string->uuid"
- '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
- (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
- (list (bytevector-length uuid) (uuid->string uuid))))
-
-(test-assert "uuid"
- (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
- (bytevector=? (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
- (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))))
-
-(test-assert "uuid, syntax error"
- (catch 'syntax-error
- (lambda ()
- (eval '(uuid "foobar") (current-module))
- #f)
- (lambda (key proc message location form . args)
- (and (eq? proc 'uuid)
- (string-contains message "invalid UUID")
- (equal? form '(uuid "foobar"))))))
-
(test-assert "file-system-needed-for-boot?"
(let-syntax ((dummy-fs (syntax-rules ()
((_ directory)
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index de6db0928c..d575795ea0 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -215,3 +215,7 @@ EOF
# In both cases 'my-torrc' should be properly resolved.
guix system build "$tmpdir/config.scm" -n
(cd "$tmpdir"; guix system build "config.scm" -n)
+
+# Searching.
+guix system search tor | grep "^name: tor"
+guix system search anonym network | grep "^name: tor"
diff --git a/tests/import-utils.scm b/tests/import-utils.scm
index 8d44b9e0e2..3d8d2c698d 100644
--- a/tests/import-utils.scm
+++ b/tests/import-utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -21,6 +21,8 @@
#:use-module (guix tests)
#:use-module (guix import utils)
#:use-module ((guix licenses) #:prefix license:)
+ #:use-module (guix packages)
+ #:use-module (guix build-system)
#:use-module (srfi srfi-64))
(test-begin "import-utils")
@@ -38,4 +40,40 @@
'license:lgpl2.0
(license->symbol license:lgpl2.0))
+(test-assert "alist->package with simple source"
+ (let* ((meta '(("name" . "hello")
+ ("version" . "2.10")
+ ("source" . "mirror://gnu/hello/hello-2.10.tar.gz")
+ ("build-system" . "gnu")
+ ("home-page" . "https://gnu.org")
+ ("synopsis" . "Say hi")
+ ("description" . "This package says hi.")
+ ("license" . "GPL-3.0+")))
+ (pkg (alist->package meta)))
+ (and (package? pkg)
+ (license:license? (package-license pkg))
+ (build-system? (package-build-system pkg))
+ (origin? (package-source pkg)))))
+
+(test-assert "alist->package with explicit source"
+ (let* ((meta '(("name" . "hello")
+ ("version" . "2.10")
+ ("source" . (("method" . "url-fetch")
+ ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz")
+ ("sha256" .
+ (("base32" .
+ "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
+ ("build-system" . "gnu")
+ ("home-page" . "https://gnu.org")
+ ("synopsis" . "Say hi")
+ ("description" . "This package says hi.")
+ ("license" . "GPL-3.0+")))
+ (pkg (alist->package meta)))
+ (and (package? pkg)
+ (license:license? (package-license pkg))
+ (build-system? (package-build-system pkg))
+ (origin? (package-source pkg))
+ (equal? (origin-sha256 (package-source pkg))
+ (base32 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i")))))
+
(test-end "import-utils")
diff --git a/tests/print.scm b/tests/print.scm
new file mode 100644
index 0000000000..305807c1d1
--- /dev/null
+++ b/tests/print.scm
@@ -0,0 +1,64 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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-print)
+ #:use-module (guix import print)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix download)
+ #:use-module (guix packages)
+ #:use-module (guix licenses)
+ #:use-module (srfi srfi-64))
+
+(test-begin "print")
+
+(define pkg
+ (package
+ (name "test")
+ (version "1.2.3")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "file:///tmp/test-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
+ (build-system gnu-build-system)
+ (home-page "http://gnu.org")
+ (synopsis "Dummy")
+ (description "This is a dummy package.")
+ (license gpl3+)))
+
+(test-equal "simple package"
+ (package->code pkg)
+ '(package
+ (name "test")
+ (version "1.2.3")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "file:///tmp/test-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
+ (build-system gnu-build-system)
+ (home-page "http://gnu.org")
+ (synopsis "Dummy")
+ (description "This is a dummy package.")
+ (license gpl3+)))
+
+(test-end "print")
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 69b272f2bb..0ad6247954 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,7 +28,9 @@
#:use-module (guix base32)
#:use-module ((guix store) #:select (%store-prefix))
#:use-module ((guix ui) #:select (guix-warning-port))
- #:use-module ((guix build utils) #:select (delete-file-recursively))
+ #:use-module ((guix build utils)
+ #:select (mkdir-p delete-file-recursively))
+ #:use-module (guix tests http)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (web uri)
@@ -112,6 +114,15 @@ version identifier.."
+(define %main-substitute-directory
+ ;; The place where 'call-with-narinfo' stores its data by default.
+ (uri-path (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
+
+(define %alternate-substitute-directory
+ ;; Another place.
+ (string-append (dirname %main-substitute-directory)
+ "/substituter-alt-data"))
+
(define %narinfo
;; Skeleton of the narinfo used below.
(string-append "StorePath: " (%store-prefix)
@@ -125,14 +136,14 @@ References: bar baz
Deriver: " (%store-prefix) "/foo.drv
System: mips64el-linux\n"))
-(define (call-with-narinfo narinfo thunk)
- "Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
+(define* (call-with-narinfo narinfo thunk
+ #:optional
+ (narinfo-directory %main-substitute-directory))
+ "Call THUNK in a context where the directory at URL is populated with
a file for NARINFO."
- (let ((narinfo-directory (and=> (string->uri (getenv
- "GUIX_BINARY_SUBSTITUTE_URL"))
- uri-path))
- (cache-directory (string-append (getenv "XDG_CACHE_HOME")
- "/guix/substitute/")))
+ (mkdir-p narinfo-directory)
+ (let ((cache-directory (string-append (getenv "XDG_CACHE_HOME")
+ "/guix/substitute/")))
(dynamic-wind
(lambda ()
(when (file-exists? cache-directory)
@@ -161,14 +172,17 @@ a file for NARINFO."
#f))
thunk
(lambda ()
- (delete-file-recursively cache-directory)))))
+ (when (file-exists? cache-directory)
+ (delete-file-recursively cache-directory))))))
(define-syntax-rule (with-narinfo narinfo body ...)
(call-with-narinfo narinfo (lambda () body ...)))
+(define-syntax-rule (with-narinfo* narinfo directory body ...)
+ (call-with-narinfo narinfo (lambda () body ...) directory))
+
;; Transmit these options to 'guix substitute'.
-(set! (@@ (guix scripts substitute) %cache-urls)
- (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
+(substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL")))
(test-equal "query narinfo without signature"
"" ; not substitutable
@@ -228,7 +242,7 @@ a file for NARINFO."
(guix-substitute "--query"))))))))
(test-quit "substitute, no signature"
- "lacks a signature"
+ "no valid substitute"
(with-narinfo %narinfo
(guix-substitute "--substitute"
(string-append (%store-prefix)
@@ -236,7 +250,7 @@ a file for NARINFO."
"foo")))
(test-quit "substitute, invalid hash"
- "hash"
+ "no valid substitute"
;; The hash in the signature differs from the hash of %NARINFO.
(with-narinfo (string-append %narinfo "Signature: "
(signature-field "different body")
@@ -247,7 +261,7 @@ a file for NARINFO."
"foo")))
(test-quit "substitute, unauthorized key"
- "unauthorized"
+ "no valid substitute"
(with-narinfo (string-append %narinfo "Signature: "
(signature-field
%narinfo
@@ -273,9 +287,158 @@ a file for NARINFO."
(lambda ()
(false-if-exception (delete-file "substitute-retrieved"))))))
+(test-equal "substitute, unauthorized narinfo comes first"
+ "Substitutable data."
+ (with-narinfo*
+ (string-append %narinfo "Signature: "
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key))
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; Remove this file so that the substitute can only be retrieved
+ ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+ (delete-file (string-append %main-substitute-directory
+ "/example.nar"))
+
+ (parameterize ((substitute-urls
+ (map (cut string-append "file://" <>)
+ (list %alternate-substitute-directory
+ %main-substitute-directory))))
+ (guix-substitute "--substitute"
+ (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, unsigned narinfo comes first"
+ "Substitutable data."
+ (with-narinfo* %narinfo ;not signed!
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; Remove this file so that the substitute can only be retrieved
+ ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+ (delete-file (string-append %main-substitute-directory
+ "/example.nar"))
+
+ (parameterize ((substitute-urls
+ (map (cut string-append "file://" <>)
+ (list %alternate-substitute-directory
+ %main-substitute-directory))))
+ (guix-substitute "--substitute"
+ (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong hash"
+ "Substitutable data."
+ (with-narinfo* (regexp-substitute #f
+ (string-match "NarHash: [[:graph:]]+"
+ %narinfo)
+ 'pre
+ "NarHash: sha256:"
+ (bytevector->nix-base32-string
+ (make-bytevector 32))
+ 'post)
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; This time remove the file so that the substitute can only be
+ ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+ (delete-file (string-append %alternate-substitute-directory
+ "/example.nar"))
+
+ (parameterize ((substitute-urls
+ (map (cut string-append "file://" <>)
+ (list %alternate-substitute-directory
+ %main-substitute-directory))))
+ (guix-substitute "--substitute"
+ (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first narinfo is unsigned and has wrong refs"
+ "Substitutable data."
+ (with-narinfo* (regexp-substitute #f
+ (string-match "References: ([^\n]+)\n"
+ %narinfo)
+ 'pre "References: " 1
+ " wrong set of references\n"
+ 'post)
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; This time remove the file so that the substitute can only be
+ ;; retrieved from %MAIN-SUBSTITUTE-DIRECTORY.
+ (delete-file (string-append %alternate-substitute-directory
+ "/example.nar"))
+
+ (parameterize ((substitute-urls
+ (map (cut string-append "file://" <>)
+ (list %alternate-substitute-directory
+ %main-substitute-directory))))
+ (guix-substitute "--substitute"
+ (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-quit "substitute, two invalid narinfos"
+ "no valid substitute"
+ (with-narinfo* %narinfo ;not signed
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: " ;unauthorized
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key))
+ %main-substitute-directory
+
+ (guix-substitute "--substitute"
+ (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))))
+
(test-end "substitute")
;;; Local Variables:
;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
+;;; eval: (put 'with-narinfo* 'scheme-indent-function 2)
;;; eval: (put 'test-quit 'scheme-indent-function 2)
;;; End:
diff --git a/tests/uuid.scm b/tests/uuid.scm
new file mode 100644
index 0000000000..aacce77233
--- /dev/null
+++ b/tests/uuid.scm
@@ -0,0 +1,60 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015, 2017 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-uuid)
+ #:use-module (gnu system uuid)
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors))
+
+(test-begin "uuid")
+
+(test-equal "uuid->string"
+ "c5307e6b-d1ba-499d-89c5-cb0b143577c4"
+ (uuid->string
+ #vu8(197 48 126 107 209 186 73 157 137 197 203 11 20 53 119 196)))
+
+(test-equal "string->uuid"
+ '(16 "4dab5feb-d176-45de-b287-9b0a6e4c01cb")
+ (let ((uuid (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
+ (list (bytevector-length uuid) (uuid->string uuid))))
+
+(test-assert "uuid"
+ (let ((str "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
+ (bytevector=? (uuid-bytevector
+ (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))
+ (string->uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))))
+
+(test-assert "uuid, syntax error"
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(uuid "foobar") (current-module))
+ #f)
+ (lambda (key proc message location form . args)
+ (and (eq? proc 'uuid)
+ (string-contains message "invalid UUID")
+ (equal? form '(uuid "foobar" 'dce))))))
+
+(test-equal "uuid, ISO-9660, format preserved"
+ "1970-01-01-17-14-42-99"
+ (uuid->string (uuid "1970-01-01-17-14-42-99" 'iso9660)))
+
+(test-equal "uuid, FAT32, format preserved"
+ "1234-ABCD"
+ (uuid->string (uuid "1234-abcd" 'fat32)))
+
+(test-end)
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-29 02:50:20 +0000