services: Add cachefilesd service.

Thanks to Bruno Victal "mirai" for cooperating on this patch and for
generously sharing a wealth of insights about Guix services.

Thanks to Jean-Baptiste Note for an early version of this service!

* doc/guix.texi (Linux Services)[Cachefilesd Service]: New heading.
* gnu/services/linux.scm (serialize-string, non-negative-integer?)
(serialize-non-negative-integer, string, non-negative-integer)
(make-option-serializer, make-percentage-threshold-serializer): New
procedures.
(cachefilesd-configuration): New record type.
(cachefilesd-service-type): New variable.
* gnu/tests/cachefilesd.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

Co-authored-by: Bruno Victal <mirai@makinata.eu>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

3 files changed, 270 insertions, 1 deletions

diff --git a/gnu/local.mk b/gnu/local.mk
index 1bf33377a4..5ed399adb0 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -770,6 +770,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests.scm					\
   %D%/tests/audio.scm				\
   %D%/tests/base.scm				\
+  %D%/tests/cachefilesd.scm			\
   %D%/tests/ci.scm				\
   %D%/tests/cups.scm				\
   %D%/tests/databases.scm			\
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index d105c42850..d17f492e15 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2021 B. Wilson <elaexuotee@wilsonb.com>
 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
 ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
+;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,6 +68,28 @@
 
             kernel-module-loader-service-type
 
+            cachefilesd-configuration
+            cachefilesd-configuration?
+            cachefilesd-configuration-cachefilesd
+            cachefilesd-configuration-debug-output?
+            cachefilesd-configuration-use-syslog?
+            cachefilesd-configuration-scan?
+            cachefilesd-configuration-cache-directory
+            cachefilesd-configuration-cache-name
+            cachefilesd-configuration-security-context
+            cachefilesd-configuration-pause-culling-for-block-percentage
+            cachefilesd-configuration-pause-culling-for-file-percentage
+            cachefilesd-configuration-resume-culling-for-block-percentage
+            cachefilesd-configuration-resume-culling-for-file-percentage
+            cachefilesd-configuration-pause-caching-for-block-percentage
+            cachefilesd-configuration-pause-caching-for-file-percentage
+            cachefilesd-configuration-log2-table-size
+            cachefilesd-configuration-cull?
+            cachefilesd-configuration-trace-function-entry-in-kernel-module
+            cachefilesd-configuration-trace-function-exit-in-kernel-module
+            cachefilesd-configuration-trace-internal-checkpoints-in-kernel-module
+            cachefilesd-service-type
+
             rasdaemon-configuration
             rasdaemon-configuration?
             rasdaemon-configuration-record?
@@ -308,6 +331,180 @@ more information)."
 
 
 ;;;
