Subject: [PATCH] WIP snapper fixes and snapperd service

From: raingloom <[email-masked]>
Date: Sun, 24 Jan 2021 03:13:37 +0100

Hi!

I have a technically working but still only lightly tested and not very
user friendly patch set for making Snapper work!

Included is Pierre Neidhardt's original patch, followed by my patches.

How to try it:
Everything needs sudo for now, sorry about that. This could probably be
changed so that users could administrate configs pertaining only to
their home dirs, but it looks like ading new configs will require sudo
no matter what.

0. Have a BTRFS file system mounted somewhere. You may have heard that
other setups (like ext4 or thin LVM) also works, but based on issue
tracker activity, it looks very much like they don't, or aren't
maintained and can break at any time.

```
# Create new subvolume
btrfs subvolume create
# Attempt to create a new config without understanding what you're
getting into:
sudo snapper -c my-config-name create-config path/to/subvolume
# This will show informative messages like `Failure (error.something).`
# Obviously this is because you haven't populated the relevant parts of
# /etc. Duh. So do this, and think about how fun it must have been to
# track down the sources of these messages.
sudo cp -r $(./pre-inst-env guix build snapper)/etc/snapper /etc/snapper
sudo install -D -m 644 $(./pre-inst-env guix build --source snapper)/data/sysconfig.snapper /etc/sysconfig/snapper
# Add snapper-service-type to an operating-system. I assume you know how to do it on your own.
# If anything breaks:
sudo herd status snapperd
# It sometimes stops for some reason? Just enable it and restart.
# Anyways, now you can create a configuration. :D
sudo snapper -c my-config-name create-config path/to/subvolume
```

Now just continue trying stuff from one of the many Snapper tutorials
around the net, like the Arch Wiki one.

Yay! Was that unnecessarily hard? It was. That's why this is a WIP
patchset and why I need some tips on making it work better.

* Should snapper be configured to use something other than
  /etc/sysconfig? The sysconfig subdirectory doesn't really make sense
  on Guix, but maybe it's not worth bikeshedding.
* (How) should homes be converted to BTRFS subvolumes?
* Snapshot scheduling is still TODO.
* Should /etc/snapper even be mutable? How to handle the configuration
  data type?

TLDR: I have some ideas on how to proceed, but would welcome some input
from people who have some experience setting up backups and
snapshotting, either on Guix, or Nix, or some traditional distro.
>From d36491046c1ab0eeab517fd153da319dc0793451 Mon Sep 17 00:00:00 2001
From: Pierre Neidhardt <[email-masked]>
Date: Sat, 26 Jan 2019 17:52:35 +0100
Subject: [PATCH 1/3] gnu: Add snapper.

* gnu/packages/linux.scm (snapper): New variable.
---
 gnu/packages/linux.scm | 107 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 107 insertions(+)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 2497e0dea9..6bc3f1e52a 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -5081,6 +5081,113 @@ uncompressed size will not match the number given by @command{tar} or
 obviously it can be shared with files outside our set).")
     (license license:gpl2+)))
 
