07/13: services: Add 'log-cleanup-service-type'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 3b9b3b49316596bc1fab2834ef156091b553b4b7
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Mar 31 23:14:39 2022 +0200

    services: Add 'log-cleanup-service-type'.
    
    * gnu/services/admin.scm (<log-cleanup-configuration>): New record
    type.
    (log-cleanup-program, log-cleanup-mcron-jobs): New procedures.
    (log-cleanup-service-type): New variable.
    * doc/guix.texi (Log Rotation): Document it.
---
 doc/guix.texi          | 28 ++++++++++++++++++++++++++
 gnu/services/admin.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 80 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index e8ef4286be..ad2763ec8a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -17641,6 +17641,34 @@ The list of syslog-controlled files to be rotated.  By 
default it is:
 "/var/log/maillog")}.
 @end defvr
 
+Some log files just need to be deleted periodically once they are old,
+without any other criterion and without any archival step.  This is the
+case of build logs stored by @command{guix-daemon} under
+@file{/var/log/guix/drvs} (@pxref{Invoking guix-daemon}).  The
+@code{log-cleanup} service addresses this use case.
+
+@defvr {Scheme Variable} log-cleanup-service-type
+This is the type of the service to delete old logs.  Its value must be a
+@code{log-cleanup-configuration} record as described below.
+@end defvr
+
+@deftp {Data Type} log-cleanup-configuration
+Data type representing the log cleanup configuration
+
+@table @asis
+@item @code{directory}
+Name of the directory containing log files.
+
+@item @code{expiry} (default: @code{(* 6 30 24 3600)})
+Age in seconds after which a file is subject to deletion (six months by
+default).
+
+@item @code{schedule} (default: @code{"30 12 01,08,15,22 * *"})
+String or gexp denoting the corresponding mcron job schedule
+(@pxref{Scheduled Job Execution}).
+@end table
+@end deftp
+
 @node Networking Setup
 @subsection Networking Setup
 
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index 043517262f..3096acdf5a 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -46,6 +46,13 @@
             rottlog-service
             rottlog-service-type
 
+            log-cleanup-service-type
+            log-cleanup-configuration
+            log-cleanup-configuration?
+            log-cleanup-configuration-directory
+            log-cleanup-configuration-expiry
+            log-cleanup-configuration-schedule
+
             unattended-upgrade-service-type
             unattended-upgrade-configuration
             unattended-upgrade-configuration?
@@ -192,6 +199,50 @@ Old log files are removed or compressed according to the 
configuration.")
    (default-value (rottlog-configuration))))
 
 
+;;;
+;;; Build log removal.
+;;;
+
+(define-record-type* <log-cleanup-configuration>
+  log-cleanup-configuration make-log-cleanup-configuration
+  log-cleanup-configuration?
+  (directory log-cleanup-configuration-directory) ;string
+  (expiry    log-cleanup-configuration-expiry     ;integer (seconds)
+             (default (* 6 30 24 3600)))
+  (schedule  log-cleanup-configuration-schedule   ;string or gexp
+             (default "30 12 01,08,15,22 * *")))
+
+(define (log-cleanup-program directory expiry)
+  (program-file "delete-old-logs"
+                (with-imported-modules '((guix build utils))
+                  #~(begin
+                      (use-modules (guix build utils))
+
+                      (let* ((now  (car (gettimeofday)))
+                             (logs (find-files #$directory
+                                              (lambda (file stat)
+                                                (> (- now (stat:mtime stat))
+                                                   #$expiry)))))
+                        (format #t "deleting ~a log files from '~a'...~%"
+                                (length logs) #$directory)
+                        (for-each delete-file logs))))))
+
+(define (log-cleanup-mcron-jobs configuration)
+  (match-record configuration <log-cleanup-configuration>
+    (directory expiry schedule)
+    (list #~(job #$schedule
+                 #$(log-cleanup-program directory expiry)))))
+
+(define log-cleanup-service-type
+  (service-type
+   (name 'log-cleanup)
+   (extensions
+    (list (service-extension mcron-service-type
+                             log-cleanup-mcron-jobs)))
+   (description
+    "Periodically delete old log files.")))
+
+
 ;;;
 ;;; Unattended upgrade.
 ;;;