;;; 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 shepherd)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:export (zfs-service-type
            zfs-configuration
            zfs-configuration?))

(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 string options.
  (options    zfs-configuration-options   (default '())))

(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")))
    (list
      (shepherd-service
        (documentation "Scans for ZFS pools and automounts filesystems.")
        (provision '(zfs-scan-automount))
        (requirement '(root-file-system))
        (modules `((srfi srfi-1)
                   (srfi srfi-34)
                   (srfi srfi-35)
                   (rnrs io ports)
                   ,@%default-modules))
        (start #~(lambda _
                   (and
                     ;; You'd think we could've used kernel-module-loader-service-type,
                     ;; but the kernel-module-loader shepherd service is dependent on
                     ;; file-systems, and file-systems is made dependent on this
                     ;; service. And we need the kernel module to be loaded before we
                     ;; scan for ZFS pools. So break the dependency loop by just
                     ;; loading ZFS module here by ourselves.
                     (or (file-exists? "/proc/sys/kernel/modprobe")
                         (begin
                           (format (current-error-port) "error loading 'zfs' module: ~a~%"
                                   "Kernel is missing loadable module support.")
                           #f))
                     (guard (c ((message-condition? c)
                                (format (current-error-port)
                                        "error loading 'zfs' module: ~a~%"
                                        (condition-message c))
                                #f))
                       (let ((modprobe (call-with-input-file "/proc/sys/kernel/modprobe"
                                                             get-line)))
                         (invoke/quiet modprobe "--" "zfs")))

                     ; scan for pools and automount contained datasets.
                     (guard (c ((message-condition? c)
                                (format (current-error-port)
                                        "error importing zpools: ~a~%"
                                        (condition-message?))
                                #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 #$zpool "import" "-a" "-l")))))))
        (stop #~(const #t))))))

(define (zfs-profile-service conf)
  (list (make-zfs-package conf)))

(define (zfs-etc-service conf)
  (let ((options (zfs-configuration-options conf)))
    (if (null? options)
        '()
        `(("modprobe.d/zfs.conf"
           ,(plain-file "zfs.conf"
                        (string-join (cons "options zfs" options) " ")))))))

(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 ZFS module, scan ZFS pools, and automount filesystems
                    (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-scan-automount)))
                    ; install ZFS management tools
                    (service-extension profile-service-type
                                       zfs-profile-service)
                    ; install ZFS module options
                    (service-extension etc-service-type
                                       zfs-etc-service)))
                (description
                  "Install ZFS, an advanced filesystem and volume manager.")))