@@ -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
@@ -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 @@ (define-module (gnu services admin)
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?
@@ -191,6 +198,50 @@ (define rottlog-service-type
rotations)))))
(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.