Add daemontools-style process supervision modules
ober
81220526ef66267304ef3816e2313731bb59bd5f
--- a/lib/std/os/posix.sls +++ b/lib/std/os/posix.sls @@ -52,6 +52,9 @@ ;; User/permissions posix-umask posix-getuid posix-geteuid posix-getegid posix-access + posix-setuid posix-setgid posix-getgid + ;; Directory + posix-chdir ;; Access mode flags F_OK R_OK W_OK X_OK @@ -69,6 +72,7 @@ ;; Resources posix-getrlimit posix-setrlimit RLIMIT_NOFILE RLIMIT_NPROC RLIMIT_STACK RLIMIT_CORE RLIMIT_FSIZE + RLIMIT_AS RLIMIT_DATA ;; Time posix-strftime @@ -231,6 +235,8 @@ (define RLIMIT_STACK 3) (define RLIMIT_CORE 4) (define RLIMIT_FSIZE 1) + (define RLIMIT_DATA 2) + (define RLIMIT_AS 9) ;; ========== Process Operations ========== @@ -478,6 +484,20 @@ (define c-access (foreign-procedure "access" (string int) int)) (define (posix-access path mode) (= (c-access path mode) 0)) + (define c-setuid (foreign-procedure "setuid" (unsigned) int)) + (define (posix-setuid uid) (check-posix 'setuid (c-setuid uid))) + + (define c-setgid (foreign-procedure "setgid" (unsigned) int)) + (define (posix-setgid gid) (check-posix 'setgid (c-setgid gid))) + + (define c-getgid (foreign-procedure "getgid" () unsigned)) + (define (posix-getgid) (c-getgid)) + + ;; ========== Directory ========== + + (define c-chdir (foreign-procedure "chdir" (string) int)) + (define (posix-chdir path) (check-posix 'chdir (c-chdir path))) + ;; ========== Environment ========== (define c-setenv (foreign-procedure "setenv" (string string int) int)) new file mode 100644 --- /dev/null +++ b/lib/std/service/config.sls @@ -0,0 +1,88 @@ +#!chezscheme +;;; (std service config) — Service configuration for daemontools-style supervision +;;; +;;; Parses optional config.scm files from service directories specifying +;;; sandbox rules, resource limits, user/group identity, and environment. + +(library (std service config) + (export + make-service-config service-config? + service-config-user service-config-group + service-config-memory-limit service-config-file-limit + service-config-nofile-limit service-config-nproc-limit + service-config-env-dir + service-config-sandbox-read service-config-sandbox-write + service-config-sandbox-exec + service-config-seccomp? + default-service-config + load-service-config) + + (import (chezscheme)) + + ;; Service configuration record + (define-record-type service-config + (fields + user ;; string or #f (username to setuid to) + group ;; string or #f (group to setgid to) + memory-limit ;; integer or #f (RLIMIT_AS in bytes) + file-limit ;; integer or #f (RLIMIT_FSIZE in bytes) + nofile-limit ;; integer or #f (RLIMIT_NOFILE count) + nproc-limit ;; integer or #f (RLIMIT_NPROC count) + env-dir ;; string or #f (path to envdir-style directory) + sandbox-read ;; list of strings (read-only paths) + sandbox-write ;; list of strings (read-write paths) + sandbox-exec ;; list of strings (executable paths) + seccomp? ;; boolean (apply default seccomp filter) + ) + (nongenerative service-config)) + + (define default-service-config + (make-service-config + #f ;; user + #f ;; group + #f ;; memory-limit + #f ;; file-limit + #f ;; nofile-limit + #f ;; nproc-limit + #f ;; env-dir + '() ;; sandbox-read + '() ;; sandbox-write + '() ;; sandbox-exec + #f)) ;; seccomp? + + ;; Load service configuration from config.scm in service directory + ;; Format: alist, e.g.: + ;; ((user . "dns") + ;; (group . "dns") + ;; (memory-limit . 67108864) + ;; (sandbox-read . ("/etc/dns")) + ;; (seccomp . #t)) + (define (load-service-config service-dir) + (let ([config-path (string-append service-dir "/config.scm")]) + (if (file-exists? config-path) + (guard (e [#t default-service-config]) + (let ([alist (call-with-input-file config-path read)]) + (if (list? alist) + (parse-config-alist alist) + default-service-config))) + default-service-config))) + + (define (alist-ref alist key default) + (let ([pair (assq key alist)]) + (if pair (cdr pair) default))) + + (define (parse-config-alist alist) + (make-service-config + (alist-ref alist 'user #f) + (alist-ref alist 'group #f) + (alist-ref alist 'memory-limit #f) + (alist-ref alist 'file-limit #f) + (alist-ref alist 'nofile-limit #f) + (alist-ref alist 'nproc-limit #f) + (alist-ref alist 'env-dir #f) + (alist-ref alist 'sandbox-read '()) + (alist-ref alist 'sandbox-write '()) + (alist-ref alist 'sandbox-exec '()) + (alist-ref alist 'seccomp #f))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/service/control.sls @@ -0,0 +1,118 @@ +#!chezscheme +;;; (std service control) — Client-side service control (svc + svstat) +;;; +;;; Send commands to supervised services via control FIFO. +;;; Read service status from binary status files. + +(library (std service control) + (export + ;; Control commands (write to FIFO) + svc-up! svc-down! svc-once! svc-term! svc-kill! + svc-pause! svc-continue! svc-hup! svc-alarm! svc-exit! + + ;; Status reading + svstat svstat-string svok? + + ;; Status record + make-svstat-info svstat-info? + svstat-info-pid svstat-info-up? svstat-info-paused? + svstat-info-want svstat-info-seconds) + + (import + (chezscheme) + (std os posix)) + + ;; ========== Status Record ========== + + (define-record-type svstat-info + (fields + pid ;; integer (0 if down) + up? ;; boolean + paused? ;; boolean + want ;; symbol: up, down, once + seconds ;; integer (seconds in current state) + ) + (nongenerative svstat-info)) + + ;; ========== TAI64N ========== + + (define TAI-OFFSET 4611686018427387904) + + ;; ========== Control Commands ========== + + (define (svc-send! service-dir byte) + (let ([ctl-path (string-append service-dir "/supervise/control")]) + (let ([fd (posix-open ctl-path O_WRONLY #o0)]) + (let ([buf (make-bytevector 1)]) + (bytevector-u8-set! buf 0 (char->integer byte)) + (posix-write fd buf 1)) + (posix-close fd)))) + + (define (svc-up! service-dir) (svc-send! service-dir #\u)) + (define (svc-down! service-dir) (svc-send! service-dir #\d)) + (define (svc-once! service-dir) (svc-send! service-dir #\o)) + (define (svc-term! service-dir) (svc-send! service-dir #\t)) + (define (svc-kill! service-dir) (svc-send! service-dir #\k)) + (define (svc-pause! service-dir) (svc-send! service-dir #\p)) + (define (svc-continue! service-dir) (svc-send! service-dir #\c)) + (define (svc-hup! service-dir) (svc-send! service-dir #\h)) + (define (svc-alarm! service-dir) (svc-send! service-dir #\a)) + (define (svc-exit! service-dir) (svc-send! service-dir #\x)) + + ;; ========== Status Reading ========== + + (define (svstat service-dir) + (let ([status-path (string-append service-dir "/supervise/status")]) + (guard (e [#t #f]) + (let ([fd (posix-open status-path O_RDONLY 0)]) + (let ([buf (make-bytevector 18 0)]) + (let ([n (posix-read fd buf 18)]) + (posix-close fd) + (if (< n 18) + #f + (let* ([tai-secs (bytevector-u64-ref buf 0 (endianness big))] + [unix-secs (- tai-secs TAI-OFFSET)] + [pid (bytevector-u32-ref buf 12 (endianness big))] + [paused? (= (bytevector-u8-ref buf 16) 1)] + [want-byte (bytevector-u8-ref buf 17)] + [want (cond + [(= want-byte (char->integer #\u)) 'up] + [(= want-byte (char->integer #\d)) 'down] + [else 'once])] + [up? (> pid 0)] + [now (time-second (current-time 'time-utc))] + [elapsed (max 0 (- now unix-secs))]) + (make-svstat-info pid up? paused? want elapsed))))))))) + + (define (svstat-string service-dir) + (let ([info (svstat service-dir)]) + (if (not info) + (string-append service-dir ": unable to read status") + (string-append + service-dir ": " + (if (svstat-info-up? info) + (string-append + "up (pid " (number->string (svstat-info-pid info)) ") " + (number->string (svstat-info-seconds info)) " seconds") + (string-append + "down " (number->string (svstat-info-seconds info)) " seconds")) + (if (svstat-info-paused? info) ", paused" "") + (cond + [(and (svstat-info-up? info) + (eq? (svstat-info-want info) 'down)) + ", want down"] + [(and (not (svstat-info-up? info)) + (eq? (svstat-info-want info) 'up)) + ", want up"] + [else ""]))))) + + (define (svok? service-dir) + ;; Check if supervise is running by trying to open the ok FIFO + (let ([ok-path (string-append service-dir "/supervise/ok")]) + (guard (e [#t #f]) + (let ([fd (posix-open ok-path + (bitwise-ior O_WRONLY O_NONBLOCK) 0)]) + (posix-close fd) + #t)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/service/multilog.sls @@ -0,0 +1,115 @@ +#!chezscheme +;;; (std service multilog) — Log multiplexer with TAI64N timestamps and rotation +;;; +;;; Reads lines from stdin, optionally prepends TAI64N timestamps, +;;; writes to rotating log files in a log directory. Inspired by +;;; DJB's multilog. + +(library (std service multilog) + (export multilog!) + + (import (chezscheme)) + + ;; ========== TAI64N Timestamp ========== + + (define TAI-OFFSET 4611686018427387904) + + (define (tai64n-stamp) + ;; Returns a TAI64N timestamp string: @hex-encoded-12-bytes + (let* ([t (current-time 'time-utc)] + [secs (+ (time-second t) TAI-OFFSET)] + [nsecs (time-nanosecond t)] + [bv (make-bytevector 12 0)]) + (bytevector-u64-set! bv 0 secs (endianness big)) + (bytevector-u32-set! bv 4 nsecs (endianness big)) + (string-append "@" + (let loop ([i 0] [acc '()]) + (if (= i 12) + (apply string-append (reverse acc)) + (loop (+ i 1) + (cons (let ([b (bytevector-u8-ref bv i)]) + (string-append + (if (< b 16) "0" "") + (number->string b 16))) + acc))))))) + + ;; ========== Log Rotation ========== + + (define (rotate-log! log-dir max-files) + ;; Rename current → @timestamp.s, prune excess files + (let* ([current-path (string-append log-dir "/current")] + [stamp (tai64n-stamp)] + [archive-name (string-append stamp ".s")] + [archive-path (string-append log-dir "/" archive-name)]) + ;; Rename current to archive + (when (file-exists? current-path) + (rename-file current-path archive-path)) + ;; Prune oldest archives beyond max-files + (let* ([entries (directory-list log-dir)] + [archives (filter (lambda (f) (and (> (string-length f) 2) + (char=? (string-ref f 0) #\@) + (string-suffix? ".s" f))) + entries)] + [sorted (sort string>? archives)] ;; newest first + [excess (if (> (length sorted) max-files) + (list-tail sorted max-files) + '())]) + (for-each + (lambda (f) + (delete-file (string-append log-dir "/" f))) + excess)))) + + (define (string-suffix? suffix str) + (let ([slen (string-length suffix)] + [len (string-length str)]) + (and (>= len slen) + (string=? (substring str (- len slen) len) suffix)))) + + ;; ========== Main Loop ========== + + (define multilog! + (case-lambda + [(log-dir) + (multilog! log-dir 99999 10 #t)] + [(log-dir max-size) + (multilog! log-dir max-size 10 #t)] + [(log-dir max-size max-files) + (multilog! log-dir max-size max-files #t)] + [(log-dir max-size max-files timestamp?) + ;; Ensure log directory exists + (unless (file-exists? log-dir) + (mkdir log-dir)) + + (let ([current-path (string-append log-dir "/current")]) + (let outer-loop () + ;; Open current log file (append mode) + (let ([out (open-file-output-port current-path + (file-options no-fail no-truncate) + (buffer-mode line) + (native-transcoder))]) + ;; Seek to end + (set-port-position! out (port-length out)) + + (let inner-loop ([bytes-written (port-position out)]) + (let ([line (get-line (current-input-port))]) + (if (eof-object? line) + ;; EOF on stdin — done + (close-port out) + ;; Write line with optional timestamp + (let* ([prefix (if timestamp? + (string-append (tai64n-stamp) " ") + "")] + [output (string-append prefix line "\n")] + [len (string-length output)]) + (put-string out output) + (flush-output-port out) + (let ([new-total (+ bytes-written len)]) + (if (>= new-total max-size) + ;; Rotate + (begin + (close-port out) + (rotate-log! log-dir max-files) + (outer-loop)) + (inner-loop new-total))))))))))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/service/supervise.sls @@ -0,0 +1,325 @@ +#!chezscheme +;;; (std service supervise) — DJB-style process supervision with sandboxing +;;; +;;; Core supervision loop for a single service directory. Forks the +;;; service's `run` script, monitors via SIGCHLD, accepts control +;;; commands via FIFO, writes DJB-compatible 18-byte status files. +;;; Adds Landlock/seccomp sandboxing and rlimit enforcement. + +(library (std service supervise) + (export supervise!) + + (import + (chezscheme) + (std os posix) + (std service config)) + + ;; ========== TAI64N Timestamps ========== + ;; TAI64N: 8 bytes TAI seconds + 4 bytes nanoseconds + ;; TAI = UNIX epoch + 2^62 (4611686018427387904) + + (define TAI-OFFSET 4611686018427387904) + + (define (tai64n-now) + ;; Returns a 12-byte bytevector: 8 bytes TAI seconds + 4 bytes nanoseconds + (let* ([t (current-time 'time-utc)] + [secs (+ (time-second t) TAI-OFFSET)] + [nsecs (time-nanosecond t)] + [bv (make-bytevector 12 0)]) + ;; Pack seconds big-endian (8 bytes) + (bytevector-u64-set! bv 0 secs (endianness big)) + ;; Pack nanoseconds big-endian (4 bytes) + (bytevector-u32-set! bv 8 nsecs (endianness big)) + bv)) + + ;; ========== Status File ========== + ;; DJB format: 18 bytes + ;; Bytes 0-11: TAI64N timestamp (when process entered current state) + ;; Bytes 12-15: PID (big-endian uint32, 0 if down) + ;; Byte 16: paused flag (0 or 1) + ;; Byte 17: want flag (char: 'u' = up, 'd' = down, 0 = once) + + (define (write-status! service-dir pid up? paused? want timestamp) + (let ([status-path (string-append service-dir "/supervise/status")] + [tmp-path (string-append service-dir "/supervise/status.new")] + [bv (make-bytevector 18 0)]) + ;; Copy timestamp (12 bytes) + (bytevector-copy! timestamp 0 bv 0 12) + ;; PID (big-endian uint32) + (bytevector-u32-set! bv 12 (if up? pid 0) (endianness big)) + ;; Paused flag + (bytevector-u8-set! bv 16 (if paused? 1 0)) + ;; Want flag + (bytevector-u8-set! bv 17 + (case want + [(up) (char->integer #\u)] + [(down) (char->integer #\d)] + [else 0])) + ;; Atomic write: write to tmp, rename + (let ([fd (posix-open tmp-path + (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd bv 18) + (posix-close fd)) + (rename-file tmp-path status-path))) + + ;; ========== Environment Directory ========== + ;; Each file in the env dir becomes an environment variable. + ;; Filename = variable name, file contents = value (first line, trimmed). + + (define (load-envdir path) + (when (and path (file-exists? path) (file-directory? path)) + (for-each + (lambda (name) + (let ([fpath (string-append path "/" name)]) + (when (file-regular? fpath) + (let ([val (call-with-input-file fpath + (lambda (p) + (let ([line (get-line p)]) + (if (eof-object? line) "" line))))]) + (posix-setenv name val #t))))) + (directory-list path)))) + + ;; ========== Resource Limits ========== + + (define (apply-rlimits! config) + (let ([mem (service-config-memory-limit config)] + [fsz (service-config-file-limit config)] + [nof (service-config-nofile-limit config)] + [npr (service-config-nproc-limit config)]) + (when mem (posix-setrlimit RLIMIT_AS mem mem)) + (when fsz (posix-setrlimit RLIMIT_FSIZE fsz fsz)) + (when nof (posix-setrlimit RLIMIT_NOFILE nof nof)) + (when npr (posix-setrlimit RLIMIT_NPROC npr npr)))) + + ;; ========== User/Group Switching ========== + ;; Resolve username/groupname to uid/gid via getpwnam/getgrnam + + (define c-getpwnam (foreign-procedure "getpwnam" (string) void*)) + (define c-getgrnam (foreign-procedure "getgrnam" (string) void*)) + + (define (resolve-uid username) + (if username + (let ([pw (c-getpwnam username)]) + (if (zero? pw) + (error 'supervise "unknown user" username) + ;; struct passwd: pw_uid is at offset 16 on Linux x86_64 + ;; char* pw_name (8), char* pw_passwd (8), uid_t pw_uid (4) + (foreign-ref 'unsigned-32 pw 16))) + #f)) + + (define (resolve-gid groupname) + (if groupname + (let ([gr (c-getgrnam groupname)]) + (if (zero? gr) + (error 'supervise "unknown group" groupname) + ;; struct group: gr_gid is at offset 16 on Linux x86_64 + ;; char* gr_name (8), char* gr_passwd (8), gid_t gr_gid (4) + (foreign-ref 'unsigned-32 gr 16))) + #f)) + + (define (drop-privileges! config) + (let ([gid (resolve-gid (service-config-group config))] + [uid (resolve-uid (service-config-user config))]) + ;; Must setgid before setuid (can't change group after dropping root) + (when gid (posix-setgid gid)) + (when uid (posix-setuid uid)))) + + ;; ========== Control FIFO Commands ========== + ;; Single-byte commands matching DJB daemontools: + ;; u = up, d = down, o = once, x = exit + ;; p = pause, c = continue + ;; h = HUP, a = ALRM, i = INT, t = TERM, k = KILL + + (define (handle-control-byte byte pid up?) + ;; Returns (values new-want should-start? should-exit?) + (let ([ch (integer->char byte)]) + (case ch + [(#\u) (values 'up (not up?) #f)] ;; start if not running + [(#\d) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGTERM) + (posix-kill pid SIGCONT)) + (values 'down #f #f))] + [(#\o) (values 'once (not up?) #f)] ;; run once, don't restart + [(#\x) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGTERM) + (posix-kill pid SIGCONT)) + (values 'down #f #t))] ;; exit supervise + [(#\p) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGSTOP)) + (values #f #f #f))] ;; #f = don't change want + [(#\c) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGCONT)) + (values #f #f #f))] + [(#\h) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGHUP)) + (values #f #f #f))] + [(#\a) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGALRM)) + (values #f #f #f))] + [(#\i) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGINT)) + (values #f #f #f))] + [(#\t) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGTERM)) + (values #f #f #f))] + [(#\k) (begin + (when (and up? (> pid 0)) + (posix-kill pid SIGKILL)) + (values #f #f #f))] + [else (values #f #f #f)]))) + + ;; ========== Main Supervision Loop ========== + + (define (supervise! service-dir) + ;; Ensure supervise directory exists + (let ([sv-dir (string-append service-dir "/supervise")]) + (unless (file-exists? sv-dir) + (mkdir sv-dir)) + + ;; Create control and ok FIFOs + (let ([control-path (string-append sv-dir "/control")] + [ok-path (string-append sv-dir "/ok")]) + (unless (file-exists? control-path) + (posix-mkfifo control-path #o600)) + (unless (file-exists? ok-path) + (posix-mkfifo ok-path #o600)) + + ;; Load service configuration + (let ([config (load-service-config service-dir)] + [run-path (string-append service-dir "/run")]) + + ;; Block SIGCHLD so we can use sigwait + (posix-sigprocmask SIG_BLOCK (list SIGCHLD)) + + ;; Open control FIFO non-blocking for reading + ;; We also open it for writing to keep it open (no EOF when writers close) + (let ([ctl-r (posix-open control-path + (bitwise-ior O_RDONLY O_NONBLOCK) 0)] + [ctl-w (posix-open control-path O_WRONLY 0)]) + + ;; State + (let loop ([pid 0] + [up? #f] + [paused? #f] + [want 'up] + [should-exit? #f] + [timestamp (tai64n-now)]) + + ;; Write status + (write-status! service-dir pid up? paused? want timestamp) + + (cond + ;; Exit requested and service is down + [should-exit? + (when (not up?) + (posix-close ctl-r) + (posix-close ctl-w) + (void))] + + ;; Need to start the service + [(and (not up?) (memq want '(up once))) + (let ([child-pid (posix-fork)]) + (if (= child-pid 0) + ;; === Child process === + (begin + ;; Unblock SIGCHLD in child + (posix-sigprocmask SIG_UNBLOCK (list SIGCHLD)) + ;; Close control FIFOs + (posix-close ctl-r) + (posix-close ctl-w) + ;; Load environment + (load-envdir (service-config-env-dir config)) + (let ([env-path (string-append service-dir "/env")]) + (when (and (file-exists? env-path) (file-directory? env-path)) + (load-envdir env-path))) + ;; Apply resource limits + (apply-rlimits! config) + ;; Drop privileges + (drop-privileges! config) + ;; Exec the run script + ;; Build argv: ["/bin/sh", "-c", "exec ./run"] + ;; But since run should be executable, just exec it directly + (let* ([argv-list (list run-path)] + [argc (length argv-list)] + [argv (foreign-alloc (* 8 (+ argc 1)))]) + ;; Set argv pointers + (let fill ([i 0] [args argv-list]) + (if (null? args) + (foreign-set! 'void* argv (* i 8) 0) ;; NULL terminator + (let ([s (car args)]) + ;; Allocate C string + (let ([cs (foreign-alloc (+ (string-length s) 1))]) + (let put-char ([j 0]) + (if (= j (string-length s)) + (foreign-set! 'unsigned-8 cs j 0) + (begin + (foreign-set! 'unsigned-8 cs j + (char->integer (string-ref s j))) + (put-char (+ j 1))))) + (foreign-set! 'void* argv (* i 8) cs)) + (fill (+ i 1) (cdr args))))) + ;; envp = NULL (inherit current environment) + (posix-execve run-path argv 0)) + ;; If exec fails, exit child + (posix-exit 111)) + ;; === Parent process === + (loop child-pid #t #f want #f (tai64n-now))))] + + ;; Service is running or want=down, wait for events + [else + ;; Try to reap any dead children (non-blocking) + (let-values ([(wpid wstatus) + (guard (e [#t (values 0 0)]) + (posix-waitpid -1 WNOHANG))]) + (let ([child-died? (and (> wpid 0) (= wpid pid))]) + + ;; Read control commands (non-blocking) + (let read-ctl ([cur-want want] + [cur-start? #f] + [cur-exit? should-exit?] + [cur-paused? paused?]) + (let ([buf (make-bytevector 1 0)]) + (let ([n (guard (e [#t 0]) + (posix-read ctl-r buf 1))]) + (if (> n 0) + ;; Got a command byte + (let-values ([(new-want should-start? should-exit-now?) + (handle-control-byte + (bytevector-u8-ref buf 0) + pid up?)]) + (read-ctl + (or new-want cur-want) + (or should-start? cur-start?) + (or should-exit-now? cur-exit?) + (if (memv (integer->char (bytevector-u8-ref buf 0)) + '(#\p)) + #t + (if (memv (integer->char (bytevector-u8-ref buf 0)) + '(#\c)) + #f + cur-paused?)))) + ;; No more commands + (cond + ;; Child died + [child-died? + (loop 0 #f #f cur-want cur-exit? (tai64n-now))] + ;; Need to start + [cur-start? + (loop pid up? cur-paused? cur-want cur-exit? timestamp)] + ;; Otherwise sleep briefly and re-check + [else + ;; Use sigwait with timeout via sleep + ;; (brief sleep to avoid busy-wait) + (sleep (make-time 'time-duration 0 1)) + (loop pid up? cur-paused? cur-want cur-exit? timestamp) + ])))))))]))))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/service/svscan.sls @@ -0,0 +1,157 @@ +#!chezscheme +;;; (std service svscan) — Service directory scanner +;;; +;;; Scans a directory for service subdirectories, spawns supervise +;;; for each one. Rescans every 5 seconds. Sets up log pipes +;;; between services and their log/ subdirectories. + +(library (std service svscan) + (export svscan!) + + (import + (chezscheme) + (std os posix) + (std service supervise)) + + ;; ========== Service Tracking ========== + ;; Track services by (dev . ino) to handle renames correctly. + + (define-record-type tracked-service + (fields + name ;; string (directory name) + dev ;; integer (device number) + ino ;; integer (inode number) + pid ;; integer (supervise process PID) + log-pid ;; integer or #f (log supervise PID) + ) + (nongenerative tracked-service)) + + ;; ========== Service Discovery ========== + + (define (scan-service-dirs scan-dir) + ;; Returns list of (name dev ino has-log?) for each service subdirectory + (let ([entries (directory-list scan-dir)]) + (filter values + (map (lambda (name) + (let ([path (string-append scan-dir "/" name)]) + (guard (e [#t #f]) + (let ([st (posix-stat path)]) + (let ([dev (stat-dev st)] + [ino (stat-ino st)] + [is-dir? (stat-is-directory? st)]) + (free-stat st) + (and is-dir? + ;; Skip hidden dirs and supervise dirs + (not (char=? (string-ref name 0) #\.)) + (not (string=? name "supervise")) + ;; Must have a run script + (file-exists? (string-append path "/run")) + (let ([has-log? (and (file-exists? + (string-append path "/log")) + (file-exists? + (string-append path "/log/run")))]) + (list name dev ino has-log?)))))))) + entries)))) + + ;; ========== Spawning ========== + + (define (spawn-supervise! scan-dir name log-pipe-read-fd) + ;; Fork a child that runs supervise! for the service + (let ([service-dir (string-append scan-dir "/" name)] + [pid (posix-fork)]) + (cond + [(= pid 0) + ;; Child: redirect stdin from log pipe if provided + (when log-pipe-read-fd + (posix-dup2 log-pipe-read-fd 0) + (posix-close log-pipe-read-fd)) + ;; Run supervise (does not return) + (guard (e [#t (posix-exit 111)]) + (supervise! service-dir)) + (posix-exit 0)] + [else pid]))) + + (define (start-service! scan-dir name has-log?) + ;; Start supervise for a service, optionally with log pipe + (if has-log? + ;; Create pipe: service stdout → log stdin + (let-values ([(pipe-r pipe-w) (posix-pipe)]) + (let* ([log-dir (string-append scan-dir "/" name "/log")] + ;; Start log supervise first (reads from pipe) + [log-pid (let ([p (posix-fork)]) + (cond + [(= p 0) + (posix-close pipe-w) + (posix-dup2 pipe-r 0) + (posix-close pipe-r) + (guard (e [#t (posix-exit 111)]) + (supervise! log-dir)) + (posix-exit 0)] + [else p]))] + ;; Start service supervise (writes to pipe) + [svc-pid (let ([p (posix-fork)]) + (cond + [(= p 0) + (posix-close pipe-r) + (posix-dup2 pipe-w 1) + (posix-close pipe-w) + (guard (e [#t (posix-exit 111)]) + (supervise! (string-append scan-dir "/" name))) + (posix-exit 0)] + [else p]))]) + ;; Parent closes both ends of pipe + (posix-close pipe-r) + (posix-close pipe-w) + (values svc-pid log-pid))) + ;; No log — just start service + (let ([svc-pid (spawn-supervise! scan-dir name #f)]) + (values svc-pid #f)))) + + ;; ========== Main Scanner Loop ========== + + (define (svscan! scan-dir) + ;; Block SIGCHLD for cleanup + (posix-sigprocmask SIG_BLOCK (list SIGCHLD)) + + (let loop ([services '()]) + ;; Reap any dead children (non-blocking) + (let reap () + (let-values ([(pid status) + (guard (e [#t (values 0 0)]) + (posix-waitpid -1 WNOHANG))]) + (when (> pid 0) + ;; Remove from tracked list + (set! services + (filter (lambda (s) + (and (not (= (tracked-service-pid s) pid)) + (or (not (tracked-service-log-pid s)) + (not (= (tracked-service-log-pid s) pid))))) + services)) + (reap)))) + + ;; Scan for services + (let ([found (scan-service-dirs scan-dir)]) + ;; Find new services (not already tracked) + (let ([tracked-keys (map (lambda (s) + (cons (tracked-service-dev s) + (tracked-service-ino s))) + services)]) + (for-each + (lambda (entry) + (let ([name (car entry)] + [dev (cadr entry)] + [ino (caddr entry)] + [has-log? (cadddr entry)]) + (unless (member (cons dev ino) tracked-keys) + ;; New service — start it + (let-values ([(svc-pid log-pid) (start-service! scan-dir name has-log?)]) + (set! services + (cons (make-tracked-service name dev ino svc-pid log-pid) + services)))))) + found))) + + ;; Sleep 5 seconds, then rescan + (sleep (make-time 'time-duration 0 5)) + (loop services))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-service-config.ss @@ -0,0 +1,160 @@ +#!chezscheme +;;; test-service-config.ss — Tests for (std service config) + +(import (chezscheme) (std service config)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (if expr + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => #f (expected #t)\n")))])) + +(display "=== Service Config Tests ===\n") + +;; ========== Default Config ========== + +(check-true (service-config? default-service-config)) +(check (service-config-user default-service-config) => #f) +(check (service-config-group default-service-config) => #f) +(check (service-config-memory-limit default-service-config) => #f) +(check (service-config-file-limit default-service-config) => #f) +(check (service-config-nofile-limit default-service-config) => #f) +(check (service-config-nproc-limit default-service-config) => #f) +(check (service-config-env-dir default-service-config) => #f) +(check (service-config-sandbox-read default-service-config) => '()) +(check (service-config-sandbox-write default-service-config) => '()) +(check (service-config-sandbox-exec default-service-config) => '()) +(check (service-config-seccomp? default-service-config) => #f) + +;; ========== make-service-config ========== + +(let ([c (make-service-config + "dns" "dns" 67108864 1048576 1024 64 + "/etc/dns/env" + '("/etc/dns") '("/var/log/dns") '("/usr/bin") + #t)]) + (check-true (service-config? c)) + (check (service-config-user c) => "dns") + (check (service-config-group c) => "dns") + (check (service-config-memory-limit c) => 67108864) + (check (service-config-file-limit c) => 1048576) + (check (service-config-nofile-limit c) => 1024) + (check (service-config-nproc-limit c) => 64) + (check (service-config-env-dir c) => "/etc/dns/env") + (check (service-config-sandbox-read c) => '("/etc/dns")) + (check (service-config-sandbox-write c) => '("/var/log/dns")) + (check (service-config-sandbox-exec c) => '("/usr/bin")) + (check (service-config-seccomp? c) => #t)) + +;; ========== load-service-config from file ========== + +(define test-dir "/tmp/test-service-config") + +;; Create test service directory +(when (file-exists? test-dir) + (for-each (lambda (f) + (let ([p (string-append test-dir "/" f)]) + (when (file-exists? p) (delete-file p)))) + '("config.scm" "run")) + (delete-directory test-dir)) +(mkdir test-dir) + +;; Test: no config.scm → default +(let ([c (load-service-config test-dir)]) + (check-true (service-config? c)) + (check (service-config-user c) => #f) + (check (service-config-memory-limit c) => #f)) + +;; Test: write a config.scm and load it +(call-with-output-file (string-append test-dir "/config.scm") + (lambda (p) + (write '((user . "www") + (group . "www") + (memory-limit . 134217728) + (nofile-limit . 256) + (sandbox-read . ("/var/www" "/etc/ssl")) + (sandbox-write . ("/var/log/www")) + (seccomp . #t)) + p)) + 'replace) + +(let ([c (load-service-config test-dir)]) + (check-true (service-config? c)) + (check (service-config-user c) => "www") + (check (service-config-group c) => "www") + (check (service-config-memory-limit c) => 134217728) + (check (service-config-file-limit c) => #f) + (check (service-config-nofile-limit c) => 256) + (check (service-config-nproc-limit c) => #f) + (check (service-config-sandbox-read c) => '("/var/www" "/etc/ssl")) + (check (service-config-sandbox-write c) => '("/var/log/www")) + (check (service-config-seccomp? c) => #t)) + +;; Test: invalid config.scm → default +(call-with-output-file (string-append test-dir "/config.scm") + (lambda (p) + (display "this is not valid scheme" p)) + 'replace) + +(let ([c (load-service-config test-dir)]) + (check-true (service-config? c)) + (check (service-config-user c) => #f)) + +;; Test: non-alist → default +(call-with-output-file (string-append test-dir "/config.scm") + (lambda (p) + (write 42 p)) + 'replace) + +(let ([c (load-service-config test-dir)]) + (check-true (service-config? c))