Merge branch 'master' into staging

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)