From 3b9b3b49316596bc1fab2834ef156091b553b4b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 Mar 2022 23:14:39 +0200 Subject: services: Add 'log-cleanup-service-type'. * gnu/services/admin.scm (): 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. --- gnu/services/admin.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) (limited to 'gnu/services/admin.scm') 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 -;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2016-2022 Ludovic Courtès ;;; Copyright © 2020 Brice Waegeneire ;;; ;;; 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 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 + (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. -- cgit v1.2.3