;;; Test for Guix System with root on LVM
;;; Copyright © 2025

(define-module (ruther tests lvm)
  #:use-module (ruthless bootloader grub)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu build marionette)
  #:use-module (gnu packages firmware)
  #:use-module (gnu packages ocr)
  #:use-module (gnu packages virtualization)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu tests)
  #:use-module (gnu tests base)
  #:use-module (guix gexp)
  #:use-module (ruthless image)
  #:export (%test-root-lvm
            %test-lvm-on-luks))

;;;
;;; OS definition with root on LVM
;;;

(define %lvm-root-os
  ;; Operating system with root filesystem on LVM.
  ;; Uses vg0/root as the root logical volume.
  (operating-system
    (host-name "lvmroot")
    (timezone "Europe/Berlin")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-efi-removable-bootloader)
                 (targets '("/boot/efi"))
                 (terminal-outputs '(console))))

    (kernel-arguments '("console=ttyS0"))

    (mapped-devices
     (list (mapped-device
            (source "vg0")
            (targets '("vg0-root"))
            (type lvm-device-mapping))))

    (file-systems
     (cons* (file-system
              (device "/dev/mapper/vg0-root")
              (mount-point "/")
              (type "ext4")
              (dependencies mapped-devices))
            (file-system
              (device (file-system-label "ESP"))
              (mount-point "/boot/efi")
              (type "vfat"))
            %base-file-systems))

    (users (cons (user-account
                  (name "alice")
                  (group "users")
                  (supplementary-groups '("wheel")))
                 %base-user-accounts))

    (services %base-services)))

;;;
;;; Test execution
;;;

(define (run-lvm-root-test)
  "Run the basic test suite on an OS with root on LVM."
  (define os
    (marionette-operating-system
     %lvm-root-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  ;; Use the generic disk image builder with LVM initializer
  (define image
    (build-disk-image os
                      #:disk-initializer lvm-disk-initializer
                      #:disk-size (* 2048 1024 1024)  ; 2 GiB
                      #:uefi? #t
                      #:name "lvm-root-image"))

  (define vm-command
    #~(list (string-append #$qemu-minimal "/bin/"
                           #$(qemu-command))
            "-m" "512"
            "-bios" #$(file-append ovmf-x86-64 "/share/firmware/ovmf_x64.bin")
            "-drive"
            (string-append "file=" #$image
                           ",format=qcow2,if=virtio")
            "-snapshot"  ; Use snapshot mode since image is in read-only store
            "-no-reboot"
            #$@(if (file-exists? "/dev/kvm")
                   '("-enable-kvm")
                   '())
            "-nographic"))

  (run-basic-test os vm-command "lvm-root"))

;;;
;;; System test definition
;;;

(define %test-root-lvm
  (system-test
   (name "lvm-root")
   (description "Test basic functionality of a Guix System with root on LVM.")
   (value (run-lvm-root-test))))

;;;
;;; OS definition with LVM on LUKS
;;;

;; The LUKS passphrase and UUID used during image creation.
;; These must match the values in make-lvm-on-luks-disk-initializer.
(define %luks-passphrase "testpassword")
(define %luks-uuid "12345678-1234-1234-1234-123456789abc")

(define %lvm-on-luks-os
  ;; Operating system with root and home on LVM, which sits on a LUKS
  ;; encrypted partition.
  ;;
  ;; Mapped devices dependency chain:
  ;;   /dev/vda3 (LUKS partition)
  ;;     -> /dev/mapper/cryptroot (opened LUKS container)
  ;;       -> vg0 (LVM volume group on cryptroot)
  ;;         -> /dev/mapper/vg0-root (root LV)
  ;;         -> /dev/mapper/vg0-home (home LV)
  (operating-system
    (host-name "crptlvm") ;; NOTE: no y, because that one the OCR does not like.
    (timezone "Europe/Berlin")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-efi-removable-bootloader)
                 (targets '("/boot/efi"))
                 (terminal-outputs '(console))))

    ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt
    ;; detection logic in 'enter-luks-passphrase' which uses OCR.

    ;; Mapped devices: first LUKS, then LVM on top
    (mapped-devices
     (list
      ;; LUKS encrypted partition
      (mapped-device
       (source (uuid %luks-uuid))
       (targets '("cryptroot"))
       (type luks-device-mapping))
      ;; LVM volume group on the LUKS container
      (mapped-device
       (source "vg0")
       (targets '("vg0-root" "vg0-home"))
       (type lvm-device-mapping))))

    (file-systems
     (cons* (file-system
              (device "/dev/mapper/vg0-root")
              (mount-point "/")
              (type "ext4")
              (dependencies mapped-devices))
            (file-system
              (device (file-system-label "ESP"))
              (mount-point "/boot/efi")
              (type "vfat"))
            (file-system
              (device "/dev/mapper/vg0-home")
              (mount-point "/home")
              (type "ext4")
              (dependencies mapped-devices))
            %base-file-systems))

    (users (cons (user-account
                  (name "alice")
                  (group "users")
                  (supplementary-groups '("wheel")))
                 %base-user-accounts))

    (services %base-services)))

;;;
;;; Test execution
;;;

;; Taken from the GNU Guix channel, with edits.
(define (enter-luks-passphrase marionette)
  "Return a gexp to be inserted in the basic system test running on MARIONETTE
to enter the LUKS passphrase."
  (let ((ocrad (file-append ocrad "/bin/ocrad")))
    #~(begin
        (define (passphrase-prompt? text)
          (string-contains (pk 'screen-text text) "Enter pass"))

        (test-assert "enter LUKS passphrase for GRUB"
          (begin

            ;; At this point we have no choice but to use OCR to determine
            ;; when the passphrase should be entered.
            (wait-for-screen-text #$marionette passphrase-prompt?
                                  #:ocr #$ocrad
                                  #:timeout 60)

            (marionette-control (string-append "screendump " #$output
                                               "/post-grub-passphrase.ppm")
                                #$marionette)

            (marionette-type #$(string-append %luks-passphrase "\n")
                             #$marionette)

            ;; It's hard to determine what to wait for here.
            ;; So just wait long enough.
            (sleep 40)))

        (test-assert "enter LUKS passphrase for the initrd"
          (begin
            ;; XXX: Here we use OCR as well but we could instead use QEMU
            ;; '-serial stdio' and run it in an input pipe,
            (wait-for-screen-text #$marionette passphrase-prompt?
                                  #:ocr #$ocrad
                                  #:timeout 60)
            (marionette-type #$(string-append %luks-passphrase "\n")
                             #$marionette)

            ;; Take a screenshot for debugging purposes.
            (marionette-control (string-append "screendump " #$output
                                               "/post-initrd-passphrase.ppm")
                                #$marionette))))))

(define (run-lvm-on-luks-test)
  "Run the basic test suite on an OS with LVM on LUKS."
  (define os
    (marionette-operating-system
     %lvm-on-luks-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  ;; Use the generic disk image builder with LVM-on-LUKS initializer
  (define image
    (build-disk-image os
                      #:disk-initializer (make-lvm-on-luks-disk-initializer
                                          #:luks-passphrase %luks-passphrase
                                          #:luks-uuid %luks-uuid)
                      #:disk-size (* 4096 1024 1024)  ; 4 GiB (need more space for LUKS + LVM)
                      #:uefi? #t
                      #:name "lvm-on-luks-image"))

  (define vm-command
    #~(list (string-append #$qemu-minimal "/bin/"
                           #$(qemu-command))
            "-m" "1024"  ; More memory for crypto operations
            "-bios" #$(file-append ovmf-x86-64 "/share/firmware/ovmf_x64.bin")
            "-drive"
            (string-append "file=" #$image
                           ",format=qcow2,if=virtio")
            "-snapshot"  ; Use snapshot mode since image is in read-only store
            "-no-reboot"
            #$@(if (file-exists? "/dev/kvm")
                   '("-enable-kvm")
                   '())))

  (run-basic-test os vm-command "lvm-on-luks"
                  #:initialization enter-luks-passphrase))

;;;
;;; System test definition
;;;

(define %test-lvm-on-luks
  (system-test
   (name "lvm-on-luks")
   (description "Test basic functionality of a Guix System with LVM on LUKS encryption.")
   (value (run-lvm-on-luks-test))))