gnu: services: Add btrfs-scrub-service-type.

* gnu/services/linux.scm (btrfs-scrub-configuration): New configuration
record.
(btrfs-scrub-service-type): New service type with custom actions.
(fstrim-/shepherd-calendar-event?): Refactor to avoid name collisions.
* doc/guix.texi: Add service documentation.

Change-Id: I04747914591a80cd535d2f79d35e08f68081b2fc
Signed-off-by: Joan Vilardaga Castro <codeberg-hn80@joanvc.cat>
Signed-off-by: Efraim Flashner <efraim@flashner.co.il>

2 files changed, 208 insertions, 3 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 8d45ed1f43b..debe9b48a77 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -151,6 +151,7 @@ Copyright @copyright{} 2025 Noé Lopez@*
 Copyright @copyright{} 2026 David Elsing@*
 Copyright @copyright{} 2026 Nguyễn Gia Phong@*
 Copyright @copyright{} 2026 Yarl Baudig@*
+Copyright @copyright{} 2026 Joan Vilardaga Castro@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -45888,6 +45889,81 @@ mount.
 @end table
 @end deftp
 
+@subsubheading btrfs-scrub Service
+@cindex btrfs-scrub service
+@cindex solid state drives, periodic trim
+@cindex solid state drives, trim
+
+@c This was copied from the btrfs-scrub manpage, with some Texinfo touch-ups.
+@quotation Information
+Scrub is a validation pass over all filesystem data and metadata that
+detects data checksum errors, basic super block errors, basic metadata
+block header errors, and disk read errors.
+
+Scrub is done on a per-device base, if a device is specified to
+@command{btrfs scrub start}, then only that device will be
+scrubbed.  Although btrfs will also try to read other device to find a
+good copy, if the mirror on that specified device failed to be read or
+pass verification.
+
+If a path of btrfs is specified to @command{btrfs scrub start}, btrfs
+will scrub all devices in parallel.
+
+On filesystems that use replicated block group profiles (e.g. RAID1),
+read-write scrub will also automatically repair any damage by copying
+verified good data from one of the other replicas.
+
+Such automatic repair is also carried out when reading metadata or data
+from a read-write mounted filesystem.
+@end quotation
+
+@defvar btrfs-scrub-service-type
+Type for a service that periodically runs @command{btrfs-scrub} on a
+certain device, whose value must be an
+@code{<btrfs-scrub-configuration>} object.  The service can be
+instantiated in its default configuration with:
+
+@lisp
+;; This will scrub the root (@file{/}) filesystem.
+(service btrfs-scrub-service-type)
+
+;; This will scrub the @file{/gnu/store} filesystem (assuming it's a
+;; different filesystem from @file{/}).
+
+(service btrfs-scrub-service-type
+  (btrfs-scrub-configuration
+    (to-scrub "/gnu/store")))
+@end lisp
+@end defvar
+
+@c %start of fragment
+
+@deftp {Data Type} btrfs-scrub-configuration
+Available @code{btrfs-scrub-configuration} fields are:
+
+@table @asis
+@item @code{package} (default: @code{btrfs-progs}) (type: file-like)
+The package providing the @command{btrfs} command.
+
+@item @code{schedule} (default: @code{"0 0 1-7 * 0"}) (type: Shepherd calendar event)
+Schedule for launching @command{btrfs-scrub}, expressed as a string in
+traditional cron syntax or as a gexp evaluating to a Shepherd calendar
+event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}).  By default
+this is set to run the 1st Sunday of the month, at 00:00.
+
+@item @code{to-scrub} (default: @code{"/"}) (type: maybe-string)
+Device to scrub.  It will scrub the root (@file{/}) if not given.
+
+@item @code{extra-arguments} (type: maybe-list-of-strings)
+Extra options to append to @command{btrfs scrub start} (run @samp{man
+btrfs-scrub.8} for more information).  Keep in mind that, by definition,
+this service uses the @option{-B} flag (do not background and print
+scrub statistics when finished).
+
+@end table
+
+@end deftp
+
 @cindex oom
 @cindex out of memory killer
 @cindex earlyoom
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index 2284741a659..f6e74b60ff5 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -9,6 +9,7 @@
 ;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
 ;;; Copyright © 2025 Edouard Klein <edk@beaver-labs.com>
 ;;; Copyright © 2026 Giacomo Leidi <therewasa@fishinthecalculator.me>
+;;; Copyright © 2026 Joan Vilardaga Castro <codeberg-hn80@joanvc.cat>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,7 +53,10 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 string-fun)
-  #:export (earlyoom-configuration
+  #:export (btrfs-scrub-configuration
+            btrfs-scrub-service-type
+
+            earlyoom-configuration
             earlyoom-configuration?
             earlyoom-configuration-earlyoom
             earlyoom-configuration-minimum-available-memory
@@ -161,6 +165,131 @@
 
 
 ;;;
