>From 2fb7a62710d17cee87c5cf4c73df49fdee3b668f Mon Sep 17 00:00:00 2001
From: raingloom <raingloom@riseup.net>
Date: Fri, 8 Jan 2021 23:02:01 +0100
Subject: [PATCH 3/3] WIP: gnu: services: Added basics of snapper service.

---
 gnu/packages/linux.scm |  7 ++++-
 gnu/services/linux.scm | 60 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 66 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 16279e50c3..dca77e2fa4 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -5083,6 +5083,10 @@ obviously it can be shared with files outside our set).")
     (license license:gpl2+)))
 
 (define-public snapper
+  ;; TODO: create full system tests
+  ;; FIXME: client can't find "config template". what even is that.
+  ;; TODO: generate /etc/sysconfig/snapper from Guix
+  ;; TODO: snapperd should take a command line argument instead of hardcoding config path
   (package
     (name "snapper")
     (version "0.8.15")
@@ -5146,7 +5150,8 @@ obviously it can be shared with files outside our set).")
                  (("(pam_snapperdir = )/usr(/lib/pam_snapper)" _ before after)
                   (string-append before out after)))
                (substitute* "data/Makefile.am"
-                 (("\\$\\(DESTDIR\\)") out))
+                 (("\\$\\(DESTDIR\\)") out)
+                 (("/usr/") "/"))
                (substitute* "pam/Makefile.am"
                  (("(securelibdir = )\\$\\(shell echo /`basename \\$\\(libdir\\)`/security\\)" _ before)
                   (string-append before out "/lib/security"))))))
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index 1046a7e0c2..7dfee8d9cd 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -24,6 +24,7 @@
   #:use-module (guix modules)
   #:use-module (gnu services)
   #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
   #:use-module (gnu packages linux)
   #:use-module (srfi srfi-1)
@@ -46,6 +47,11 @@
 
             kernel-module-loader-service-type
 
+            snapper-configuration
+            snapper-configuration?
+            snapper-configuration-snapper
+            snapper-service-type
+
             zram-device-configuration
             zram-device-configuration?
             zram-device-configuration-size
@@ -187,6 +193,60 @@ representation."
    (extend append)
    (default-value '())))
 
+
+;;;
+;;; File system snapshotter
+;;;
+
+;; TODO: other services might want to extend it with filters
+;; TODO: extend PAM and snapshot home on login (see man pam_snapper)
+;; TODO: convert pam_snapper_homeconvert.sh into a shepherd service
+;; TODO: data type for snapper configs
+
+(define-record-type* <snapper-configuration>
+  snapper-configuration make-snapper-configuration
+  snapper-configuration?
+  (snapper snapper-configuration-snapper
+           (default snapper)))
+
+(define (snapper-scm->config key)
+  (let* ((key-lo (string-downcase key))
+         (maybe-scm-key (assoc-ref
+                         '(("file-system-type" . "fstype")
+                           ("quote-group" . "qgroup"))
+                         key-lo)))
+    (string-upcase
+     (string-map
+      (lambda (c)
+        (if (eq? #\- c)
+            #\_
+            c))
+      (or maybe-scm-key key-lo)))))
+
+(define (snapper-shepherd-service config)
+  (shepherd-service
+   (documentation "Run the Snapper daemon (snapperd).")
+   (provision '(snapperd))
+   (start #~(make-forkexec-constructor
+             '#$(list (file-append
+                       (snapper-configuration-snapper config)
+                       "/sbin/snapperd"))
+             #:log-file "/var/log/snapperd.log"))
+   (stop #~(make-kill-destructor))))
+
+(define snapper-service-type
+  (service-type
+   (name 'snapper)
+   (extensions
+    (list
+     (service-extension shepherd-root-service-type
+                        (compose list snapper-shepherd-service))
+     (service-extension dbus-root-service-type
+                        (compose list snapper-configuration-snapper))))
+   (default-value (snapper-configuration))
+   (description
+    "Create periodic snapshots on BTRFS subvolumes and thin LVM volumes")))
+
 
 ;;;
 ;;; Kernel module loader.
-- 
2.30.0