;;; 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.
;;;
(define-module (test-file-systems)
#:use-module (guix store)
+ #:use-module (guix modules)
#: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)
(device "/foo")
(flags '(bind-mount read-only)))))))))
+(test-assert "does not pull (guix config)"
+ ;; This module is meant both for the host side and "build side", so make
+ ;; sure it doesn't pull in (guix config), which depends on the user's
+ ;; config.
+ (not (member '(guix config)
+ (source-module-closure '((gnu system file-systems))))))
+
+(test-equal "does not pull (gnu packages …)"
+ ;; Same story: (gnu packages …) should not be pulled.
+ #f
+ (find (match-lambda
+ (('gnu 'packages _ ..1) #t)
+ (_ #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 '()))
+
+\f
+;;;
+;;; 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)