Rotating log file with retention

2026-08-30 09:28:58 +02:00
parent f88ee4951e
commit 8810edf801
5 changed files with 202 additions and 3 deletions
@@ -0,0 +1,132 @@
+#lang racket
+
+(require file/gzip
+         racket/date
+         racket-sprintf)
+
+(provide make-rotating-log-callback)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Supporting functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (iso-date seconds [local-time? #t])
+  (let ((d (seconds->date seconds local-time?)))
+    (sprintf "%04d-%02d-%02d"
+             (date-year d)
+             (date-month d)
+             (date-day d))))
+
+(define (rotate-log-file! filename log-date)
+  (when (file-exists? filename)
+    (if (> (file-size filename) 0)
+        (let* ((filename-path (if (path? filename) filename (string->path filename)))
+               (archive
+                (string->path
+                 (string-append (path->string filename-path) "." log-date ".gz"))))
+          (gzip filename archive)
+          (delete-file filename))
+        (delete-file filename))))
+
+(define (remove-expired-log-files! filename log-date retention-days)
+  (let* ((filename-path (if (path? filename) filename (string->path filename)))
+         (directory (or (path-only filename-path) (current-directory)))
+         (base-name (path->string (file-name-from-path filename-path)))
+         (archive-regexp
+          (regexp
+           (format "^~a\\.([0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9])\\.gz$"
+                   (regexp-quote base-name))))
+         (date-match
+          (regexp-match #rx"^([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9])$"
+                        log-date))
+         (year (string->number (cadr date-match)))
+         (month (string->number (caddr date-match)))
+         (day (string->number (cadddr date-match)))
+         (date-seconds (find-seconds 0 0 12 day month year #f))
+         (cutoff-seconds (- date-seconds (* 86400 (sub1 retention-days))))
+         (cutoff-date (iso-date cutoff-seconds #f)))
+    (for-each
+     (λ (entry)
+       (let* ((entry-name (path->string entry))
+              (archive-match (regexp-match archive-regexp entry-name))
+              (archive-path (build-path directory entry)))
+         (when (and archive-match
+                    (string<? (cadr archive-match) cutoff-date)
+                    (file-exists? archive-path))
+           (delete-file archive-path))))
+     (directory-list directory))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provided functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal       : Create a callback that writes to a daily rotating log file.
+; pre        : filename is a path string and retention-days is a positive integer.
+; post       : The current day is kept as plain text. Older retained days are
+;              stored as <filename>.YYYY-MM-DD.gz.
+; result     : A simple-log callback procedure.
+; internals  : Rotation is checked for every log entry using the entry timestamp.
+;              retention-days includes the current, uncompressed day.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (make-rotating-log-callback filename retention-days)
+  (let ((active-date (iso-date (current-seconds)))
+        (out #f))
+
+    ;; A file left by an earlier process belongs to the day on which it was
+    ;; last written. Keep today's file plain, and archive an older one first.
+    (when (file-exists? filename)
+      (let ((file-date
+             (iso-date (file-or-directory-modify-seconds filename))))
+        (when (not (string=? file-date active-date))
+          (rotate-log-file! filename file-date))))
+
+    (remove-expired-log-files! filename active-date retention-days)
+    (set! out (open-output-file filename #:exists 'append))
+
+    (λ (topic level dt msg)
+      (let ((entry-date (substring dt 0 10)))
+        (when (not (string=? entry-date active-date))
+          (close-output-port out)
+          (rotate-log-file! filename active-date)
+          (set! active-date entry-date)
+          (remove-expired-log-files! filename active-date retention-days)
+          (set! out (open-output-file filename #:exists 'append)))
+
+        (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
+        (flush-output out)))))
+
+(module+ test
+  (require rackunit
+           racket/file
+           file/gunzip)
+
+  (let ((test-directory (make-temporary-file "simple-log-rotation~a" 'directory)))
+    (dynamic-wind
+      void
+      (λ ()
+        (let* ((logfile (build-path test-directory "application.log"))
+               (archive (build-path test-directory "application.log.2026-08-28.gz"))
+               (expired (build-path test-directory "application.log.2026-08-26.gz")))
+
+          (call-with-output-file logfile
+            (λ (out) (displayln "previous day" out))
+            #:exists 'replace)
+          (call-with-output-file expired
+            (λ (out) (displayln "expired" out))
+            #:exists 'replace)
+
+          (rotate-log-file! logfile "2026-08-28")
+          (check-false (file-exists? logfile))
+          (check-true (file-exists? archive))
+
+          (let ((out (open-output-bytes)))
+            (call-with-input-file archive
+              (λ (in) (gunzip-through-ports in out)))
+            (check-equal? (get-output-bytes out) #"previous day\n"))
+
+          (remove-expired-log-files! logfile "2026-08-29" 2)
+          (check-true (file-exists? archive))
+          (check-false (file-exists? expired))))
+      (λ ()
+        (delete-directory/files test-directory)))))