+;;; Cachefilesd, an FS-Cache daemon
+;;;
+
+(define (serialize-string variable-symbol value)
+  #~(format #f "~a ~a~%" #$(symbol->string variable-symbol) #$value))
+
+(define-maybe string)
+
+(define (non-negative-integer? val)
+  (and (exact-integer? val) (not (negative? val))))
+
+(define (serialize-non-negative-integer variable-symbol value)
+  #~(format #f "~a ~d~%" #$(symbol->string variable-symbol) #$value))
+
+(define-maybe non-negative-integer)
+
+(define (make-option-serializer option-symbol)
+  (lambda (variable-symbol text)
+    (if (maybe-value-set? text)
+        #~(format #f "~a ~a~%" #$(symbol->string option-symbol) #$text)
+        "")))
+
+(define (make-percentage-threshold-serializer threshold-symbol)
+  (lambda (variable-symbol percentage)
+    (if (maybe-value-set? percentage)
+        #~(format #f "~a ~a%~%" #$(symbol->string threshold-symbol) #$percentage)
+        "")))
+
+(define-configuration cachefilesd-configuration
+  (cachefilesd
+   (file-like cachefilesd)
+   "The cachefilesd package to use."
+   (serializer empty-serializer))
+
+  ;; command-line options
+  (debug-output?
+   (boolean #f)
+   "Print debugging output to stderr."
+   (serializer empty-serializer))
+
+  (use-syslog?
+   (boolean #t)
+   "Log to syslog facility instead of stdout."
+   (serializer empty-serializer))
+
+  ;; culling is part of the configuration file
+  ;; despite the name of the command-line option
+  (scan?
+   (boolean #t)
+   "Scan for cachable objects."
+   (serializer empty-serializer))
+
+  ;; sole required field in the configuration file
+  (cache-directory
+   maybe-string
+   "Location of the cache directory."
+   (serializer (make-option-serializer 'dir)))
+
+  (cache-name
+   (maybe-string "CacheFiles")
+   "Name of cache (keep unique)."
+   (serializer (make-option-serializer 'tag)))
+
+  (security-context
+   maybe-string
+   "SELinux security context."
+   (serializer (make-option-serializer 'secctx)))
+
+  ;; percentage thresholds in the configuration file
+  (pause-culling-for-block-percentage
+   (maybe-non-negative-integer 7)
+   "Pause culling when available blocks exceed this percentage."
+   (serializer (make-percentage-threshold-serializer 'brun)))
+
+  (pause-culling-for-file-percentage
+   (maybe-non-negative-integer 7)
+   "Pause culling when available files exceed this percentage."
+   (serializer (make-percentage-threshold-serializer 'frun)))
+
+  (resume-culling-for-block-percentage
+   (maybe-non-negative-integer 5)
+   "Start culling when available blocks drop below this percentage."
+   (serializer (make-percentage-threshold-serializer 'bcull)))
+
+  (resume-culling-for-file-percentage
+   (maybe-non-negative-integer 5)
+   "Start culling when available files drop below this percentage."
+   (serializer (make-percentage-threshold-serializer 'fcull)))
+
+  (pause-caching-for-block-percentage
+   (maybe-non-negative-integer 1)
+   "Pause further allocations when available blocks drop below this percentage."
+   (serializer (make-percentage-threshold-serializer 'bstop)))
+
+  (pause-caching-for-file-percentage
+   (maybe-non-negative-integer 1)
+   "Pause further allocations when available files drop below this percentage."
+   (serializer (make-percentage-threshold-serializer 'fstop)))
+
+  ;; run time optimizations in the configuration file
+  (log2-table-size
+   (maybe-non-negative-integer 12)
+   "Size of tables holding cullable objects in logarithm of base 2."
+   (serializer (make-option-serializer 'culltable)))
+
+  (cull?
+   (boolean #t)
+   "Create free space by culling (consumes system load)."
+   (serializer
+    (lambda (variable-symbol value)
+      (if value "" "nocull\n"))))
+
+  ;; kernel module debugging in the configuration file
+  (trace-function-entry-in-kernel-module?
+   (boolean #f)
+   "Trace function entry in the kernel module (for debugging)."
+   (serializer empty-serializer))
+
+  (trace-function-exit-in-kernel-module?
+   (boolean #f)
+   "Trace function exit in the kernel module (for debugging)."
+   (serializer empty-serializer))
+
+  (trace-internal-checkpoints-in-kernel-module?
+   (boolean #f)
+   "Trace internal checkpoints in the kernel module (for debugging)."
+   (serializer empty-serializer)))
+
+(define (serialize-cachefilesd-configuration configuration)
+  (mixed-text-file
+   "cachefilesd.conf"
+   (serialize-configuration configuration cachefilesd-configuration-fields)))
+
+(define (cachefilesd-shepherd-service config)
+  "Return a list of <shepherd-service> for cachefilesd for CONFIG."
+  (match-record
+      config <cachefilesd-configuration> (cachefilesd
+                                          debug-output?
+                                          use-syslog?
+                                          scan?
+                                          cache-directory)
+      (let ((configuration-file (serialize-cachefilesd-configuration config)))
+        (shepherd-service
+         (documentation "Run the cachefilesd daemon for FS-Cache.")
+         (provision '(cachefilesd))
+         (requirement (append '(file-systems)
+                              (if use-syslog? '(syslogd) '())))
+         (start #~(begin
+                    (and=> #$(maybe-value cache-directory) mkdir-p)
+                    (make-forkexec-constructor
+                     `(#$(file-append cachefilesd "/sbin/cachefilesd")
+                       ;; do not detach
+                       "-n"
+                       #$@(if debug-output? '("-d") '())
+                       #$@(if use-syslog? '() '("-s"))
+                       #$@(if scan? '() '("-N"))
+                       "-f" #$configuration-file))))
+         (stop #~(make-kill-destructor))))))
+
+(define cachefilesd-service-type
+  (service-type
+   (name 'cachefilesd)
+   (description
+    "Run the file system cache daemon @command{cachefilesd}, which relies on
+the Linux @code{cachefiles} module.")
+   (extensions
+    (list (service-extension kernel-module-loader-service-type
+                             (const '("cachefiles")))
+          (service-extension shepherd-root-service-type
+                             (compose list cachefilesd-shepherd-service))))
+   (default-value (cachefilesd-configuration))))
+
+
+;;;
 ;;; Reliability, Availability, and Serviceability (RAS) daemon
 ;;;
 
@@ -351,7 +548,7 @@ more information)."
 
 
 ;;;
-;;; Kernel module loader.
+;;; Zram device
 ;;;
 
 (define-record-type* <zram-device-configuration>
diff --git a/gnu/tests/cachefilesd.scm b/gnu/tests/cachefilesd.scm
new file mode 100644
index 0000000000..7f5d513067
--- /dev/null
+++ b/gnu/tests/cachefilesd.scm
@@ -0,0 +1,71 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
+;;; Copyright © 2022 Bruno Victal <mirai@makinata.eu>
+;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests cachefilesd)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services linux)
+  #:use-module (guix gexp)
+  #:export (%test-cachefilesd))
+
+(define %cachefilesd-os
+  (simple-operating-system
+   (service cachefilesd-service-type
+            (cachefilesd-configuration
+             (cache-directory "/var/cache/fscache")))))
+
+(define (run-cachefilesd-test)
+  "Run tests in %cachefilesd-os, which has cachefilesd running."
+  (define os
+    (marionette-operating-system
+     %cachefilesd-os
+     #:imported-modules '((gnu services herd))))
+
+  (define vm
+    (virtual-machine os))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-64)
+                       (gnu build marionette))
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "cachefilesd")
+
+          (test-assert "service is running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'cachefilesd))
+             marionette))
+
+          (test-end))))
+  (gexp->derivation "cachefilesd-test" test))
+
+(define %test-cachefilesd
+  (system-test
+   (name "cachefilesd")
+   (description "Test that the cachefilesd runs when started.")
+   (value (run-cachefilesd-test))))