+;;; BTRFS scrub.
+;;;
+
+(define (btrfs-scrub-shepherd-calendar-event? x)
+  (or (string? x) (gexp? x)))
+
+(define-maybe string (prefix btrfs-scrub-))
+
+(define-maybe list-of-strings (prefix btrfs-scrub-))
+
+(define (btrfs-scrub-serialize-string field-name value)
+  (if (maybe-value-set? value)
+   (list value) '()))
+
+(define (btrfs-scrub-serialize-list-of-string field-name value)
+  (if (maybe-value-set? value)
+    value '()))
+
+(define-configuration btrfs-scrub-configuration
+  (package
+    (file-like btrfs-progs)
+    "The package providing the @command{btrfs} command." empty-serializer)
+  (schedule (btrfs-scrub-shepherd-calendar-event "0 0 1-7 * 0")
+   "Schedule for launching @command{btrfs-scrub}, expressed as a string in
+traditional cron syntax or as a gexp evaluating to a Shepherd calendar
+event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}).  By default this
+is set to run the 1st Sunday of the month, at 00:00."
+   empty-serializer)
+  ;; The following are btrfs-scrub-related options.
+  (to-scrub (maybe-string "/")
+            "Device to scrub.  It will scrub the root (\"/\") if not given.")
+  (extra-arguments maybe-list-of-strings
+   "Extra options to append to @command{btrfs scrub start}
+   (run @samp{man btrfs-scrub} for more information).  Keep in mind that,
+   by default, this service uses the @option{-B} flag (do not background and
+   print scrub statistics when finished).")
+  (prefix btrfs-scrub-))
+
+(define (serialize-btrfs-scrub-configuration config)
+  (list-transduce (compose (base-transducer config) tconcatenate)
+                   rcons
+                   btrfs-scrub-configuration-fields))
+
+
+(define (btrfs-scrub-template-action-procedure btrfs-bin cmd-args to-scrub)
+  "Template procedure to call the btrfs command, print it's outputs and return
+it's exit code.  Taken from
+https://www.gnu.org/software/guile/manual/html_node/Processes.html#index-spawn"
+  #~(lambda (_ . args)
+      (let* ((stdout-in-out (pipe)) (stderr-in-out (pipe))
+       (argv (append (list #$btrfs-bin) '#$cmd-args '(#$to-scrub)))
+       (pid (spawn #$btrfs-bin argv
+             #:output (cdr stdout-in-out)
+             #:error (cdr stderr-in-out))))
+       (close-port (cdr stdout-in-out))
+       (close-port (cdr stderr-in-out))
+       (display (get-string-all (car stdout-in-out)))
+       ;; Redirect stderr to stdout to make it printable for "herd"
+       (display (get-string-all (car stderr-in-out)))
+       (close-port (car stdout-in-out))
+       (close-port (car stderr-in-out))
+       (let* ((status (waitpid pid)) (exit-val (status:exit-val (cdr status))))
+       (= EXIT_SUCCESS exit-val)))))
+
+
+(define (btrfs-scrub-status-action-procedure btrfs-bin to-scrub)
+  "Return a procedure to check the status of the current BTRFS scrub."
+  (btrfs-scrub-template-action-procedure btrfs-bin '("scrub" "status") to-scrub))
+
+(define (btrfs-scrub-cancel-action-procedure btrfs-bin to-scrub)
+  "Return a procedure to always cancel the current BTRFS scrub."
+  (btrfs-scrub-template-action-procedure btrfs-bin '("scrub" "cancel") to-scrub))
+
+(define (btrfs-scrub-extra-actions btrfs-bin to-scrub)
+  (list shepherd-trigger-action
+        (shepherd-action (name 'scrub-status)
+                         (documentation
+                          "Print the status of the scrubing process.")
+                         (procedure (btrfs-scrub-status-action-procedure
+                                     btrfs-bin
+                                     to-scrub)))
+        (shepherd-action (name 'cancel)
+                         (documentation
+                          "Cancel the current scrub (it's an alias for stop).")
+                         (procedure (btrfs-scrub-cancel-action-procedure
+                                     btrfs-bin
+                                     to-scrub)))))
+
+
+(define (btrfs-scrub-shepherd-services config)
+  (match-record config <btrfs-scrub-configuration>
+    (package schedule to-scrub)
+    (let ((btrfs-bin (file-append package "/bin/btrfs")))
+    (list (shepherd-service
+           (provision (list (string->symbol (string-append "btrfs-scrub-" to-scrub))))
+           (requirement '(user-processes))
+           (modules '((shepherd service timer)
+                      (ice-9 popen)
+                      (ice-9 textual-ports)))
+           (start #~(make-timer-constructor
+                     #$(if (string? schedule)
+                            #~(cron-string->calendar-event #$schedule)
+                            schedule)
+                     (command (list #$btrfs-bin
+                                    "scrub"
+                                    "start"
+                                    "-B"
+                                    #$@(serialize-btrfs-scrub-configuration config)))
+                     #:wait-for-termination? #t))
+           (stop (btrfs-scrub-cancel-action-procedure btrfs-bin to-scrub))
+           (documentation "Periodically run the 'btrfs-scrub' command.")
+           (actions (btrfs-scrub-extra-actions btrfs-bin to-scrub)))))))
+
+
+(define btrfs-scrub-service-type
+  (service-type (name 'btrfs-scrub)
+                (extensions (list (service-extension
+                                   shepherd-root-service-type
+                                   btrfs-scrub-shepherd-services)))
+                (description
+                 "Verify the block checksums of a BTRFS filesystem.")
+                (default-value (btrfs-scrub-configuration))))
+
+
+;;;
 ;;; Early OOM daemon.
 ;;;
 
@@ -251,7 +380,7 @@ representation."
 ;;; fstrim
 ;;;
 
-(define (shepherd-calendar-event? x)
+(define (fstrim-shepherd-calendar-event? x)
   (or (string? x) (gexp? x)))
 
 (define-maybe list-of-strings (prefix fstrim-))
@@ -271,7 +400,7 @@ representation."
     "The package providing the @command{fstrim} command."
     empty-serializer)
   (schedule
-   (shepherd-calendar-event "0 0 * * 0")
+   (fstrim-shepherd-calendar-event "0 0 * * 0")
    "Schedule for launching @command{fstrim}, expressed as a string in
 traditional cron syntax or as a gexp evaluating to a Shepherd calendar
 event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}).  By default this