+(define-public snapper
+  (package
+    (name "snapper")
+    (version "0.8.2")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "ftp://ftp.suse.com/pub/projects/snapper/snapper-"
+                                  version
+                                  ".tar.bz2"))
+              (sha256
+               (base32
+                "0s73x5h0fdggcxxcmjlf1q7pqlwd1ac4pngwsm6ayg8n4gxk3acy"))))
+    (build-system gnu-build-system)
+    (arguments
+     `( ;; TODO: 2 tests are failing:
+       ;; unknown location(0): fatal error: in "test_byte_to_humanstring": std::runtime_error: locale::facet::_S_create_c_locale name not valid
+       ;; unknown location(0): fatal error: in "test_big_numbers": std::runtime_error: locale::facet::_S_create_c_locale name not valid
+       ;; unknown location(0): fatal error: in "test1": std::runtime_error: locale::facet::_S_create_c_locale name not valid
+       #:tests? #f
+       #:configure-flags (list
+                          (string-append "CPPFLAGS="
+                                         "-I"
+                                         (assoc-ref %build-inputs "libxml2")
+                                         "/include/libxml2")
+                          "--disable-zypp")
+       #:phases
+       (modify-phases %standard-phases
+         (add-before 'build 'make-local-docbook-xml
+           (lambda* (#:key inputs #:allow-other-keys)
+             (substitute* "doc/html.xsl"
+               (("http://docbook.sourceforge.net/release/xsl/current/xhtml/docbook.xsl")
+                (string-append (assoc-ref inputs "docbook-xsl")
+                               "/xml/xsl/docbook-xsl-"
+                               ,(package-version docbook-xsl)
+                               "/xhtml/docbook.xsl")))
+             (substitute* "doc/manpages.xsl"
+               (("http://docbook.sourceforge.net/release/xsl/current/manpages/docbook.xsl")
+                (string-append (assoc-ref inputs "docbook-xsl")
+                               "/xml/xsl/docbook-xsl-"
+                               ,(package-version docbook-xsl)
+                               "/manpages/docbook.xsl")))
+             #t))
+         (add-before 'build 'patch-makefiles
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out")))
+               (substitute* "client/Makefile.am"
+                 (("libexecdir = /usr/lib/snapper")
+                  (string-append "libexecdir = " out
+                                 "/lib/snapper")))
+               ;; TODO: Why is $(DESTDIR) not doing the right thing for scripts?
+               ;; Changing it in #:make-flags produces the wrong behaviour.
+               (substitute* "scripts/Makefile.am"
+                 (("\\$\\(DESTDIR\\)") out)
+                 (("(pam_snapperdir = )/usr(/lib/pam_snapper)" _ before after)
+                  (string-append before out after)))
+               (substitute* "data/Makefile.am"
+                 (("\\$\\(DESTDIR\\)") out))
+               (substitute* "pam/Makefile.am"
+                 (("(securelibdir = )\\$\\(shell echo /`basename \\$\\(libdir\\)`/security\\)" _ before)
+                  (string-append before out "/lib/security"))))
+             #t))
+         (add-after 'install 'clean-up-systemd-services
+           (lambda* (#:key outputs #:allow-other-keys)
+             ;; TODO: Maybe we should not remove everything, we need dbus.
+             (delete-file-recursively
+              (string-append (assoc-ref outputs "out") "/usr"))
+             #t)))))
+    (native-inputs
+     `(("pkg-config" ,pkg-config)
+       ("gettext" ,gettext-minimal)     ;for msgfmt
+       ("libxslt" ,libxslt)
+       ("docbook-xsl" ,docbook-xsl)
+       ("autoconf" ,autoconf)
+       ("automake" ,automake)))
+    (inputs
+     `(("libmount" ,util-linux)
+       ("dbus" ,dbus)
+       ("acl" ,acl)
+       ("boost" ,boost)
+       ("libxml2" ,libxml2)
+       ("btrfs-progs" ,btrfs-progs)
+       ("e2fsprogs" ,e2fsprogs)
+       ("linux-pam" ,linux-pam)))
+    (home-page "http://snapper.io/")
+    (synopsis "Manage BTRFS and LVM snapshots")
+    (description " Snapper is a tool for Linux filesystem snapshot
+management.  Apart from the obvious creation and deletion of snapshots, it can
+compare snapshots and revert differences between snapshots.  In simple terms,
+this allows root and non-root users to view older versions of files and revert
+changes.
+
+The features include:
+
+@itemize
+@item Manually create snapshots.
+@item Automatically create snapshots.
+@item Automatically create timeline of snapshots.
+@item Show and revert changes between snapshots.
+@item Works with btrfs, ext4 and thin-provisioned LVM volumes.
+@item Supports Access Control Lists and Extended Attributes.
+@item Automatic cleanup of old snapshots.
+@item Command line interface.
+@item D-Bus interface.
+@item PAM module to create snapshots during login and logout.
+@end itemize\n")
+    (license license:gpl2)))
+
 (define-public f2fs-tools-1.7
   (package
     (name "f2fs-tools")
-- 
2.30.0

>From e7e454785b7d449376448485643e704e72a20d9e Mon Sep 17 00:00:00 2001
From: raingloom <[email-masked]>
Date: Wed, 6 Jan 2021 22:13:14 +0100
Subject: [PATCH 2/3] gnu: WIP update Snapper.

---
 gnu/packages/linux.scm | 78 ++++++++++++++++++++++++++++--------------
 1 file changed, 52 insertions(+), 26 deletions(-)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 6bc3f1e52a..16279e50c3 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -74,6 +74,7 @@
   #:use-module (gnu packages acl)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages algebra)
+  #:use-module (gnu packages attr)
   #:use-module (gnu packages audio)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages backup)
@@ -5084,15 +5085,15 @@ obviously it can be shared with files outside our set).")
 (define-public snapper
   (package
     (name "snapper")
-    (version "0.8.2")
+    (version "0.8.15")
     (source (origin
-              (method url-fetch)
-              (uri (string-append "ftp://ftp.suse.com/pub/projects/snapper/snapper-"
-                                  version
-                                  ".tar.bz2"))
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/openSUSE/snapper")
+                    (commit (string-append "v" version))))
               (sha256
                (base32
-                "0s73x5h0fdggcxxcmjlf1q7pqlwd1ac4pngwsm6ayg8n4gxk3acy"))))
+                "1rqv1qfxr02qbkix1mpx91s4827irxryxkhby3ii0fdkm3ympsas"))))
     (build-system gnu-build-system)
     (arguments
      `( ;; TODO: 2 tests are failing:
@@ -5105,7 +5106,12 @@ obviously it can be shared with files outside our set).")
                                          "-I"
                                          (assoc-ref %build-inputs "libxml2")
                                          "/include/libxml2")
