services: btrfs: add snapshot services

1 files changed, 295 insertions, 0 deletions

diff --git a/yellowsquid/services/btrfs.scm b/yellowsquid/services/btrfs.scm
new file mode 100644
index 0000000..afa38d8
--- /dev/null
+++ b/yellowsquid/services/btrfs.scm
@@ -0,0 +1,295 @@
+(define-module (yellowsquid services btrfs)
+  #:use-module (gnu home services)
+  #:use-module (gnu home services mcron)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services mcron)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (<snapshot-location>
+            snapshot-location
+            make-snapshot-location
+            snapshot-location?
+            snapshot-location-name
+            snapshot-location-path
+
+            <snapshot-frequency>
+            snapshot-frequency
+            make-snapshot-frequency
+            snapshot-frequency?
+            snapshot-frequency-name
+            snapshot-frequency-min-period
+            snapshot-frequency-max-keep
+
+            list-of-locations?
+            list-of-frequencies?
+
+            <btrfs-snapshot-configuration>
+            btrfs-snapshot-configuration
+            make-btrfs-snapshot-configuration
+            btrfs-snapshot-configuration?
+            btrfs-snapshot-configuration-btrfs-progs
+            btrfs-snapshot-configuration-destination
+            btrfs-snapshot-configuration-frequencies
+            btrfs-snapshot-configuration-locations
+            btrfs-snapshot-configuration-ts-format
+
+            btrfs-snapshot-service-type
+            home-btrfs-snapshot-service-type))
+
+(define-record-type* <snapshot-location>
+  snapshot-location make-snapshot-location
+  snapshot-location?
+  (name snapshot-location-name)
+  (path snapshot-location-path))
+
+(define-record-type* <snapshot-frequency>
+  snapshot-frequency make-snapshot-frequency
+  snapshot-frequency?
+  (name snapshot-frequency-name)
+  ;; in seconds
+  (min-period snapshot-frequency-min-period)
+  (max-keep snapshot-frequency-max-keep))
+
+(define list-of-locations?
+  (list-of snapshot-location?))
+
+(define list-of-frequencies?
+  (list-of snapshot-frequency?))
+
+(define-configuration/no-serialization btrfs-snapshot-configuration
+  (btrfs-progs
+   (package btrfs-progs)
+   "The btrfs package to use.")
+  (destination
+   (string "/backup")
+   "Root directory where backups are stored.")
+  (frequencies
+   (list-of-frequencies '())
+   "List of backup frequencies.")
+  (locations
+   (list-of-locations '())
+   "List of locations to backup.")
+  (ts-format
+   (string "%FT%T")
+   "File timestamp format."))
+
+(define (frobnicate destination freq loc)
+  (string-append (if (string-suffix? "/" destination)
+                     destination
+                     (string-append destination "/"))
+                 (symbol->string (snapshot-location-name loc))
+                 "/"
+                 (symbol->string (snapshot-frequency-name freq))
+                 "/"))
+
+(define (btrfs-snapshot-one-job destination btrfs ts-format freq loc)
+  (define dest (frobnicate destination freq loc))
+
+  (define name->path+date
+    #~(lambda (name)
+        "Converts the NAME of a snapshot into the path to the snapshot and the
+date it was created."
+        (let ((strptimed
+               (false-if-exception (strptime #$ts-format name))))
+          (and strptimed
+               (list (string-append #$dest name)
+                     (car (mktime (car strptimed) "GMT")))))))
+
+  (define name->date
+    #~(lambda (name)
+        "Converts the NAME of a snapshot into the date it was created."
+        (let ((path+date (#$name->path+date name)))
+          (and path+date (cadr path+date)))))
+
+  (define next-create
+    #~(lambda (date)
+        "Returns the next time after DATE that a new snapshot can be created."
+        (+ date #$(snapshot-frequency-min-period freq))))
+
+  (define first-delete
+    #~(lambda (date)
+        "Returns the first time after DATE that this snapshot can be deleted."
+        (+ date #$(snapshot-frequency-max-keep freq))))
+
+  (define make-time
+    #~(lambda (date)
+        "Returns DATE as a string."
+        (strftime #$ts-format (gmtime date))))
+
+  (list
+   #~(job (lambda (now)
+            (use-modules (ice-9 ftw))
+            (let* ((scanned (or (scandir #$dest) '()))
+                   (dates (filter-map
+                           #$name->date
+                           scanned)))
+              (if (null? dates)
+                  (next-minute-from now)
+                  (max (if (< (abs (- now (current-time))) 5)
+                           (next-minute-from (1+ now))
+                           (let ((time (localtime now)))
+                             (set-tm:year time (+ 1000 (tm:year time)))
+                             (car (mktime time))))
+                       (apply max (map #$next-create dates))))))
+          #$(program-file
+             (string-append "backup-create-"
+                            (symbol->string (snapshot-location-name loc))
+                            "-"
+                            (symbol->string (snapshot-frequency-name freq))
+                            ".scm")
+             (with-imported-modules
+                 (source-module-closure '((guix build utils)))
+               #~(begin
+                   (use-modules (guix build utils)
+                                (ice-9 ftw)
+                                (ice-9 match)
+                                (srfi srfi-1))
+
+                   (let* ((now (current-time))
+                          (scanned (or (scandir #$dest)
+                                       (begin (mkdir-p #$dest) '())))
+                          (dates (filter-map #$name->date scanned))
+                          (skip? (any (lambda (date)
+                                        (and (< now (#$next-create date))
+                                             date))
+                                      dates)))
+                     (if skip?
+                         (format
+                          #t
+                          "Skipping ~a backup of ~a as last success was at ~a.\n"
+                          #$(symbol->string (snapshot-frequency-name freq))
+                          #$(symbol->string (snapshot-location-name loc))
+                          (#$make-time skip?))
+                         (invoke
+                          #$btrfs
+                          "subvolume"
+                          "snapshot"
+                          "-r"
+                          #$(snapshot-location-path loc)
+                          (string-append
+                           #$dest
+                           (#$make-time (current-time)))))))))
+          #$(format #f
+                    "Create a ~a backup of ~a."
+                    (symbol->string (snapshot-frequency-name freq))
+                    (symbol->string (snapshot-location-name loc))))
+   #~(job (lambda (now)
+            (use-modules (ice-9 ftw))
+            (let* ((scanned (or (scandir #$dest) '()))
+                   (dates (filter-map
+                           #$name->date
+                           scanned)))
+              (if (null? dates)
+                  (next-minute-from now)
+                  (max (if (< (abs (- now (current-time))) 5)
+                           (next-minute-from (1+ now))
+                           (let ((time (localtime now)))
+                             (set-tm:year time (+ 1000 (tm:year time)))
+                             (car (mktime time))))
+                       (apply min (map #$first-delete dates))))))
+          #$(program-file
+             (string-append "backup-delete-"
+                            (symbol->string (snapshot-location-name loc))
+                            "-"
+                            (symbol->string (snapshot-frequency-name freq))
+                            ".scm")
+             (with-imported-modules
+                 (source-module-closure '((guix build utils)))
+               #~(begin
+                   (use-modules (guix build utils)
+                                (ice-9 ftw)
+                                (ice-9 match)
+                                (srfi srfi-1))
+
+                   (let* ((now (current-time))
+                          (scanned (or (scandir #$dest)
+                                       (begin (mkdir-p #$dest) '())))
+                          (path-dates (filter-map #$name->path+date scanned))
+                          (del (filter-map
+                                (match-lambda
+                                  ((path date)
+                                   (and (> now (#$first-delete date))
+                                        path)))
+                                path-dates)))
+                     (for-each
+                      (lambda (path)
+                        (invoke #$btrfs
+                                "property"
+                                "set"
+                                path
+                                "ro"
+                                "false"))
+                      del)
+                     (unless (null? del)
+                       (apply invoke
+                              #$btrfs
+                              (cons* "subvolume" "delete" "-c" del)))))))
+          #$(format #f
+                    "Delete a ~a backup of ~a."
+                    (symbol->string (snapshot-frequency-name freq))
+                    (symbol->string (snapshot-location-name loc))))))
+
+(define (btrfs-snapshot-jobs config)
+  "Returns a list of mcron jobs to manage local backups."
+  (define (product xs ys)
+    (match xs
+      (() '())
+      ((x xs ...) (append (map (lambda (y) (list x y)) ys) (product xs ys)))))
+
+  (match-record config <btrfs-snapshot-configuration>
+    (btrfs-progs destination frequencies locations ts-format)
+    (append-map
+     (match-lambda
+       ((freq loc)
+        (btrfs-snapshot-one-job
+         destination
+         (file-append btrfs-progs "/bin/btrfs")
+         ts-format
+         freq
+         loc)))
+     (product frequencies locations))))
+
+(define (btrfs-snapshot-activation config)
+  "Returns a list of mcron jobs to manage local backups."
+  (match-record config <btrfs-snapshot-configuration>
+    (btrfs-progs destination frequencies locations ts-format)
+    #~(begin
+        #@(append-map
+           (lambda (loc)
+             (map
+              (lambda (freq)
+                #~(mkdir-p #$(frobnicate destination loc freq)))
+              frequencies))
+           locations))))
+
+(define home-btrfs-snapshot-service-type
+  (service-type (name 'home-btrfs-snapshot-service)
+                (extensions
+                 (list (service-extension
+                        home-mcron-service-type
+                        btrfs-snapshot-jobs)
+                       (service-extension
+                        home-activation-service-type
+                        btrfs-snapshot-activation)))
+                (default-value (btrfs-snapshot-configuration))
+                (description "Create jobs to keep a rolling set of backups for
+some btrfs subvolumes.")))
+
+(define btrfs-snapshot-service-type
+  (service-type (name 'btrfs-snapshot-service)
+                (extensions
+                 (list (service-extension
+                        mcron-service-type
+                        btrfs-snapshot-jobs)
+                       (service-extension
+                        activation-service-type
+                        btrfs-snapshot-activation)))
+                (default-value (btrfs-snapshot-configuration))
+                (description "Create jobs to keep a rolling set of backups for
+some btrfs subvolumes.")))