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.

1 files changed, 52 insertions, 1 deletions

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?
@@ -193,6 +200,50 @@ Old log files are removed or compressed according to the 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.
 ;;;