#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)))))