guix
/
maintenance
mirror of git://git.savannah.gnu.org/guix/maintenance.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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.
This commit is contained in:
Maxim Cournoyer 2023-05-19 10:15:01 -04:00
parent b49da23ee6
commit 0b402ffc49
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
1 changed files with 80 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
hydra/berlin.scm
View File

@ -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))))))))))