;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
;;;
;;; 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 services file-systems)
  #:use-module (gnu packages file-systems)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services linux)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system mapped-devices)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:export (zfs-service-type

            zfs-configuration
            zfs-configuration?
            zfs-configuration-kernel
            zfs-configuration-base-zfs
            zfs-configuration-dependencies

            %zfs-zvol-dependency))

(define-record-type* <zfs-configuration>
  zfs-configuration make-zfs-configuration zfs-configuration?
  ; kernel you want to compile the base-zfs module for.
  (kernel         zfs-configuration-kernel)
  ; base package that will be compiled for the kernel
  (base-zfs       zfs-configuration-base-zfs
                  (default zfs))
  ; list of <mapped-device> | <file-system> we should wait for,
  ; before scanning for ZFS pools.
  (dependencies   zfs-configuration-dependencies
                  (default '())))

;; This is a synthetic and unusable MAPPED-DEVICE; its only use
;; is to be added as a (dependency ...) of some FILE-SYSTEM.
(define %zfs-zvol-dependency
  (mapped-device
    (source '())
    ;; The /* prevents naming conflict with non-ZFS device mappings,
    ;; since it is not a valid name for mapped devices, and also
    ;; implies "all zvols" in terms of globs.
    (targets '("zvol/*"))
    (type #f)))

(define (make-zfs-package conf)
  (let ((base-zfs (zfs-configuration-base-zfs conf))
        (kernel   (zfs-configuration-kernel conf)))
    (package
      (inherit base-zfs)
      (name (string-join (list (package-name base-zfs)
                               "for"
                               (package-name kernel)
                               (package-version kernel)
                               "version")
                         "-"))
      (arguments (cons* #:linux kernel (package-arguments base-zfs))))))

(define (zfs-loadable-module conf)
  (list (list (make-zfs-package conf) "module")))

(define (zfs-shepherd-services conf)
  (let* ((zfs-package     (make-zfs-package conf))
         (zpool           (file-append zfs-package "/sbin/zpool"))
         (zfs             (file-append zfs-package "/sbin/zfs"))
         (zvol_wait       (file-append zfs-package "/bin/zvol_wait"))
         (scheme-modules  `((srfi srfi-1)
                            (srfi srfi-34)
                            (srfi srfi-35)
                            (rnrs io ports)
                            ,@%default-modules)))

    (define zfs-scan
      (shepherd-service
        (provision '(zfs-scan))
        (documentation "Scans for ZFS pools.")
        (requirement `(kernel-module-loader
                       root-file-system
                       ,@(map dependency->shepherd-service-name
                              (zfs-configuration-dependencies conf))))
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "error importing zpools: ~a~%"
                                      (condition-message c))
                              #f))
                     ; TODO: optionally use a cachefile, for systems with dozens or
                     ; hundreds of devices.
                     (invoke/quiet #$zpool "import" "-a" "-N"))))
        (stop #~(const #t))))

    (define device-mapping-zvol/*
      (shepherd-service
        (provision '(device-mapping-zvol/*))
        (documentation "Waits for ZFS ZVOL devices to appear.")
        (requirement '(zfs-scan))
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "error waiting for zvols: ~a~%"
                                      (condition-message c))
                              #f))
                     (invoke/quiet #$zvol_wait))))
        (stop #~(const #t))))

    (define zfs-automount
      (shepherd-service
        (provision '(zfs-automount))
        (documentation "Automounts ZFS datasets.")
        (requirement '(zfs-scan))
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "error automounting zfs: ~a~$")
                              #f))
                     ; (current-output-port) is typically connected to /dev/klog,
                     ; so redirect it to (current-error-port) so that user can see
                     ; prompts for passphrases on console
                     (with-output-to-port (current-error-port)
                       (lambda ()
                         (invoke #$zfs "mount" "-a" "-l"))))))
        (stop #~(lambda _
                  ;; make sure we don't keep any ZFS mountpoints busy.
                  (chdir "/")
                  ;; unmount everything.
                  (invoke/quiet #$zfs "unmount" "-a" "-f")))))

    (list zfs-scan
          device-mapping-zvol/*
          zfs-automount)))

(define zfs-service-type
  (service-type (name 'zfs)
                (extensions
                  (list
                    ; install the kernel module
                    (service-extension kernel-loadable-module-service-type
                                       zfs-loadable-module)
                    ; load the kernel module
                    (service-extension kernel-module-loader-service-type
                                       (const '("zfs")))
                    ; scan ZFS pools, automount filesystem, wait for zvols.
                    (service-extension shepherd-root-service-type
                                       zfs-shepherd-services)
                    ; make sure automount occurs before file-systems target is reached
                    (service-extension file-systems-target-service-type
                                       (const '(zfs-automount)))
                    ; install ZFS management tools
                    (service-extension profile-service-type
                                       (compose list make-zfs-package))
                    ; install ZFS udev rules
                    (service-extension udev-service-type
                                       (compose list make-zfs-package))))
                (description
                  "Install ZFS, an advanced filesystem and volume manager.")))