;;; 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 image-with-os efi-disk-image)
  #:use-module </td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=67c45d836756727cde23bdc752d7ead7fbb67228'>refs</a><a class='active' href='/guix/log/gnu/home/services'>log</a><a href='/guix/tree/gnu/home/services?id=67c45d836756727cde23bdc752d7ead7fbb67228'>tree</a><a href='/guix/commit/gnu/home/services?id=67c45d836756727cde23bdc752d7ead7fbb67228'>commit</a><a href='/guix/diff/gnu/home/services?id=67c45d836756727cde23bdc752d7ead7fbb67228'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/home/services'>
<input type='hidden' name='id' value='67c45d836756727cde23bdc752d7ead7fbb67228'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/log/?id=67c45d836756727cde23bdc752d7ead7fbb67228'>root</a>/<a href='/guix/log/gnu?id=67c45d836756727cde23bdc752d7ead7fbb67228'>gnu</a>/<a href='/guix/log/gnu/home?id=67c45d836756727cde23bdc752d7ead7fbb67228'>home</a>/<a href='/guix/log/gnu/home/services?id=67c45d836756727cde23bdc752d7ead7fbb67228'>services</a></div><div class='content'><table class='list nowrap'><tr class='nohover'><th class='left'>Age</th><th class='left'>Commit message (<a href='/guix/log/gnu/home/services?id=67c45d836756727cde23bdc752d7ead7fbb67228&amp;showmsg=1'>Expand</a>)</th><th class='left'>Author</th></tr>
<tr><td><span title='2024-03-06 23:25:51 +0100'>2024-03-06</span></td><td><a href='/guix/commit/gnu/home/services?id=01f685d56016ae529381a73daedccc1949b808ec'>gnu: home: dotfiles: Properly support both plain and Stow directory layouts.</a><span class='msg-avail'>...</span></td><td>Giacomo Leidi</td></tr>

   (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))))))

;; A efi disk image with default partitions
(define i6
  (image-with-os efi-disk-image %simple-efi-os))

(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)))))

            ;; Image i6.
            (define i6-image
              #$(system-image i6))
            (define d6-device
              (get-device i6-image))

            (test-equal "gpt"
              (disk-type-name (disk-probe d6-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))))