;;; 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 mcron)
  #: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-base-zfs-auto-snapshot
            zfs-configuration-dependencies
            zfs-configuration-auto-mount?
            zfs-configuration-auto-scrub
            zfs-configuration-auto-snapshot?
            zfs-configuration-auto-snapshot-keep

            %zfs-zvol-dependency))

(define-record-type* <zfs-configuration>
  zfs-configuration
  make-zfs-configuration
  zfs-configuration?

  ; linux-libre kernel you want to compile the base-zfs module for.
  (kernel                     zfs-configuration-kernel)

  ; the OpenZFS package that will be modified to compile for the
  ; given kernel.
  (base-zfs                   zfs-configuration-base-zfs
                              (default zfs))

  ; the zfs-auto-snapshot package that will be modified to compile
  ; for the given kernel.
  (base-zfs-auto-snapshot     zfs-configuration-base-zfs-auto-snapshot
                              (default zfs-auto-snapshot))

  ; list of <mapped-device> or <file-system> objects that must be
  ; opened/mounted before we import any ZFS pools.
  (dependencies               zfs-configuration-dependencies
                              (default '()))

  ; #t if mountable datasets are to be mounted automatically.
  ; #f if not mounting.
  ; #t is the expected behavior on other operating systems, the
  ; #f is only supported for "rescue" operating systems where
  ; the user wants lower-level control of when to mount.
  (auto-mount?                zfs-configuration-auto-mount?
                              (default #t))

  ; 'weekly for weekly scrubbing, 'monthly for monthly scrubbing, an
  ; mcron time specification that can be given to `job`, or #f to
  ; disable.
  (auto-scrub                 zfs-configuration-auto-scrub
                              (default 'weekly))

  ; #t if auto-snapshot is default (and `com.sun:auto-snapshot=false`
  ; disables auto-snapshot per dataset), #f if no auto-snapshotting
  ; is default (and `com.sun:auto-snapshot=true` enables auto-snapshot
  ; per dataset).
  (auto-snapshot?             zfs-configuration-auto-snapshot?
                              (default #t))

  ; association list of symbol-number pairs to indicate the number
  ; of automatic snapshots to keep for each of 'frequent, 'hourly,
  ; 'daily, 'weekly, and 'monthly.
  ; e.g. '((frequent . 8) (hourly . 12))
  (auto-snapshot-keep         zfs-configuration-auto-snapshot-keep
                              (default '())))

(define %default-auto-snapshot-keep
  '((frequent . 4)
    (hourly . 24)
    (daily . 31)
    (weekly . 8)
    (monthly . 12)))

(define %auto-snapshot-mcron-schedule
  '((frequent .  "0,15,30,45 * * * *")
    (hourly .    "0 * * * *")
    (daily .     "0 0 * * *")
    (weekly .    "0 0 * * 7")
    (monthly .   "0 0 1 * *")))

;; A synthetic and unusable MAPPED-DEVICE intended for use when
;; the user has created a mountable filesystem inside a ZFS
;; zvol and wants it mounted inside the configuration.scm.
(define %zfs-zvol-dependency
  (mapped-device
    (source '())
    (targets '("zvol/*"))
    (type #f)))

(define (make-zfs-package conf)
  (let ((kernel    (zfs-configuration-kernel conf))
        (base-zfs  (zfs-configuration-base-zfs conf)))
    (package
      (inherit base-zfs)
      (arguments (cons* #:linux kernel
                        (package-arguments base-zfs))))))

(define (make-zfs-auto-snapshot-package conf)
  (let ((zfs                    (make-zfs-package conf))
        (base-zfs-auto-snapshot (zfs-configuration-base-zfs-auto-snapshot conf)))
    (package
      (inherit base-zfs-auto-snapshot)
      (inputs `(("zfs" ,zfs))))))

(define (zfs-loadable-modules 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))
        (requirement `(root-file-system
                       kernel-module-loader
                       udev
                       ,@(map dependency->shepherd-service-name
                              (zfs-configuration-dependencies conf))))
        (documentation "Scans for and imports ZFS pools.")
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "zfs: error importing pools: ~s~%"
                                      (condition-message c))
                              #f))
                     ; TODO: optionally use a cachefile.
                     (invoke #$zpool "import" "-a" "-N"))))
        ;; Why not one-shot?  Because we don't really want to rescan
        ;; this each time a requiring process is restarted, as scanning
        ;; can take a long time and a lot of I/O.
        (stop #~(const #f))))

    (define device-mapping-zvol/*
      (shepherd-service
        (provision '(device-mapping-zvol/*))
        (requirement '(zfs-scan))
        (documentation "Waits for all ZFS ZVOLs to be opened.")
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "zfs: error opening zvols: ~s~%"
                                      (condition-message c))
                              #f))
                     (invoke #$zvol_wait))))
        (stop #~(const #f))))

    (define zfs-auto-mount
      (shepherd-service
        (provision '(zfs-auto-mount))
        (requirement '(zfs-scan))
        (documentation "Mounts all non-legacy mounted ZFS filesystems.")
        (modules scheme-modules)
        (start #~(lambda _
                   (guard (c ((message-condition? c)
                              (format (current-error-port)
                                      "zfs: error mounting file systems: ~s~%"
                                      (condition-message c))
                              #f))
                     ;; Output to current-error-port, otherwise the
                     ;; user will not see any prompts for passwords
                     ;; of encrypted datasets.
                     ;; XXX Maybe better to explicitly open /dev/console ?
                     (with-output-to-port (current-error-port)
                       (lambda ()
                         (invoke #$zfs "mount" "-a" "-l"))))))
        (stop #~(lambda _
                  ;; Make sure that Shepherd does not have a CWD that
                  ;; is a mounted ZFS filesystem, which would prevent
                  ;; unmounting.
                  (chdir "/")
                  (invoke #$zfs "unmount" "-a" "-f")))))

    `(,zfs-scan
      ,device-mapping-zvol/*
      ,@(if (zfs-configuration-auto-mount? conf)
            `(,zfs-auto-mount)
            '()))))

(define (zfs-user-processes conf)
  (if (zfs-configuration-auto-mount? conf)
      '(zfs-auto-mount)
      '(zfs-scan)))

(define (zfs-mcron-auto-snapshot-jobs conf)
  (let* ((user-auto-snapshot-keep      (zfs-configuration-auto-snapshot-keep conf))
         ;; assoc-ref has earlier entries overriding later ones.
         (auto-snapshot-keep           (append user-auto-snapshot-keep
                                               %default-auto-snapshot-keep))
         (auto-snapshot?               (zfs-configuration-auto-snapshot? conf))
         (zfs-auto-snapshot-package    (make-zfs-auto-snapshot-package conf))
         (zfs-auto-snapshot            (file-append zfs-auto-snapshot-package
                                                    "/sbin/zfs-auto-snapshot")))
    (map
      (lambda (label)
        (let ((keep   (assoc-ref auto-snapshot-keep label))
              (sched  (assoc-ref %auto-snapshot-mcron-schedule label)))
          #~(job '#$sched
                 (string-append #$zfs-auto-snapshot
                                " --quiet --syslog "
                                " --label=" #$(symbol->string label)
                                " --keep=" #$(number->string keep)
                                " //"))))
      '(frequent hourly daily weekly monthly))))

(define (zfs-mcron-auto-scrub-jobs conf)
  (let* ((zfs-package    (make-zfs-package conf))
         (zpool          (file-append zfs-package "/sbin/zpool"))
         (auto-scrub     (zfs-configuration-auto-scrub conf))
         (sched          (cond
                           ((eq? auto-scrub 'weekly)  "0 0 * * 7")
                           ((eq? auto-scrub 'monthly) "0 0 1 * *")
                           (else                      auto-scrub))))
    (list
      #~(job '#$sched
             ;; Suppress errors: if there are no ZFS pools, the
             ;; scrub will not be given any arguments, which makes
             ;; it error out.
             (string-append "(" #$zpool " scrub `" #$zpool " list -o name -H` "
                            "> /dev/null 2>&1) "
                            "|| exit 0")))))

(define (zfs-mcron-jobs conf)
  (append (zfs-mcron-auto-snapshot-jobs conf)
          (if (zfs-configuration-auto-scrub conf)
              (zfs-mcron-auto-scrub-jobs conf)
              '())))

(define zfs-service-type
  (service-type
    (name 'zfs)
    (extensions
      (list ;; Install OpenZFS kernel module into kernel profile.
            (service-extension linux-loadable-module-service-type
                               zfs-loadable-modules)
            ;; And load it.
            (service-extension kernel-module-loader-service-type
                               (const '("zfs")))
            ;; Make sure ZFS pools and datasets are mounted at
            ;; boot.
            (service-extension shepherd-root-service-type
                               zfs-shepherd-services)
            ;; Make sure user-processes don't start until
            ;; after ZFS does.
            (service-extension user-processes-service-type
                               zfs-user-processes)
            ;; Install automated scrubbing and snapshotting.
            (service-extension mcron-service-type
                               zfs-mcron-jobs)

            ;; Install ZFS management commands in the system
            ;; profile.
            (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 "Installs ZFS, an advanced filesystem and volume manager.")))