[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
branch master updated: hydra: berlin: Add an initial (incomplete) btrfs-
From: |
Maxim Cournoyer |
Subject: |
branch master updated: hydra: berlin: Add an initial (incomplete) btrfs-send-job mcron job. |
Date: |
Fri, 19 May 2023 16:21:45 -0400 |
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 0b402ff hydra: berlin: Add an initial (incomplete) btrfs-send-job
mcron job.
0b402ff is described below
commit 0b402ffc496d40f36b9ee9f53fbfc79fecee16e3
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Fri May 19 10:15:01 2023 -0400
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))))))))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- branch master updated: hydra: berlin: Add an initial (incomplete) btrfs-send-job mcron job.,
Maxim Cournoyer <=