-                          "--disable-zypp")
+                          ;; SUSE package manager stuff
+                          "--disable-zypp"
+                          ;; We have Shepherd.
+                          "--disable-systemd"
+                          ;; Don't use /etc/sysconfig, just /etc.
+                          "--with-conf=/etc")
        #:phases
        (modify-phases %standard-phases
          (add-before 'build 'make-local-docbook-xml
@@ -5121,11 +5127,14 @@ obviously it can be shared with files outside our set).")
                 (string-append (assoc-ref inputs "docbook-xsl")
                                "/xml/xsl/docbook-xsl-"
                                ,(package-version docbook-xsl)
-                               "/manpages/docbook.xsl")))
-             #t))
+                               "/manpages/docbook.xsl")))))
          (add-before 'build 'patch-makefiles
            (lambda* (#:key outputs #:allow-other-keys)
              (let ((out (assoc-ref outputs "out")))
+               (substitute* "client/utils/Makefile.am"
+                 ;; I ain't patching ncurses to alias ncurses to ltinfo.
+                 ;; Also adds libjson-c, which is missing for some reason.
+                 (("-ltinfo") "-lncurses -ljson-c"))
                (substitute* "client/Makefile.am"
                  (("libexecdir = /usr/lib/snapper")
                   (string-append "libexecdir = " out
@@ -5140,30 +5149,47 @@ obviously it can be shared with files outside our set).")
                  (("\\$\\(DESTDIR\\)") out))
                (substitute* "pam/Makefile.am"
                  (("(securelibdir = )\\$\\(shell echo /`basename \\$\\(libdir\\)`/security\\)" _ before)
-                  (string-append before out "/lib/security"))))
-             #t))
-         (add-after 'install 'clean-up-systemd-services
-           (lambda* (#:key outputs #:allow-other-keys)
-             ;; TODO: Maybe we should not remove everything, we need dbus.
-             (delete-file-recursively
-              (string-append (assoc-ref outputs "out") "/usr"))
-             #t)))))
+                  (string-append before out "/lib/security"))))))
+         (add-after 'install 'fix-paths...again
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out")))
+               (for-each
+                (lambda (f)
+                  (substitute* f
+                      (("CMD_SNAPPER=\"/usr/bin/snapper\"")
+                       (string-append out "/bin/snapper"))
+                    (("CMD_PAM_CONFIG=\"/usr/sbin/pam-config\"")
+                     (string-append (assoc-ref inputs "linux-pam") "/sbin/pam-config"))))
+                (apply append
+                       (map
+                        (lambda (d)
+                          (find-files (string-append out d) (const #t)))
+                        '("/lib/pam_snapper/"
+                          "/lib/systemd/system/"
+                          "/share/dbus-1/system-services/"))))))))))
     (native-inputs
-     `(("pkg-config" ,pkg-config)
+     `(("autoconf" ,autoconf)
+       ("automake" ,automake)
+       ("docbook-xsl" ,docbook-xsl)
+       ("docbook-xml" ,docbook-xml)
        ("gettext" ,gettext-minimal)     ;for msgfmt
+       ("libtool" ,libtool)
        ("libxslt" ,libxslt)
-       ("docbook-xsl" ,docbook-xsl)
-       ("autoconf" ,autoconf)
-       ("automake" ,automake)))
+       ("pkg-config" ,pkg-config)))
     (inputs
-     `(("libmount" ,util-linux)
-       ("dbus" ,dbus)
-       ("acl" ,acl)
+     `(("acl" ,acl)
+       ("attr" ,attr)
        ("boost" ,boost)
-       ("libxml2" ,libxml2)
        ("btrfs-progs" ,btrfs-progs)
+       ("dbus" ,dbus)
        ("e2fsprogs" ,e2fsprogs)
-       ("linux-pam" ,linux-pam)))
+       ("json-c" ,json-c)
+       ("libxml2" ,libxml2)
+       ("linux-pam" ,linux-pam)
+       ("ncurses" ,ncurses)
+       ("util-linux" ,util-linux "lib")
+       ("lvm2" ,lvm2)
+       ("util-linux" ,util-linux)))
     (home-page "http://snapper.io/")
     (synopsis "Manage BTRFS and LVM snapshots")
     (description " Snapper is a tool for Linux filesystem snapshot
-- 
2.30.0

>From 2fb7a62710d17cee87c5cf4c73df49fdee3b668f Mon Sep 17 00:00:00 2001
From: raingloom <[email-masked]>
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