tests: image: New test.

Add a new image test module to validate the image creation itself. The images
structures are validated using guile-parted. Checking the content of those
images is out of scope and should be performed in other modules (installation
for instance).

* gnu/tests/image.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

1 files changed, 270 insertions, 0 deletions

diff --git a/gnu/tests/image.scm b/gnu/tests/image.scm
new file mode 100644
index 0000000000..99d34b7670
--- /dev/null
+++ b/gnu/tests/image.scm
@@ -0,0 +1,270 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Mathieu Othacehe <othacehe@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 (gnu tests image)
+  #:use-module (gnu)
+  #:use-module (gnu image)
+  #:use-module (gnu tests)
+  #:autoload   (gnu system image) (system-image root-offset)
+  #:use-module (gnu system uuid)
+  #:use-module (gnu system vm)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages guile-xyz)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (ice-9 format)
+  #:export (%test-images))
+
+;;; Commentary:
+;;;
+;;; This module provides tests for the image creation process that is
+;;; performed by "genimage" under the hood.
+;;;
+;;; The image partitionment is checked using Guile-Parted.  The content of the
+;;; images is out of the scope of this module.  Other test modules such as
+;;; (gnu tests installation) make sure that the produced images are viable.
+;;;
+;;; Code:
+
+;; A dummy initializer creating a simple file in the partition.
+(define dummy-initializer
+  #~(lambda* (root . rest)
+      (mkdir root)
+      (call-with-output-file
+          (string-append root "/test")
+        (lambda (port)
+          (format port "content")))))
+
+(define %simple-efi-os
+  (operating-system
+    (inherit %simple-os)
+    (bootloader (bootloader-configuration
+                 (bootloader grub-efi-bootloader)
+                 (targets '("/boot/efi"))))))
+
+;; An MBR disk image with a single ext4 partition.
+(define i1
+  (image
+   (format 'disk-image)
+   (operating-system %simple-os)
+   (partitions
+    (list
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (offset root-offset)
+      (label "test")
+      (file-system "ext4")
+      (flags '(boot))
+      (initializer dummy-initializer))))))
+
+;; A GPT disk image with a single ext4 partition.
+(define i2
+  (image
+   (format 'disk-image)
+   (operating-system %simple-efi-os)
+   (partition-table-type 'gpt)
+   (partitions
+    (list
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (offset root-offset)
+      (label "test")
+      (file-system "ext4")
+      (flags '(boot))
+      (initializer dummy-initializer))))))
+
+;; An MBR disk image with multiple ext4 partitions.
+(define i3
+  (image
+   (format 'disk-image)
+   (operating-system %simple-os)
+   (partitions
+    (list
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (offset root-offset)
+      (label "test")
+      (file-system "ext4")
+      (flags '(boot))
+      (initializer dummy-initializer))
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (label "test2")
+      (file-system "ext4")
+      (flags '())
+      (initializer dummy-initializer))))))
+
+;; A GPT disk image with multiple ext4 partitions.
+(define i4
+  (image
+   (format 'disk-image)
+   (operating-system %simple-efi-os)
+   (partition-table-type 'gpt)
+   (partitions
+    (list
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (offset root-offset)
+      (label "test")
+      (file-system "ext4")
+      (flags '(boot))
+      (initializer dummy-initializer))
+     (partition
+      (size (* 1024 1024)) ;1MiB
+      (label "test2")
+      (file-system "ext4")
+      (flags '())
+      (initializer dummy-initializer))))))
+
+;; A GPT disk image with fat32 and ext4 partitions.
+(define i5
+  (image
+   (format 'disk-image)
+   (operating-system %simple-efi-os)
+   (partition-table-type 'gpt)
+   (partitions
+    (list
+     (partition
+      (size (* 1024 1024 128)) ;128MiB
+      (offset root-offset)
+      (label "test")
+      (file-system "fat32")
+      (flags '(esp))
+      (initializer dummy-initializer))
+     (partition
+      (size (* 1024 1024 256)) ;256MiB
+      (label "test2")
+      (file-system "ext4")
+      (flags '(boot))
+      (initializer dummy-initializer))))))
+
+(define (run-images-test)
+  (define test
+    (with-imported-modules '((srfi srfi-64)
+                             (gnu build marionette))
+      (with-extensions (list guile-parted guile-bytestructures)
+        #~(begin
+            (use-modules (gnu build marionette)
+                         (srfi srfi-1)
+                         (srfi srfi-26)
+                         (srfi srfi-64)
+                         (parted))
+
+            (define (image->disk img)
+              (disk-new (get-device img)))
+
+            (test-runner-current (system-test-runner #$output))
+            (test-begin "images")
+
+            ;; Image i1.
+            (define i1-image
+              #$(system-image i1))
+            (define d1-device
+              (get-device i1-image))
+
+            (test-equal "msdos"
+              (disk-type-name (disk-probe d1-device)))
+
+            (test-equal 1
+              (disk-get-primary-partition-count (disk-new d1-device)))
+
+            (test-assert
+                (let* ((disk (disk-new d1-device))
+                       (partitions (disk-partitions disk))
+                       (boot-partition (find normal-partition? partitions)))
+                  (partition-get-flag boot-partition PARTITION-FLAG-BOOT)))
+
+            ;; Image i2.
+            (define i2-image
+              #$(system-image i2))
+            (define d2-device
+              (get-device i2-image))
+
+            (test-equal "gpt"
+              (disk-type-name (disk-probe d2-device)))
+
+            (test-equal 1
+              (disk-get-primary-partition-count (disk-new d2-device)))
+
+            (test-equal "test"
+                (let* ((disk (disk-new d2-device))
+                       (partitions (disk-partitions disk))
+                       (boot-partition (find normal-partition? partitions)))
+                  (partition-get-name boot-partition)))
+
+            ;; Image i3.
+            (define i3-image
+              #$(system-image i3))
+            (define d3-device
+              (get-device i3-image))
+
+            (test-equal "msdos"
+              (disk-type-name (disk-probe d3-device)))
+
+            (test-equal 2
+              (disk-get-primary-partition-count (disk-new d3-device)))
+
+            ;; Image i4.
+            (define i4-image
+              #$(system-image i4))
+            (define d4-device
+              (get-device i4-image))
+
+            (test-equal "gpt"
+              (disk-type-name (disk-probe d4-device)))
+
+            (test-equal 2
+              (disk-get-primary-partition-count (disk-new d4-device)))
+
+            ;; Image i5.
+            (define i5-image
+              #$(system-image i5))
+            (define d5-device
+              (get-device i5-image))
+
+            (define (sector->byte sector)
+              (/ (* sector (device-sector-size d5-device))
+                 MEBIBYTE-SIZE))
+
+            (test-equal "gpt"
+              (disk-type-name (disk-probe d5-device)))
+
+            (test-equal 2
+              (disk-get-primary-partition-count (disk-new d5-device)))
+
+            (test-equal '("fat32" "ext4")
+              (map (compose filesystem-type-name partition-fs-type)
+                   (filter data-partition?
+                           (disk-partitions (disk-new d5-device)))))
+
+            ;; The first partition has a 1MiB offset has a 128MiB size. The
+            ;; second partition should then start at 129MiB.
+            (test-equal '(1 129)
+              (map (compose sector->byte partition-start)
+                   (filter data-partition?
+                           (disk-partitions (disk-new d5-device)))))
+
+            (test-end)))))
+
+  (gexp->derivation "images-test" test))
+
+(define %test-images
+  (system-test
+   (name "images")
+   (description "Build and test basic system images.")
+   (value (run-images-test))))