133 lines
5.3 KiB
Racket
133 lines
5.3 KiB
Racket
#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)))))
|