[shepherd] 03/04: service: Use a ring buffer for event logs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 7ab3b051c2c70fcf2ac9237ee063580d63a7fa23
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Apr 23 23:17:55 2023 +0200

    service: Use a ring buffer for event logs.
    
    This is marginally better than using the O(N) 'at-most' at every event.
    
    * modules/shepherd/support.scm (<ring-buffer>): New record type.
    (ring-buffer, ring-buffer-insert): New procedures.
    (ring-buffer->list): New procedure.
    * modules/shepherd/service.scm (service-controller): Turn 'changes' and
    'failures' into ring buffers.  Adjust uses accordingly.
    (service-startup-failures, service-status-changes): Compose with
    'ring-buffer->list'.
---
 modules/shepherd/service.scm | 24 +++++++++++++----------
 modules/shepherd/support.scm | 46 +++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 59 insertions(+), 11 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 2c8ec7e..76b0f26 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -381,14 +381,15 @@ denoting what the service provides."
                   (value #f)
                   (condition #f)
                   (enabled? #t)
-                  (changes '())                ;list of status/timestamp pairs
-                  (failures '())               ;list of timestamps
+                  (changes                     ;list of status/timestamp pairs
+                   (ring-buffer %max-recorded-status-changes))
+                  (failures                    ;list of timestamps
+                   (ring-buffer %max-recorded-startup-failures))
                   (respawns '())               ;list of timestamps
                   (replacement #f))
     (define (update-status-changes status)
-      ;; Add STATUS to CHANGES, the alist of status changes.
-      (at-most %max-recorded-status-changes
-               (alist-cons status (current-time) changes)))
+      ;; Add STATUS to CHANGES, the ring buffer of status changes.
+      (ring-buffer-insert (cons status (current-time)) changes))
 
     (match (get-message channel)
       (('running reply)
@@ -476,8 +477,8 @@ denoting what the service provides."
                 (condition #f)
                 (failures (if new-value
                               failures
-                              (at-most %max-recorded-startup-failures
-                                       (cons (current-time) failures))))))))
+                              (ring-buffer-insert (current-time)
+                                                  failures)))))))
 
       (((? change-value-message?) new-value)
        (local-output (l10n "Running value of service ~a changed to ~s.")
@@ -533,7 +534,8 @@ denoting what the service provides."
        (loop (status 'stopped)
              (changes (update-status-changes 'stopped))
              (value #f) (condition #f)
-             (respawns '()) (failures '())))
+             (respawns '())
+             (failures (ring-buffer %max-recorded-startup-failures))))
 
       ('notify-termination                        ;no reply
        (loop (status 'stopped)
@@ -670,12 +672,14 @@ channel and wait for its reply."
 
 (define service-startup-failures
   ;; Return the list of recent startup failure times for @var{service}.
-  (service-control-message 'startup-failures))
+  (compose ring-buffer->list
+           (service-control-message 'startup-failures)))
 
 (define service-status-changes
   ;; Return the list of symbol/timestamp pairs representing recent state
   ;; changes for @var{service}.
-  (service-control-message 'status-changes))
+  (compose ring-buffer->list
+           (service-control-message 'status-changes)))
 
 (define service-enabled?
   ;; Return true if @var{service} is enabled, false otherwise.
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 513af00..0cddc03 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -25,10 +25,17 @@
   #:autoload   (shepherd colors) (color-output? color colorize-string)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:autoload   (srfi srfi-1) (take)
+  #:use-module (srfi srfi-9)
   #:export (caught-error
             assert
             let-loop
-            at-most
+
+            ring-buffer
+            ring-buffer?
+            ring-buffer-limit
+            ring-buffer-insert
+            ring-buffer->list
 
             buffering
             catch-system-error
@@ -126,6 +133,43 @@ That reduces the amount of boilerplate for loops with many 
variables."
                               ...)))))
       body ...)))
 
+;; The poor developer's persistent "ring buffer": it holds between N and 2N
+;; elements, but has O(1) insertion.
+(define-record-type <ring-buffer>
+  (%ring-buffer limit front-length front rear)
+  ring-buffer?
+  (limit         ring-buffer-limit)
+  (front-length  ring-buffer-front-length)
+  (front         ring-buffer-front)
+  (rear          ring-buffer-rear))
+
+(define (ring-buffer size)
+  "Return an ring buffer that can hold @var{size} elements."
+  (%ring-buffer size 0 '() '()))
+
+(define-inlinable (ring-buffer-insert element buffer)
+  "Insert @var{element} to the front of @var{buffer}.  If @var{buffer} is
+already full, its oldest element is removed."
+  (match buffer
+    (($ <ring-buffer> limit front-length front rear)
+     (if (< front-length limit)
+         (let ((front-length (+ 1 front-length)))
+           (%ring-buffer limit front-length
+                         (cons element front)
+                         (if (= limit front-length)
+                             '()
+                             rear)))
+         (%ring-buffer limit 1
+                       (list element) front)))))
+
+(define (ring-buffer->list buffer)
+  "Convert @var{buffer} into a list."
+  (match buffer
+    (($ <ring-buffer> limit front-length front rear)
+     (if (= limit front-length)
+         front
+         (append front (at-most (- limit front-length) rear))))))
+
 (define (at-most max-length lst)
   "If @var{lst} is shorter than @var{max-length}, return it and the empty list;
 otherwise return its @var{max-length} first elements and its tail."