;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012-2021 Ludovic Courtès ;;; ;;; 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 . (define-module (test-nar) #:use-module (guix tests) #:use-module (guix nar) #:use-module (guix serialization) #:use-module (guix store) #:use-module ((gcrypt hash) #:select (open-sha256-port open-sha256-input-port)) #:use-module ((guix packages) #:select (base32)) #:use-module ((guix build utils) #:select (find-files)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 ftw) #:use-module (ice-9 regex) #:use-module ((ice-9 control) #:select (let/ec)) #:use-module (ice-9 match)) ;; Test the (guix nar) module. ;;; ;;; File system testing tools, initially contributed to Guile, then libchop. ;;; (define (random-file-size) (define %average (* 1024 512)) ; 512 KiB (define %stddev (* 1024 64)) ; 64 KiB (inexact->exact (max 0 (round (+ %average (* %stddev (random:normal))))))) (define (make-file-tree dir tree) "Make file system TREE at DIR." (let loop ((dir dir) (tree tree)) (define (scope file) (string-append dir "/" file)) (match tree (('directory name (body ...)) (mkdir (scope name)) (for-each (cute loop (scope name) <>) body)) (('directory name (? integer? mode) (body ...)) (mkdir (scope name)) (for-each (cute loop (scope name) <>) body) (chmod (scope name) mode)) ((file) (populate-file (scope file) (random-file-size))) ((file (? integer? mode)) (populate-file (scope file) (random-file-size)) (chmod (scope file) mode)) ((from '-> to) (symlink to (scope fr2020-05-20bootloader: grub: Allow booting from a Btrfs subvolume....* gnu/bootloader/grub.scm (strip-mount-point): Remove procedure. (normalize-file): Add procedure. (grub-configuration-file): New BTRFS-SUBVOLUME-FILE-NAME parameter. When defined, prepend its value to the kernel and initrd file names, using the NORMALIZE-FILE procedure. Adjust the call to EYE-CANDY to pass the BTRFS-SUBVOLUME-FILE-NAME argument. Normalize the KEYMAP file as well. (eye-candy): Add a BTRFS-SUBVOLUME-FILE-NAME parameter, and use it, along with the NORMALIZE-FILE procedure, to normalize the FONT-FILE and IMAGE nested variables. Adjust doc. * gnu/bootloader/depthcharge.scm (depthcharge-configuration-file): Adapt. * gnu/bootloader/extlinux.scm (extlinux-configuration-file): Likewise. * gnu/system/file-systems.scm (btrfs-subvolume?) (btrfs-store-subvolume-file-name): New procedures. * gnu/system.scm (operating-system-bootcfg): Specify the Btrfs subvolume file name the store resides on to the `operating-system-bootcfg' procedure, using the new BTRFS-SUBVOLUME-FILE-NAME argument. * doc/guix.texi (File Systems): Add a Btrfs subsection to document the use of subvolumes. * gnu/tests/install.scm (%btrfs-root-on-subvolume-os) (%btrfs-root-on-subvolume-os-source) (%btrfs-root-on-subvolume-installation-script) (%test-btrfs-root-on-subvolume-os): New variables. Maxim Cournoyer 2020-05-20file-systems: Add helpers for parsing the options string into an alist....* gnu/system/file-systems.scm (file-system-options->alist) (alist->file-system-options): New procedures. * tests/file-systems.scm: New tests. * doc/guix.texi (File Systems): Add note about the newly added procedures. Maxim Cournoyer 2017-09-14uuid: Move tests to 'tests/uuid.scm'....* tests/file-systems.scm ("uuid->string", "string->uuid") ("uuid", "uuid, syntax error"): Move to... * tests/uuid.scm: ... here. New file. ("uuid, ISO-9660, format preserved"): New test. Ludovic Courtès 2017-09-14uuid: Adjust tests....This is a followup to 9b336338cdc0e46a3bf7a2913c2f61cd2410c4d6. * tests/file-systems.scm ("uuid"): Add call to 'uuid-bytevector'. ("uuid, syntax error"): Add 'dce to the expected form. Ludovic Courtès 2017-03-21file-systems: Do not use (gnu packages …)....Fixes a regression introduced in 7208995426714c9fc3ad59cadc3cc0f52df0f018 whereby (gnu system file-systems) would pull in (gnu packages …) module, which in turn breaks when importing things like (gnu build shepherd). * gnu/system/file-systems.scm (file-system-type-predicate): Export. (file-system-packages): Move to... * gnu/system/linux-initrd.scm (file-system-packages): ... here. Add docstring. * gnu/services/base.scm: Use it. * tests/file-systems.scm ("does not pull (gnu packages …)"): New test. Ludovic Courtès 2017-02-04file-systems: Remove dependency on (guix store)....(gnu system file-systems) is used on the "build" side since commit 5970e8e248f6327c41c83b86bb2c89be7c3b1b4e. * gnu/system/file-systems.scm: Remove dependency on (guix store). (%store-prefix): New procedure. * tests/file-systems.scm ("does not pull (guix config)"): New test. Ludovic Courtès 2017-01-16file-systems: 'file-system-needed-for-boot?' is #t for parents of the store....Suggested by John Darrington <john@darrington.wattle.id.au>. * gnu/system/file-systems.scm (%not-slash): New variable. (file-prefix?): New procedure. (file-system-needed-for-boot?): Use it to check whether FS holds the store. * tests/file-systems.scm ("file-system-needed-for-boot?"): New test. * gnu/tests/install.scm (%separate-store-os)[file-systems]: Remove 'needed-for-boot?' field for "/gnu". Ludovic Courtès 2016-04-03build: Add a Guile custom test driver using SRFI-64....Before that '.log' files for scheme tests were fragmented and not included in test-suite.log. This unifies the semantics of SRFI-64 API with Automake test suite. * build-aux/test-driver.scm: New file. * Makefile.am (SCM_LOG_DRIVER, AM_SCM_LOG_DRIVER_FLAGS): New variables. (SCM_LOG_COMPILER, AM_SCM_LOG_FLAGS): Delete variables. (AM_TESTS_ENVIRONMENT): Set GUILE_AUTO_COMPILE to 0. * test-env.in: Silence guix-daemon. * doc/guix.texi (Running the Test Suite): Describe how to display the detailed results. Bug reports require only 'test-suite.log' file. * tests/base32.scm, tests/build-utils.scm, tests/builders.scm, tests/challenge.scm, tests/cpan.scm, tests/cpio.scm, tests/cran.scm, tests/cve.scm, tests/derivations.scm, tests/elpa.scm, tests/file-systems.scm, tests/gem.scm, tests/gexp.scm, tests/gnu-maintenance.scm, tests/grafts.scm, tests/graph.scm, tests/gremlin.scm, tests/hackage.scm, tests/hash.scm, tests/import-utils.scm, tests/lint.scm, tests/monads.scm, tests/nar.scm, tests/packages.scm, tests/pk-crypto.scm, tests/pki.scm, tests/profiles.scm, tests/publish.scm, tests/pypi.scm, tests/records.scm, tests/scripts-build.scm, tests/scripts.scm, tests/services.scm, tests/sets.scm, tests/size.scm, tests/snix.scm, tests/store.scm, tests/substitute.scm, tests/syscalls.scm, tests/system.scm, tests/ui.scm, tests/union.scm, tests/upstream.scm, tests/utils.scm: Don't exit at the end of test groups. * tests/containers.scm: Likewise. Use 'test-skip' instead of exiting with error code 77. Mathieu Lirzin 2015-07-16file-systems: 'uuid' raises a syntax error for invalid UUIDs....* gnu/system/file-systems.scm (uuid): Call 'syntax-violation' when 'string->uuid' returns #f. * tests/file-systems.scm ("uuid, syntax error"): New test. Ludovic Courtès 2015-07-14file-systems: Allow users to specify file system UUIDs as strings....Fixes <http://bugs.gnu.org/19778>. Reported by Mark H Weaver <mhw@netris.org>. * gnu/system/file-systems.scm (%uuid-rx): New variable. (string->uuid): New procedure. (uuid): New macro. * tests/file-systems.scm: New file. * Makefile.am (SCM_TESTS): Add it. * doc/guix.texi (File Systems): Give an example of UUID. Ludovic Courtès 63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3") (let ((input (string-append %test-dir ".input"))) (dynamic-wind (lambda () (define (touch file) (call-with-output-file (string-append input "/" file) (const #t))) (mkdir input) (touch "B") (touch "Z") (touch "a") (symlink "B" (string-append input "/z"))) (lambda () (let-values (((port get-hash) (open-sha256-port))) (write-file input port) (close-port port) (get-hash))) (lambda () (rm-rf input))))) (test-equal "restore-file with incomplete input" (string-append %test-dir "/foo") (let ((port (open-bytevector-input-port #vu8(1 2 3)))) (guard (c ((nar-error? c) (and (eq? port (nar-error-port c)) (nar-error-file c)))) (restore-file port (string-append %test-dir "/foo")) #f))) (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) (output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) (file-tree-equal? input output)) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output)))))) (test-assert "write-file + restore-file with symlinks" (let ((input (string-append %test-dir ".input"))) (mkdir input) (dynamic-wind (const #t) (lambda () (with-file-tree input (directory "root" (("reg") ("exe" #o777) ("sym" -> "reg"))) (let* ((output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) (and (file-tree-equal? input output) (every (lambda (file) (canonical-file? (string-append output "/" file))) '("root" "root/reg" "root/exe")))) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output))))))) (lambda () (rmdir input))))) (test-assert "write-file #:select? + restore-file" (let ((input (string-append %test-dir ".input"))) (mkdir input) (dynamic-wind (const #t) (lambda () (with-file-tree input (directory "root" ((directory "a" (("x") ("y") ("z"))) ("b") ("c") ("d" -> "b"))) (let* ((output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (lambda (port) (write-file input port #:select? (lambda (file stat) (and (not (string=? (basename file) "a")) (not (eq? (stat:type stat) 'symlink))))))) (call-with-input-file nar (cut restore-file <> output)) ;; Make sure "a" and "d" have been filtered out. (and (not (file-exists? (string-append output "/root/a"))) (file=? (string-append output "/root/b") (string-append input "/root/b")) (file=? (string-append output "/root/c") (string-append input "/root/c")) (not (file-exists? (string-append output "/root/d"))))) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output))))))) (lambda () (rmdir input))))) (test-eq "restore-file with non-UTF8 locale" ; 'encoding-error (let* ((file (search-path %load-path "guix.scm")) (output (string-append %test-dir "/output")) (locale (setlocale LC_ALL "C"))) (dynamic-wind (lambda () #t) (lambda () (define-values (port get-bytevector) (open-bytevector-output-port)) (write-file-tree "root" port #:file-type+size (match-lambda ("root" (values 'directory 0)) ("root/λ" (values 'regular 0))) #:file-port (const (%make-void-port "r")) #:symlink-target (const #f) #:directory-entries (const '("λ"))) (close-port port) (mkdir %test-dir) (catch 'encoding-error (lambda () ;; This show throw to 'encoding-error. (restore-file (open-bytevector-input-port (get-bytevector)) output) (scandir output)) (lambda args 'encoding-error))) (lambda () (false-if-exception (rm-rf %test-dir)) (setlocale LC_ALL locale))))) ;; XXX: Tell the 'deduplicate' procedure what store we're actually using. (setenv "NIX_STORE" (%store-prefix)) (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) (lambda _ (random-text)) 1+ 0)) (files (map (cut add-text-to-store store "text" <>) texts)) (dump (call-with-bytevector-output-port (cut export-paths store files <>)))) (delete-paths store files) (and (every (negate file-exists?) files) (let* ((source (open-bytevector-input-port dump)) (imported (restore-file-set source))) (and (equal? imported files) (every (lambda (file) (and (file-exists? file) (valid-path? store file))) files) (equal? texts (map (lambda (file) (call-with-input-file file get-string-all)) files)) (every canonical-file? files))))))) (test-assert "restore-file-set with directories (signed, valid)" ;; describes a bug whereby directories ;; containing files subject to deduplication were not canonicalized--i.e., ;; their mtime and permissions were not reset. Ensure that this bug is ;; gone. (with-store store ;; Note: TEXT1 and TEXT2 must be longer than %DEDUPLICATION-MINIMUM-SIZE. (let* ((text1 (string-concatenate (make-list 200 (random-text)))) (text2 (string-concatenate (make-list 200 (random-text)))) (tree `("tree" directory ("a" regular (data ,text1)) ("b" directory ("c" regular (data ,text2)) ("d" regular (data ,text1))))) ;duplicate (file (add-file-tree-to-store store tree)) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <>)))) (delete-paths store (list file)) (and (not (file-exists? file)) (let* ((source (open-bytevector-input-port dump)) (imported (restore-file-set source))) (and (equal? imported (list file)) (file-exists? file) (valid-path? store file) (string=? text1 (call-with-input-file (string-append file "/a") get-string-all)) (string=? text2 (call-with-input-file (string-append file "/b/c") get-string-all)) (= (stat:ino (stat (string-append file "/a"))) ;deduplication (stat:ino (stat (string-append file "/b/d")))) (every canonical-file? (find-files file #:directories? #t)))))))) (test-assert "restore-file-set (missing signature)" (let/ec return (with-store store (let* ((file (add-text-to-store store "foo" (random-text))) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <> #:sign? #f)))) (delete-paths store (list file)) (and (not (file-exists? file)) (let ((source (open-bytevector-input-port dump))) (guard (c ((nar-signature-error? c) (let ((message (condition-message c)) (port (nar-error-port c))) (return (and (string-match "lacks.*signature" message) (string=? file (nar-error-file c)) (eq? source port)))))) (restore-file-set source)) #f)))))) (test-assert "restore-file-set (corrupt)" (let/ec return (with-store store (let* ((file (add-text-to-store store "foo" (random-text))) (dump (call-with-bytevector-output-port (cute export-paths store (list file) <>)))) (delete-paths store (list file)) ;; Flip a byte in the file contents. (let* ((index 120) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) (let ((source (open-bytevector-input-port dump))) (guard (c ((nar-invalid-hash-error? c) (let ((message (condition-message c)) (port (nar-error-port c))) (return (and (string-contains message "hash") (string=? file (nar-error-file c)) (eq? source port)))))) (restore-file-set source)) #f)))))) (test-end "nar") ;;; Local Variables: ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) ;;; End: