branch master updated: hydra: berlin: Factorize btrfs-send mcron job script.

[Maxim Cournoyer]

This is an automated email from the git hooks/post-receive script.

apteryx pushed a commit to branch master
in repository maintenance.

The following commit(s) were added to refs/heads/master by this push:
     new ed9fa32  hydra: berlin: Factorize btrfs-send mcron job script.
ed9fa32 is described below

commit ed9fa3216ffb41baf0bd255abaa8b0bf4e700a91
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Fri May 19 17:18:07 2023 -0400

    hydra: berlin: Factorize btrfs-send mcron job script.
    
    * hydra/berlin.scm (btrfs-send-job): Break the script into smaller
    procedures to improve readability.
---
 hydra/berlin.scm | 85 +++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 54 insertions(+), 31 deletions(-)

diff --git a/hydra/berlin.scm b/hydra/berlin.scm
index 2f22f74..9e036ef 100644
--- a/hydra/berlin.scm
+++ b/hydra/berlin.scm
@@ -266,51 +266,67 @@ file system than the default one hosted on the SAN 
storage."
                                (rnrs io simple)
                                (srfi srfi-1)
                                (srfi srfi-19)
-                               (srfi srfi-26))
+                               (srfi srfi-26)
+                               (srfi srfi-71))
+
+                  (define %lock-file "/var/lock/mcron-btrfs-send-job.lock")
+                  (define btrfs #$(file-append btrfs-progs "/bin/btrfs"))
+                  (define %subvolume "/mnt/btrfs-pool-san/@publish")
+                  (define %snapshots-dir "/mnt/btrfs-pool-san/snapshots/")
+
                   ;; 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))
+                  (define (snapshot-subvolume subvolume dest)
+                    "Create a new snapshot of SUBVOLUME in DEST."
+                    (let* ((subvolume-name (basename subvolume))
                            (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)
+                                                         timestamp)))
+                      (mkdir-p dest)
+                      (with-directory-excursion dest
+                        (invoke btrfs "subvolume" "snapshot" "-r"
+                                subvolume snapshot-name))))
+
+                  (define (prune-snapshots dir prefix preserve-count)
+                    "Delete all but the PRESERVE-COUNT newest snapshots
+found in DIR whose name match PREFIX."
+                    (with-directory-excursion dir
                       (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)))
+                                                          prefix <>)))
+                             (old-snapshots (if (> (length snapshots)
+                                                   preserve-count)
+                                                (drop-right snapshots
+                                                            preserve-count)
+                                                '())))
                         ;; 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~%"))))
+                                  old-snapshots))))
+
+                  (define* (get-latest-snapshots dir prefix)
+                    "Return two values: the latest snapshot and its parent, if 
available."
+                    (with-directory-excursion dir
+                      (let ((snapshots (scandir "." (cut string-prefix?
+                                                         prefix <>))))
+                        (match snapshots
+                          ((head ... parent latest)
+                           (values latest parent))
+                          ((latest)
+                           (values latest #f))))))
+
+                  (define* (send-snapshot file #:key parent
+                                          pipe)
+                    "Send the snapshot FILE, a file name, to the output PIPE.
+An incremental send is attempted if a PARENT snapshot is provided."
+                    ;; 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)
@@ -323,7 +339,14 @@ file system than the default one hosted on the SAN 
storage."
                                  (format #t "btrfs-send job already 
running~%")))))
                     (call-with-advisory-lock
                      %lock-file
-                     create-and-send-snapshot)))))))
+                     (lambda _
+                       (define subvolume-name (basename %subvolume))
+                       (snapshot-subvolume %subvolume %snapshots-dir)
+                       (prune-snapshots %snapshots-dir subvolume-name 2)
+                       (let ((snapshot parent (get-latest-snapshots
+                                               %snapshots-dir subvolume-name)))
+                         (send-snapshot snapshot #:parent parent
+                                        #:pipe #f))))))))))
 
 (define (anonip-service file)
   (service anonip-service-type