diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/file-systems.scm | 64 | ||||
| -rw-r--r-- | tests/gexp.scm | 54 |
2 files changed, 118 insertions, 0 deletions
diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 4c28d0ebc5..7f7c373884 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,4 +65,67 @@ (_ #f)) (source-module-closure '((gnu system file-systems))))) +(test-equal "file-system-options->alist" + '("autodefrag" ("subvol" . "home") ("compress" . "lzo")) + (file-system-options->alist "autodefrag,subvol=home,compress=lzo")) + +(test-equal "file-system-options->alist (#f)" + '() + (file-system-options->alist #f)) + +(test-equal "alist->file-system-options" + "autodefrag,subvol=root,compress=lzo" + (alist->file-system-options '("autodefrag" + ("subvol" . "root") + ("compress" . "lzo")))) + +(test-equal "alist->file-system-options (null)" + #f + (alist->file-system-options '())) + + +;;; +;;; Btrfs related. +;;; + +(define %btrfs-root-subvolume + (file-system + (device (file-system-label "btrfs-pool")) + (mount-point "/") + (type "btrfs") + (options "subvol=rootfs,compress=zstd"))) + +(define %btrfs-store-subvolid + (file-system + (device (file-system-label "btrfs-pool")) + (mount-point "/gnu/store") + (type "btrfs") + (options "subvolid=10,compress=zstd") + (dependencies (list %btrfs-root-subvolume)))) + +(define %btrfs-store-subvolume + (file-system + (device (file-system-label "btrfs-pool")) + (mount-point "/gnu/store") + (type "btrfs") + (options "subvol=/some/nested/file/name") + (dependencies (list %btrfs-root-subvolume)))) + +(test-assert "btrfs-subvolume? (subvol)" + (btrfs-subvolume? %btrfs-root-subvolume)) + +(test-assert "btrfs-subvolume? (subvolid)" + (btrfs-subvolume? %btrfs-store-subvolid)) + +(test-equal "btrfs-store-subvolume-file-name" + "/some/nested/file/name" + (parameterize ((%store-prefix "/gnu/store")) + (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume + %btrfs-store-subvolume)))) + +(test-error "btrfs-store-subvolume-file-name (subvolid)" + (parameterize ((%store-prefix "/gnu/store")) + (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume + %btrfs-store-subvolid)))) + (test-end) diff --git a/tests/gexp.scm b/tests/gexp.scm index 6a42d3eb57..e073a7b816 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -321,6 +321,60 @@ (string=? result (string-append (derivation->output-path drv) "/bin/touch")))))) +(test-equal "let-system" + (list `(begin ,(%current-system) #t) '(system-binding) '() + 'low '() '()) + (let* ((exp #~(begin + #$(let-system system system) + #t)) + (low (run-with-store %store (lower-gexp exp)))) + (list (lowered-gexp-sexp low) + (match (gexp-inputs exp) + (((($ (@@ (guix gexp) <system-binding>)) "out")) + '(system-binding)) + (x x)) + (gexp-native-inputs exp) + 'low + (lowered-gexp-inputs low) + (lowered-gexp-sources low)))) + +(test-equal "let-system, target" + (list `(list ,(%current-system) #f) + `(list ,(%current-system) "aarch64-linux-gnu")) + (let ((exp #~(list #$@(let-system (system target) + (list system target))))) + (list (gexp->sexp* exp) + (gexp->sexp* exp "aarch64-linux-gnu")))) + +(test-equal "let-system, ungexp-native, target" + `(here it is: ,(%current-system) #f) + (let ((exp #~(here it is: #+@(let-system (system target) + (list system target))))) + (gexp->sexp* exp "aarch64-linux-gnu"))) + +(test-equal "let-system, nested" + (list `(system* ,(string-append "qemu-system-" (%current-system)) + "-m" "256") + '() + '(system-binding)) + (let ((exp #~(system* + #+(let-system (system target) + (file-append (@@ (gnu packages virtualization) + qemu) + "/bin/qemu-system-" + system)) + "-m" "256"))) + (list (match (gexp->sexp* exp) + (('system* command rest ...) + `(system* ,(and (string-prefix? (%store-prefix) command) + (basename command)) + ,@rest)) + (x x)) + (gexp-inputs exp) + (match (gexp-native-inputs exp) + (((($ (@@ (guix gexp) <system-binding>)) "out")) + '(system-binding)) + (x x))))) (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) |