;; Multi-process interleaving stress test for logger/lock.
;;
;; Forks N processes, each writing M log lines through a shared lockfile to
;; the same destination file. After all children exit, every line in the
;; output must match the expected regex (no half-lines, no spliced lines).
;;
;; POSIX-only. Run with: csi -s tests/concurrency-test.scm

(import test
        chicken.base
        chicken.bitwise
        chicken.file
        chicken.file.posix
        chicken.io
        chicken.process
        chicken.string
        chicken.irregex
        (only srfi-1 every))

(load "logger.scm")
(import logger)

(define n-procs 4)
(define n-msgs 200)
(define log-path "tests/concurrent.log")
(define lock-path "tests/concurrent.lock")
(define padding (make-string 600 #\x))

(when (file-exists? log-path) (delete-file log-path))
(when (file-exists? lock-path) (delete-file lock-path))

(define (child-body proc-id)
  (let* ((fd (file-open log-path
                        (bitwise-ior open/wronly open/creat open/append)
                        #o644))
         (port (open-output-file* fd)))
    (parameterize ((logger/output port)
                   (logger/lock (logger/make-flock-lock lock-path))
                   (logger/level 'debug)
                   (logger/format 'text))
      (let loop ((j 0))
        (when (< j n-msgs)
          (logger/i "proc=" proc-id " seq=" j " " padding)
          (loop (+ j 1)))))
    (close-output-port port)))

(let loop ((i 0) (pids '()))
  (if (= i n-procs)
      (for-each
       (lambda (pid)
         (call-with-values (lambda () (process-wait pid))
           (lambda (_pid ok? _status) (unless ok? (error "child failed")))))
       pids)
      (let ((pid (process-fork)))
        (if (zero? pid)
            (begin (child-body i) (exit 0))
            (loop (+ i 1) (cons pid pids))))))

(define line-rx
  (irregex
   "^[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}Z \\[INFO\\] \\[GLOBAL\\] proc=[0-9]+ seq=[0-9]+ x+$"))

(define (read-all-lines path)
  (with-input-from-file path
    (lambda ()
      (let loop ((acc '()))
        (let ((line (read-line)))
          (if (eof-object? line)
              (reverse acc)
              (loop (cons line acc))))))))

(define lines (read-all-lines log-path))

(test-group "multi-process interleaving"
  (test "wrote expected number of lines"
        (* n-procs n-msgs) (length lines))
  (test-assert "every line is intact (no splicing)"
               (every (lambda (l) (irregex-match line-rx l)) lines)))

(when (file-exists? log-path) (delete-file log-path))
(when (file-exists? lock-path) (delete-file lock-path))

(test-exit)