From 0b402ffc496d40f36b9ee9f53fbfc79fecee16e3 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Fri, 19 May 2023 10:15:01 -0400
Subject: [PATCH] hydra: berlin: Add an initial (incomplete) btrfs-send-job
 mcron job.

* hydra/berlin.scm (btrfs-send-job): New mcron job.
[services] <mcron-service-type>: Register it.
---
 hydra/berlin.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 80 insertions(+), 3 deletions(-)

diff --git a/hydra/berlin.scm b/hydra/berlin.scm
index 62c35ee..2f22f74 100644
--- a/hydra/berlin.scm
+++ b/hydra/berlin.scm
@@ -13,6 +13,7 @@
 (use-modules (gnu) (guix) (sysadmin services) (sysadmin people) (sysadmin dns)
              (sysadmin web)
              (guix git-download)
+             (guix modules)
              ((guix utils) #:select (current-source-directory))
              ((guix build utils) #:select (find-files))
              (srfi srfi-1)
@@ -249,6 +250,81 @@ file system than the default one hosted on the SAN storage."
                     "balance" "start" "-dusage=5" "/"))
          "btrfs-balance"))
 
+(define btrfs-send-job
+  ;; Take a snapshot of the substitutes, and send it to
+  ;; hydra-guix-129.
+  #~(job '(next-minute (range 0 60 10))
+         #$(program-file
+            "btrfs-send-publish"
+            (with-imported-modules (source-module-closure
+                                    '((guix build utils)))
+              #~(begin
+                  (use-modules (guix build utils)
+                               (ice-9 ftw)
+                               (ice-9 exceptions)
+                               (ice-9 match)
+                               (rnrs io simple)
+                               (srfi srfi-1)
+                               (srfi srfi-19)
+                               (srfi srfi-26))
+                  ;; TODO: Add non-overlapping job support to mcron
+                  ;; itself, instead of this ad-hoc advisory lock
+                  ;; based solution.
+                  (define %lock-file "/var/lock/mcron-btrfs-send-job.lock")
+
+                  (define (call-with-advisory-lock file thunk)
+                    (call-with-port (open-file file "r")
+                      (lambda (lock)
+                        (flock lock (logior LOCK_EX LOCK_NB))
+                        (thunk))))
+
+                  (define (create-and-send-snapshot)
+                    (let* ((subvolume-name "@publish")
+                           (subvolume (string-append "/mnt/btrfs-pool-san/"
+                                                     subvolume-name))
+                           (timestamp (date->string
+                                       (time-utc->date (current-time)) "~5"))
+                           (snapshot-name (string-append subvolume-name "."
+                                                         timestamp))
+                           (snapshots-dir "/mnt/btrfs-pool-san/snapshots/")
+                           (btrfs #$(file-append btrfs-progs "/bin/btrfs")))
+                      (mkdir-p snapshots-dir)
+                      (chdir snapshots-dir)
+                      ;; Create a new snapshot.
+                      (invoke btrfs "subvolume" "snapshot" "-r"
+                              subvolume snapshot-name)
+                      (let* ((snapshots (scandir "." (cut string-prefix?
+                                                          subvolume-name <>)))
+                             (old-snapshots (if (> (length snapshots) 2)
+                                                (drop-right snapshots 2)
+                                                '()))
+                             (recent-snapshots (if (> (length snapshots) 2)
+                                                   (take-right snapshots 2)
+                                                   snapshots))
+                             (snapshot (last recent-snapshots))
+                             (parent-snapshot (if (= 2 (length recent-snapshots))
+                                                  (first recent-snapshots)
+                                                  #f)))
+                        ;; Only preserve the last two snapshots.
+                        (for-each (cut invoke btrfs "subvolume" "delete" <>)
+                                  old-snapshots)
+                        ;; Send the snapshot to the remote server (hydra).
+                        (format
+                         #t "TODO: send snapshot to hydra-guix-129~%"))))
+
+                  ;; Create the lock file if it doesn't exist.
+                  (unless (file-exists? %lock-file)
+                    (mkdir-p (dirname %lock-file))
+                    (call-with-output-file %lock-file (const #t)))
+
+                  (guard (ex ((eq? 'system-error (exception-kind ex))
+                              (match (exception-args ex)
+                                (("flock" _ _ (11))
+                                 (format #t "btrfs-send job already running~%")))))
+                    (call-with-advisory-lock
+                     %lock-file
+                     create-and-send-snapshot)))))))
+
 (define (anonip-service file)
   (service anonip-service-type
            (anonip-configuration
@@ -552,6 +628,7 @@ file system than the default one hosted on the SAN storage."
                 (mcron-service-type
                  config => (mcron-configuration
                             (inherit config)
-                            (jobs (cons btrfs-balance-job
-                                        (mcron-configuration-jobs
-                                         config))))))))))
+                            (jobs (cons* btrfs-balance-job
+                                         btrfs-send-job
+                                         (mcron-configuration-jobs
+                                          config))))))))))