From 0b402ffc496d40f36b9ee9f53fbfc79fecee16e3 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer 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] : 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))))))))))