fix: reject symlinked/non-regular database paths in open-event-store

ober

cc247affbc3d56b7eea9ea486231da894f45c674

diff --git a/lib/secmon/storage/store.sls b/lib/secmon/storage/store.sls
index cb0c795..8401371 100644
--- a/lib/secmon/storage/store.sls
+++ b/lib/secmon/storage/store.sls
@@ -42,7 +42,31 @@
                (japi:sqlite-finalize stmt)
                (reverse acc)]))))))
 
+  (define (path-dirname path)
+    (let loop ([i (- (string-length path) 1)])
+      (cond
+        [(< i 0) "."]
+        [(char=? (string-ref path i) #\/)
+         (if (= i 0) "/" (substring path 0 i))]
+        [else (loop (- i 1))])))
+
+  (define (validate-store-path! path)
+    ;; Fail closed on a hostile path. The database must not be reached through a
+    ;; symlink and must be a regular file when it already exists, so SQLite
+    ;; WAL/SHM sidecars cannot be symlink-attacked; it must also live in a real
+    ;; directory that is not itself a symlink.
+    (when (file-symbolic-link? path)
+      (error 'open-event-store "refusing symlinked database path" path))
+    (when (and (file-exists? path) (not (file-regular? path)))
+      (error 'open-event-store "database path is not a regular file" path))
+    (let ([dir (path-dirname path)])
+      (when (file-symbolic-link? dir)
+        (error 'open-event-store "refusing symlinked database directory" dir))
+      (when (and (file-exists? dir) (not (file-directory? dir)))
+        (error 'open-event-store "database parent is not a directory" dir))))
+
   (define (open-event-store path)
+    (validate-store-path! path)
     (let ([db (sqlite-open path)])
       (init-schema! db)
       (make-event-store db)))
diff --git a/tests/store-path-test.ss b/tests/store-path-test.ss
new file mode 100644
index 0000000..6669759
--- /dev/null
+++ b/tests/store-path-test.ss
@@ -0,0 +1,57 @@
+(import (chezscheme)
+        (secmon storage store))
+
+(define failures 0)
+(define (check name got want)
+  (let ([ok (equal? got want)])
+    (unless ok (set! failures (+ failures 1)))
+    (display (if ok "ok: " "FAIL: "))
+    (display name)
+    (unless ok (display (format " got=~s want=~s" got want)))
+    (newline)))
+
+(define (rejected? thunk)
+  (guard (e [#t #t]) (thunk) #f))
+
+(define c-symlink (foreign-procedure "symlink" (string string) int))
+
+(define tmpdir
+  (let ([t (current-time)])
+    (format "/tmp/secmon-store-~a-~a" (time-second t) (time-nanosecond t))))
+(mkdir tmpdir)
+
+(define (in-tmp name) (string-append tmpdir "/" name))
+
+;; Positive: a regular database path inside a real directory opens.
+(check "regular database path opens"
+       (event-store? (open-event-store (in-tmp "events.db"))) #t)
+
+;; A symlinked database path is rejected (no O_NOFOLLOW follow).
+(call-with-output-file (in-tmp "real.db") (lambda (p) (display "x" p)))
+(c-symlink (in-tmp "real.db") (in-tmp "link.db"))
+(check "symlinked database path rejected"
+       (rejected? (lambda () (open-event-store (in-tmp "link.db")))) #t)
+
+;; A non-regular (directory) database path is rejected.
+(check "directory as database path rejected"
+       (rejected? (lambda () (open-event-store tmpdir))) #t)
+
+;; A database reached through a symlinked directory is rejected.
+(mkdir (in-tmp "realdir"))
+(c-symlink (in-tmp "realdir") (in-tmp "linkdir"))
+(check "database under symlinked directory rejected"
+       (rejected? (lambda () (open-event-store (in-tmp "linkdir/events.db")))) #t)
+
+;; Best-effort cleanup.
+(guard (e [#t (void)])
+  (for-each
+    (lambda (f) (guard (e [#t (void)]) (delete-file (in-tmp f))))
+    '("events.db" "events.db-wal" "events.db-shm" "real.db" "link.db"))
+  (guard (e [#t (void)]) (delete-directory (in-tmp "realdir")))
+  (guard (e [#t (void)]) (delete-file (in-tmp "linkdir")))
+  (guard (e [#t (void)]) (delete-directory tmpdir)))
+
+(if (= failures 0)
+  (begin (display "store-path-test: all path-validation checks passed") (newline))
+  (begin (display (format "store-path-test: ~a failures" failures))
+         (newline) (exit 1)))