build: convert raw-Chez .sls library source to src/ .ss with generated .sls wrappers
ober
83e2e0073ae75043877d00b9f0dd7316539aaf99
--- a/.gitignore +++ b/.gitignore @@ -14,3 +14,6 @@ jerboa-stage/ # generated FFI symbol list (build artifact) support/ffi-symbols.gen + +# Generated .sls wrappers from src/ .ss source +lib/**/*.sls --- a/Makefile +++ b/Makefile @@ -60,7 +60,10 @@ ensure-jsqlite: toolchain-check # The final pass stabilizes the WPO payload after the generated FFI symbol set # exists, so repeated clean release builds produce the same secmon-agent bytes. -binary: ensure-jsqlite +transpile: + python3 support/wrap-ss-to-sls.py src lib + +binary: ensure-jsqlite transpile @: > support/ffi-symbols.gen $(JERBUILD) build JERBUILD="$(JERBUILD)" sh support/gen-ffi-symbols.sh deleted file mode 100644 --- a/lib/secmon/buffer/ring.sls +++ /dev/null @@ -1,92 +0,0 @@ -(library (secmon buffer ring) - (export - make-event-buffer event-buffer? - buffer-store! buffer-get-after buffer-get-in-range - buffer-clear-before! buffer-latest-seq buffer-count - make-stored-event stored-event? stored-event-seq stored-event-timestamp-ms - stored-event-encrypted-data) - (import - (chezscheme) - (jerboa prelude clean) - (secmon monitor events) - (secmon crypto ecies)) - - (define-record-type stored-event - (fields seq timestamp-ms encrypted-data) - (nongenerative stored-event-type)) - - (define-record-type event-buffer - (fields encryptor max-size - (mutable events) (mutable next-seq) mutex) - (nongenerative event-buffer-type) - (protocol - (lambda (new) - (lambda (encryptor max-size) - (new encryptor max-size '() 0 (make-mutex)))))) - - (define (buffer-store! buf event) - (let ([mtx (event-buffer-mutex buf)]) - (dynamic-wind - (lambda () (mutex-acquire mtx)) - (lambda () - (let* ([seq (event-buffer-next-seq buf)] - [plaintext (security-event->bytevector event)] - [encrypted (ecies-encrypt (event-buffer-encryptor buf) plaintext)] - [enc-bytes (encrypted-payload->bytevector encrypted)] - [stored (make-stored-event seq - (security-event-timestamp-ms event) - enc-bytes)] - [events (event-buffer-events buf)] - [new-events (cons stored events)]) - (event-buffer-next-seq-set! buf (+ seq 1)) - (if (> (length new-events) (event-buffer-max-size buf)) - (event-buffer-events-set! buf - (list-head new-events (event-buffer-max-size buf))) - (event-buffer-events-set! buf new-events)) - stored)) - (lambda () (mutex-release mtx))))) - - (define (buffer-get-after buf seq) - (let ([mtx (event-buffer-mutex buf)]) - (mutex-acquire mtx) - (let ([result (reverse - (filter (lambda (e) (> (stored-event-seq e) seq)) - (event-buffer-events buf)))]) - (mutex-release mtx) - result))) - - (define (buffer-get-in-range buf start-ms end-ms) - (let ([mtx (event-buffer-mutex buf)]) - (mutex-acquire mtx) - (let ([result (reverse - (filter - (lambda (e) - (and (>= (stored-event-timestamp-ms e) start-ms) - (<= (stored-event-timestamp-ms e) end-ms))) - (event-buffer-events buf)))]) - (mutex-release mtx) - result))) - - (define (buffer-clear-before! buf seq) - (let ([mtx (event-buffer-mutex buf)]) - (mutex-acquire mtx) - (event-buffer-events-set! buf - (filter (lambda (e) (> (stored-event-seq e) seq)) - (event-buffer-events buf))) - (mutex-release mtx))) - - (define (buffer-latest-seq buf) - (let ([mtx (event-buffer-mutex buf)]) - (mutex-acquire mtx) - (let ([s (event-buffer-next-seq buf)]) - (mutex-release mtx) - s))) - - (define (buffer-count buf) - (let ([mtx (event-buffer-mutex buf)]) - (mutex-acquire mtx) - (let ([n (length (event-buffer-events buf))]) - (mutex-release mtx) - n))) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/config.sls +++ /dev/null @@ -1,77 +0,0 @@ -(library (secmon config) - (export - make-agent-config agent-config? - agent-config-listen-addr agent-config-poll-interval-ms - agent-config-max-buffer-size agent-config-public-key - agent-config-psk agent-config-debug-mode - load-agent-config load-collector-config - load-key-from-env) - (import - (chezscheme) - (jerboa prelude clean) - (secmon stealth obfuscate) - (std text hex)) - - (define-record-type agent-config - (fields listen-addr poll-interval-ms max-buffer-size - public-key psk debug-mode) - (nongenerative agent-config-type)) - - (define (load-key-from-env env-var fallback-path) - ;; Try env var first; if it looks like a file path, read it - (let ([val (getenv env-var)]) - (cond - [(and val (> (string-length val) 0) - (or (string-prefix? "/" val) (string-prefix? "." val)) - (< (string-length val) 64)) - ;; Treat as file path - (guard (e [#t #f]) - (let ([content (string-trim - (call-with-input-file val - (lambda (p) (get-string-all p))))]) - (hex-string->u8vector content)))] - [(and val (>= (string-length val) 64)) - (hex-string->u8vector val)] - [fallback-path - (guard (e [#t #f]) - (let ([content (string-trim - (call-with-input-file fallback-path - (lambda (p) (get-string-all p))))]) - (hex-string->u8vector content)))] - [else #f]))) - - (define (clear-secmon-env!) - (let ([c-unsetenv (foreign-procedure "unsetenv" (string) int)]) - (for-each - (lambda (var) - (when (getenv var) - (c-unsetenv var))) - (list (obfstr "SECMON_LISTEN") (obfstr "SECMON_POLL_MS") - (obfstr "SECMON_BUFFER_SIZE") (obfstr "SECMON_PUBLIC_KEY") - (obfstr "SECMON_PSK") (obfstr "SECMON_PRIVATE_KEY") - (obfstr "SECMON_DEBUG"))))) - - (define (load-agent-config) - (let ([config (make-agent-config - (or (getenv (obfstr "SECMON_LISTEN")) (obfstr "127.0.0.1:31337")) - (or (and (getenv (obfstr "SECMON_POLL_MS")) - (string->number (getenv (obfstr "SECMON_POLL_MS")))) - 100) - (or (and (getenv (obfstr "SECMON_BUFFER_SIZE")) - (string->number (getenv (obfstr "SECMON_BUFFER_SIZE")))) - 10000) - (load-key-from-env (obfstr "SECMON_PUBLIC_KEY") (obfstr "keys/public.key")) - (load-key-from-env (obfstr "SECMON_PSK") (obfstr "keys/psk.key")) - (and (getenv (obfstr "SECMON_DEBUG")) #t))]) - (clear-secmon-env!) - config)) - - (define (load-collector-config) - (let-values ([(private-key psk) - (values - (load-key-from-env (obfstr "SECMON_PRIVATE_KEY") (obfstr "keys/private.key")) - (load-key-from-env (obfstr "SECMON_PSK") (obfstr "keys/psk.key")))]) - (clear-secmon-env!) - (values private-key psk))) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/crypto/ecies.sls +++ /dev/null @@ -1,130 +0,0 @@ -(library (secmon crypto ecies) - (export - make-ecies-encryptor ecies-encryptor? ecies-encryptor-public-key - make-ecies-decryptor ecies-decryptor? ecies-decryptor-private-key - ecies-encrypt ecies-decrypt - encrypted-payload? encrypted-payload-ephemeral-pubkey - encrypted-payload-nonce encrypted-payload-ciphertext - encrypted-payload->bytevector bytevector->encrypted-payload) - (import - (chezscheme) - (jerboa prelude clean) - (std crypto native-rust) - (std text hex)) - - ;; --- Encrypted Payload --- - - (define-record-type encrypted-payload - (fields ephemeral-pubkey nonce ciphertext) - (nongenerative encrypted-payload-type)) - - ;; Serialize: ephemeral_pubkey(32) || nonce(12) || ciphertext_len(4 LE) || ciphertext(N) - (define (encrypted-payload->bytevector ep) - (let* ([epk (encrypted-payload-ephemeral-pubkey ep)] - [nonce (encrypted-payload-nonce ep)] - [ct (encrypted-payload-ciphertext ep)] - [ct-len (bytevector-length ct)] - [total (+ 32 12 4 ct-len)] - [out (make-bytevector total)]) - (bytevector-copy! epk 0 out 0 32) - (bytevector-copy! nonce 0 out 32 12) - (bytevector-u32-set! out 44 ct-len (endianness little)) - (bytevector-copy! ct 0 out 48 ct-len) - out)) - - (define (bytevector->encrypted-payload bv) - (let ([len (bytevector-length bv)]) - (when (< len 48) - (error 'bytevector->encrypted-payload "data too short" len)) - (let ([ct-len (bytevector-u32-ref bv 44 (endianness little))]) - (unless (= (+ 48 ct-len) len) - (error 'bytevector->encrypted-payload - "ciphertext length out of bounds" ct-len len)) - (let ([epk (make-bytevector 32)] - [nonce (make-bytevector 12)] - [ct (make-bytevector ct-len)]) - (bytevector-copy! bv 0 epk 0 32) - (bytevector-copy! bv 32 nonce 0 12) - (bytevector-copy! bv 48 ct 0 ct-len) - (make-encrypted-payload epk nonce ct))))) - - ;; --- FFI bindings for X25519 and HKDF --- - - (define c-x25519-keypair - (foreign-procedure "jerboa_x25519_generate_keypair" (u8* u8*) int)) - - (define c-x25519-public-from-private - (foreign-procedure "jerboa_x25519_public_from_private" (u8* size_t u8*) int)) - - (define c-x25519-dh - (foreign-procedure "jerboa_x25519_diffie_hellman" - (u8* size_t u8* size_t u8* size_t) int)) - - (define c-hkdf-sha256 - (foreign-procedure "jerboa_hkdf_sha256" - (u8* size_t u8* size_t u8* size_t u8* size_t) int)) - - (define (x25519-keypair) - (let ([priv-key (make-bytevector 32)] - [pub-key (make-bytevector 32)]) - (let ([rc (c-x25519-keypair priv-key pub-key)]) - (when (< rc 0) - (error 'x25519-keypair "key generation failed" (rust-last-error))) - (values priv-key pub-key)))) - - (define (x25519-public-from-private priv-key) - (let ([pub-key (make-bytevector 32)]) - (let ([rc (c-x25519-public-from-private priv-key 32 pub-key)]) - (when (< rc 0) - (error 'x25519-public-from-private "failed" (rust-last-error))) - pub-key))) - - (define (x25519-dh our-private their-public) - (let ([shared (make-bytevector 32)]) - (let ([rc (c-x25519-dh our-private 32 their-public 32 shared 32)]) - (when (< rc 0) - (error 'x25519-dh "DH failed" (rust-last-error))) - shared))) - - (define (hkdf-sha256 ikm salt info output-len) - (let ([output (make-bytevector output-len)]) - (let ([rc (c-hkdf-sha256 - ikm (bytevector-length ikm) - (if salt salt (make-bytevector 0)) (if salt (bytevector-length salt) 0) - info (bytevector-length info) - output output-len)]) - (when (< rc 0) - (error 'hkdf-sha256 "HKDF failed" (rust-last-error))) - output))) - - ;; --- ECIES Encryptor (agent: public key only, cannot decrypt) --- - - (define-record-type ecies-encryptor - (fields public-key) ; bytevector, 32 bytes - (nongenerative ecies-encryptor-type)) - - (define (ecies-encrypt encryptor plaintext) - (let-values ([(eph-priv eph-pub) (x25519-keypair)]) - (let* ([shared-secret (x25519-dh eph-priv (ecies-encryptor-public-key encryptor))] - [aes-key (hkdf-sha256 shared-secret eph-pub - (string->utf8 "secmon-ecies-v1") 32)] - [nonce (rust-random-bytes 12)] - [ciphertext (rust-aead-seal aes-key nonce plaintext #vu8())]) - (make-encrypted-payload eph-pub nonce ciphertext)))) - - ;; --- ECIES Decryptor (collector: private key required) --- - - (define-record-type ecies-decryptor - (fields private-key) ; bytevector, 32 bytes - (nongenerative ecies-decryptor-type)) - - (define (ecies-decrypt decryptor payload) - (let* ([eph-pub (encrypted-payload-ephemeral-pubkey payload)] - [shared-secret (x25519-dh (ecies-decryptor-private-key decryptor) eph-pub)] - [aes-key (hkdf-sha256 shared-secret eph-pub - (string->utf8 "secmon-ecies-v1") 32)] - [nonce (encrypted-payload-nonce payload)] - [ciphertext (encrypted-payload-ciphertext payload)]) - (rust-aead-open aes-key nonce ciphertext #vu8()))) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/crypto/keys.sls +++ /dev/null @@ -1,33 +0,0 @@ -(library (secmon crypto keys) - (export - generate-keypair - generate-psk - hex->key key->hex) - (import - (chezscheme) - (std crypto native-rust) - (std text hex)) - - (define c-x25519-keypair - (foreign-procedure "jerboa_x25519_generate_keypair" (u8* u8*) int)) - - (define (generate-keypair) - ;; Returns (values private-key-bv public-key-bv) - (let ([priv-key (make-bytevector 32)] - [pub-key (make-bytevector 32)]) - (let ([rc (c-x25519-keypair priv-key pub-key)]) - (when (< rc 0) - (error 'generate-keypair "key generation failed" (rust-last-error))) - (values priv-key pub-key)))) - - (define (generate-psk) - ;; Returns 32-byte random PSK - (rust-random-bytes 32)) - - (define (hex->key hex-str) - (hex-string->u8vector hex-str)) - - (define (key->hex key-bv) - (u8vector->hex-string key-bv)) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/crypto/psk.sls +++ /dev/null @@ -1,248 +0,0 @@ -(library (secmon crypto psk) - (export - make-psk-auth psk-auth? - psk-auth-auth-key psk-auth-transport-key - psk-create-challenge psk-verify-response psk-respond-to-challenge - psk-encrypt-transport psk-decrypt-transport - psk-challenge? psk-challenge-nonce psk-challenge-timestamp - psk-response? psk-response-proof psk-response-counter-nonce - psk-challenge->bytevector bytevector->psk-challenge - psk-response->bytevector bytevector->psk-response - psk-derive-transport-direction-key psk-derive-channel-id - make-psk-transport-session psk-transport-session? - make-server-transport-session make-client-transport-session - psk-session-seal psk-session-open - psk-session-send-seq psk-session-recv-top) - (import - (chezscheme) - (jerboa prelude clean) - (std crypto native-rust) - (std text hex)) - - ;; --- FFI --- - - (define c-hkdf-sha256 - (foreign-procedure "jerboa_hkdf_sha256" - (u8* size_t u8* size_t u8* size_t u8* size_t) int)) - - (define (hkdf-sha256 ikm salt info output-len) - (let ([output (make-bytevector output-len)]) - (let ([rc (c-hkdf-sha256 - ikm (bytevector-length ikm) - (if salt salt (make-bytevector 0)) (if salt (bytevector-length salt) 0) - info (bytevector-length info) - output output-len)]) - (when (< rc 0) - (error 'hkdf-sha256 "HKDF failed" (rust-last-error))) - output))) - - ;; --- Data types --- - - (define-record-type psk-challenge - (fields nonce timestamp) ; nonce=32B bytevector, timestamp=i64 ms - (nongenerative psk-challenge-type)) - - (define-record-type psk-response - (fields proof counter-nonce) ; proof=32B, counter-nonce=32B - (nongenerative psk-response-type)) - - ;; --- PSK Auth --- - - (define-record-type psk-auth - (fields psk auth-key transport-key) - (nongenerative psk-auth-type) - (protocol - (lambda (new) - (lambda (psk-bytes) - (let ([auth-key (hkdf-sha256 psk-bytes #f - (string->utf8 "secmon-psk-auth-v1") 32)] - [transport-key (hkdf-sha256 psk-bytes #f - (string->utf8 "secmon-psk-transport-v1") 32)]) - (new psk-bytes auth-key transport-key)))))) - - ;; --- Challenge/Response Protocol --- - - (define (current-unix-timestamp) - (let ([t (current-time)]) - (+ (time-second t) - (quotient (time-nanosecond t) 1000000000)))) - - (define (psk-create-challenge auth) - (let ([nonce (rust-random-bytes 32)] - [ts (current-unix-timestamp)]) - (make-psk-challenge nonce ts))) - - (define (compute-proof auth-key nonce timestamp) - ;; SHA256(auth_key || nonce || timestamp_le_bytes || "secmon-challenge-proof") - (let* ([ts-bytes (make-bytevector 8)] - [_ (bytevector-s64-set! ts-bytes 0 timestamp (endianness little))] - [tag (string->utf8 "secmon-challenge-proof")] - [msg-len (+ 32 (bytevector-length nonce) 8 (bytevector-length tag))] - [msg (make-bytevector msg-len)]) - (bytevector-copy! auth-key 0 msg 0 32) - (bytevector-copy! nonce 0 msg 32 (bytevector-length nonce)) - (bytevector-copy! ts-bytes 0 msg (+ 32 (bytevector-length nonce)) 8) - (bytevector-copy! tag 0 msg (+ 32 (bytevector-length nonce) 8) - (bytevector-length tag)) - (rust-sha256 msg))) - - (define (psk-respond-to-challenge auth challenge) - (let ([proof (compute-proof (psk-auth-auth-key auth) - (psk-challenge-nonce challenge) - (psk-challenge-timestamp challenge))] - [counter-nonce (rust-random-bytes 32)]) - (make-psk-response proof counter-nonce))) - - (define (psk-verify-response auth challenge response max-age-secs) - (let* ([now (current-unix-timestamp)] - [age (abs (- now (psk-challenge-timestamp challenge)))]) - (and (<= age max-age-secs) - (let ([expected (compute-proof (psk-auth-auth-key auth) - (psk-challenge-nonce challenge) - (psk-challenge-timestamp challenge))]) - (rust-timing-safe-equal? expected (psk-response-proof response)))))) - - ;; --- Transport Encryption --- - - (define (psk-encrypt-transport auth plaintext) - (let* ([nonce (rust-random-bytes 12)] - [ct (rust-aead-seal (psk-auth-transport-key auth) nonce plaintext #vu8())] - [out (make-bytevector (+ 12 (bytevector-length ct)))]) - (bytevector-copy! nonce 0 out 0 12) - (bytevector-copy! ct 0 out 12 (bytevector-length ct)) - out)) - - (define (psk-decrypt-transport auth data) - (when (< (bytevector-length data) 12) - (error 'psk-decrypt-transport "data too short")) - (let ([nonce (make-bytevector 12)] - [ct-len (- (bytevector-length data) 12)]) - (bytevector-copy! data 0 nonce 0 12) - (let ([ct (make-bytevector ct-len)]) - (bytevector-copy! data 12 ct 0 ct-len) - (rust-aead-open (psk-auth-transport-key auth) nonce ct #vu8())))) - - ;; --- Replay-protected transport session --- - ;; - ;; The post-auth request loop must not accept a captured frame twice. Each - ;; direction gets its own HKDF-derived key (domain separation, so a frame - ;; sealed for one direction cannot decrypt as the other — reflection is - ;; rejected) and a monotonic sequence number bound into the AEAD AAD as - ;; direction ‖ channel-id ‖ seq. The receiver keeps a high-water mark and - ;; rejects any seq it has already advanced past, so a replayed or stale frame - ;; fails before it can purge buffered evidence. The channel-id binds every - ;; frame to the handshake that established the session, defeating - ;; cross-context splicing. - - (define (psk-derive-transport-direction-key psk info) - (hkdf-sha256 psk #f (string->utf8 info) 32)) - - (define (psk-derive-channel-id challenge-nonce) - (rust-sha256 challenge-nonce)) - - (define-record-type psk-transport-session - (fields - (immutable send-key psk-session-send-key) - (immutable recv-key psk-session-recv-key) - (immutable send-dir psk-session-send-dir) - (immutable recv-dir psk-session-recv-dir) - (immutable channel-id psk-session-channel-id) - (mutable send-seq psk-session-send-seq psk-session-send-seq-set!) - (mutable recv-top psk-session-recv-top psk-session-recv-top-set!)) - (nongenerative psk-transport-session-type) - (protocol - (lambda (new) - (lambda (send-key recv-key send-dir recv-dir channel-id) - (new send-key recv-key send-dir recv-dir channel-id 1 0))))) - - (define (psk-transport-aad dir-byte channel-id seq) - (let* ([cid-len (bytevector-length channel-id)] - [aad (make-bytevector (+ 1 cid-len 8))]) - (bytevector-u8-set! aad 0 dir-byte) - (bytevector-copy! channel-id 0 aad 1 cid-len) - (bytevector-u64-set! aad (+ 1 cid-len) seq (endianness little)) - aad)) - - ;; Frame layout: seq(8 LE) ‖ nonce(12) ‖ ciphertext‖tag. The seq rides in the - ;; clear so the receiver can rebuild the AAD before opening, and is itself - ;; authenticated by the tag. - (define (psk-session-seal session plaintext) - (let* ([seq (psk-session-send-seq session)] - [_ (psk-session-send-seq-set! session (+ seq 1))] - [nonce (rust-random-bytes 12)] - [aad (psk-transport-aad (psk-session-send-dir session) - (psk-session-channel-id session) seq)] - [ct (rust-aead-seal (psk-session-send-key session) nonce plaintext aad)] - [out (make-bytevector (+ 20 (bytevector-length ct)))]) - (bytevector-u64-set! out 0 seq (endianness little)) - (bytevector-copy! nonce 0 out 8 12) - (bytevector-copy! ct 0 out 20 (bytevector-length ct)) - out)) - - ;; Open a frame, rejecting anything stale or replayed. Returns the plaintext - ;; bytevector, or #f on a short frame, a non-fresh seq, or a failed tag - ;; (wrong direction key, wrong channel-id, or tampering). The high-water mark - ;; advances only after a successful open, so a forged seq cannot poison it. - (define (psk-session-open session frame) - (let ([n (bytevector-length frame)]) - (and (>= n 36) ;; seq(8) + nonce(12) + GCM tag(16) - (let* ([seq (bytevector-u64-ref frame 0 (endianness little))] - [top (psk-session-recv-top session)]) - (and (> seq top) ;; fresh, strictly monotonic: rejects stale + replay - (let* ([nonce (make-bytevector 12)] - [_ (bytevector-copy! frame 8 nonce 0 12)] - [ct-len (- n 20)] - [ct (make-bytevector ct-len)] - [_ (bytevector-copy! frame 20 ct 0 ct-len)] - [aad (psk-transport-aad (psk-session-recv-dir session) - (psk-session-channel-id session) seq)] - ;; rust-aead-open raises on a bad tag; a reflected, spliced, - ;; or tampered frame must surface as #f, not an exception. - [pt (guard (e [#t #f]) - (rust-aead-open (psk-session-recv-key session) nonce ct aad))]) - (and pt - (begin (psk-session-recv-top-set! session seq) pt)))))))) - - ;; Direction byte 0 = client→server, 1 = server→client. The server sends on - ;; s2c and receives on c2s; the client is the mirror. - (define (make-server-transport-session auth channel-id) - (let ([psk (psk-auth-psk auth)]) - (make-psk-transport-session - (psk-derive-transport-direction-key psk "secmon-psk-transport-v2:s2c") - (psk-derive-transport-direction-key psk "secmon-psk-transport-v2:c2s") - 1 0 channel-id))) - - (define (make-client-transport-session auth channel-id) - (let ([psk (psk-auth-psk auth)]) - (make-psk-transport-session - (psk-derive-transport-direction-key psk "secmon-psk-transport-v2:c2s") - (psk-derive-transport-direction-key psk "secmon-psk-transport-v2:s2c") - 0 1 channel-id))) - - ;; --- Serialization --- - - (define (psk-challenge->bytevector c) - (let ([out (make-bytevector 40)]) - (bytevector-copy! (psk-challenge-nonce c) 0 out 0 32) - (bytevector-s64-set! out 32 (psk-challenge-timestamp c) (endianness little)) - out)) - - (define (bytevector->psk-challenge bv) - (let ([nonce (make-bytevector 32)]) - (bytevector-copy! bv 0 nonce 0 32) - (make-psk-challenge nonce (bytevector-s64-ref bv 32 (endianness little))))) - - (define (psk-response->bytevector r) - (let ([out (make-bytevector 64)]) - (bytevector-copy! (psk-response-proof r) 0 out 0 32) - (bytevector-copy! (psk-response-counter-nonce r) 0 out 32 32) - out)) - - (define (bytevector->psk-response bv) - (let ([proof (make-bytevector 32)] - [counter (make-bytevector 32)]) - (bytevector-copy! bv 0 proof 0 32) - (bytevector-copy! bv 32 counter 0 32) - (make-psk-response proof counter))) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/monitor/auth.sls +++ /dev/null @@ -1,246 +0,0 @@ -(library (secmon monitor auth) - (export spawn-auth-monitor) - (import - (chezscheme) - (jerboa prelude clean) - (secmon monitor events) - (std os file-info)) - - ;; Auth monitor: detects SSH logins, sudo, su, user changes - (define (spawn-auth-monitor emit! poll-ms hostname) - (fork-thread - (lambda () - (let ([log-path (find-auth-log)] - [log-pos (box 0)] - [logged-in-users (make-hashtable string-hash string=?)]) - ;; Initialize position to end of file - (when log-path - (guard (e [#t (void)]) - (let ([size (file-size-safe log-path)]) - (set-box! log-pos (or size 0))))) - ;; Poll loop - (let loop () - (guard (e [#t (void)]) - ;; Tail-follow auth log - (when log-path - (tail-auth-log! log-path log-pos emit! hostname)) - ;; Check utmp for login changes - (check-utmp-changes! logged-in-users emit! hostname)) - (sleep (make-time 'time-duration (* (mod poll-ms 1000) 1000000) (quotient poll-ms 1000))) - (loop)))))) - - (define (find-auth-log) - (cond - [(file-exists? "/var/log/auth.log") "/var/log/auth.log"] - [(file-exists? "/var/log/secure") "/var/log/secure"] - [(file-exists? "/var/log/messages") "/var/log/messages"] ;; FreeBSD fallback - [else #f])) - - (define (file-size-safe path) - (guard (e [#t #f]) - (let ([info (get-file-info path)]) - (file-info-size info)))) - - (define (tail-auth-log! path pos-box emit! hostname) - (guard (e [#t (void)]) - (let ([size (file-size-safe path)]) - (when size - ;; Detect log rotation (size decreased) - (when (< size (unbox pos-box)) - (set-box! pos-box 0)) - (when (> size (unbox pos-box)) - (let ([p (open-file-input-port path)]) - (set-port-position! p (unbox pos-box)) - (let ([tp (open-utf8-input-port p)]) - (let line-loop () - (let ([line (get-line tp)]) - (unless (eof-object? line) - (parse-auth-line! line emit! hostname) - (line-loop))))) - (set-box! pos-box (port-position p)) - (close-port p))))))) - - (define (open-utf8-input-port binary-port) - (transcoded-port binary-port (make-transcoder (utf-8-codec)))) - - (define (parse-auth-line! line emit! hostname) - (cond - ;; SSH accepted - [(string-contains line "Accepted ") - (let ([username (extract-field line "for " " from")] - [remote (extract-field line "from " " port")] - [method (extract-field line "Accepted " " for")]) - (emit! (make-auth-event hostname "ssh_login" "success" 'info - username remote (or method ""))))] - ;; SSH failed - [(string-contains line "Failed password") - (let ([username (extract-field line "for " " from")] - [remote (extract-field line "from " " port")]) - (emit! (make-auth-event hostname "ssh_login" "failed" 'medium - username remote "password")))] - ;; Invalid user - [(string-contains line "Invalid user") - (let ([username (extract-field line "Invalid user " " from")] - [remote (extract-field line "from " " port")]) - (emit! (make-auth-event hostname "ssh_login" "failed" 'medium - username remote "invalid_user")))] - ;; sudo - [(string-contains line "sudo:") - (cond - [(string-contains line "authentication failure") - (let ([user (extract-field line "user=" ";")]) - (emit! (make-auth-event hostname "sudo" "failed" 'medium - user "" "")))] - [(string-contains line "COMMAND=") - (let ([user (extract-field line "sudo:" " :")] - [cmd (extract-after line "COMMAND=")]) - (emit! (make-auth-event hostname "sudo" "success" 'info - (or user "") "" (or cmd ""))))])] - ;; su - [(string-contains line "su:") - (cond - [(string-contains line "Successful su") - (let ([user (extract-field line "for " " by")]) - (emit! (make-auth-event hostname "su" "success" 'info - (or user "") "" "")))] - [(string-contains line "FAILED su") - (let ([user (extract-field line "for " " by")]) - (emit! (make-auth-event hostname "su" "failed" 'medium - (or user "") "" "")))])] - ;; User creation/deletion - [(string-contains line "useradd") - (let ([user (extract-field line "name=" ",")]) - (emit! (make-auth-event hostname "user_created" "success" 'high - (or user "") "" "")))] - [(string-contains line "userdel") - (let ([user (extract-field line "name=" ",")]) - (emit! (make-auth-event hostname "user_deleted" "success" 'high - (or user "") "" "")))] - ;; Password change - [(string-contains line "passwd") - (when (string-contains line "password changed") - (let ([user (extract-field line "for " "")]) - (emit! (make-auth-event hostname "password_change" "success" 'medium - (or user "") "" ""))))])) - - ;; Extract text between two markers - (define (extract-field line start-marker end-marker) - (let ([start-pos (string-contains line start-marker)]) - (if (not start-pos) #f - (let* ([after (+ start-pos (string-length start-marker))] - [rest (substring line after (string-length line))]) - (if (string=? end-marker "") - (string-trim rest) - (let ([end-pos (string-contains rest end-marker)]) - (if end-pos - (substring rest 0 end-pos) - (string-trim rest)))))))) - - (define (extract-after line marker) - (let ([pos (string-contains line marker)]) - (if (not pos) #f - (substring line (+ pos (string-length marker)) - (string-length line))))) - - ;; Check /var/run/utmp for logged-in user changes - (define (check-utmp-changes! known-users emit! hostname) - (guard (e [#t (void)]) - (let ([current-users (read-utmp-users)] - [current-set (make-hashtable string-hash string=?)]) - ;; New logins - (for-each - (lambda (user) - (hashtable-set! current-set user #t) - (unless (hashtable-ref known-users user #f) - (emit! (make-auth-event hostname "session_start" "success" 'info - user "" "")))) - current-users) - ;; Logouts - (vector-for-each - (lambda (user) - (unless (hashtable-ref current-set user #f) - (emit! (make-auth-event hostname "session_end" "success" 'info - user "" "")))) - (hashtable-keys known-users)) - ;; Update known - (let ([keys (hashtable-keys known-users)]) - (vector-for-each (lambda (k) (hashtable-delete! known-users k)) keys)) - (for-each (lambda (u) (hashtable-set! known-users u #t)) current-users)))) - - ;; Read logged-in users. Uses `who` command on FreeBSD (different utmp format), - ;; binary utmp parsing on Linux. - (define on-freebsd? - (string-contains (symbol->string (machine-type)) "fb")) - - (define (read-utmp-users) - (if on-freebsd? - (read-utmp-users-who) - (read-utmp-users-linux))) - - ;; Cross-platform: parse `who` output - (define (read-utmp-users-who) - (guard (e [#t '()]) - (let ([output (shell-output "who 2>/dev/null")]) - (filter-map - (lambda (line) - (let ([parts (filter (lambda (s) (not (string=? s ""))) - (string-split (string-trim line) #\space))]) - (and (not (null? parts)) (car parts)))) - (filter (lambda (s) (not (string=? s ""))) - (string-split output #\newline)))))) - - (define (shell-output cmd) - (guard (e [#t ""]) - (let-values ([(to-stdin from-stdout from-stderr pid) - (open-process-ports cmd 'line (current-transcoder))]) - (close-port to-stdin) - (let ([output (get-string-all from-stdout)]) - (close-port from-stdout) - (close-port from-stderr) - output)))) - - ;; Linux: binary utmp parsing (384-byte records, ut_type=7 means USER_PROCESS) - (define (read-utmp-users-linux) - (guard (e [#t '()]) - (let ([path (if (file-exists? "/var/run/utmp") "/var/run/utmp" "/run/utmp")]) - (if (not (file-exists? path)) '() - (let ([bv (let ([p (open-file-input-port path)]) - (let ([data (get-bytevector-all p)]) - (close-port p) data))]) - (if (eof-object? bv) '() - (let ([record-size 384] - [users '()]) - (let loop ([offset 0]) - (if (> (+ offset record-size) (bytevector-length bv)) - users - (let ([ut-type (bytevector-s32-ref bv offset (endianness little))]) - (if (= ut-type 7) ;; USER_PROCESS - (let ([user (extract-utmp-string bv (+ offset 8) 32)]) - (cons user (loop (+ offset record-size)))) - (loop (+ offset record-size))))))))))))) - - (define (extract-utmp-string bv offset max-len) - (let loop ([i 0] [acc '()]) - (if (or (= i max-len) (>= (+ offset i) (bytevector-length bv))) - (list->string (reverse acc)) - (let ([b (bytevector-u8-ref bv (+ offset i))]) - (if (= b 0) - (list->string (reverse acc)) - (loop (+ i 1) (cons (integer->char b) acc))))))) - - (define (make-auth-event hostname auth-type status severity username remote-host method) - (let ([data (make-hashtable string-hash string=?)]) - (hashtable-set! data "auth_type" auth-type) - (hashtable-set! data "status" status) - (hashtable-set! data "username" username) - (hashtable-set! data "remote_host" remote-host) - (hashtable-set! data "method" method) - (make-security-event (next-event-id!) (current-time-ms) hostname - 'auth_event severity data))) - - (define (current-time-ms) - (let ([t (current-time)]) - (+ (* (time-second t) 1000) - (quotient (time-nanosecond t) 1000000)))) - -) ;; end library deleted file mode 100644 --- a/lib/secmon/monitor/container.sls +++ /dev/null @@ -1,196 +0,0 @@ -(library (secmon monitor container) - (export spawn-container-escape-monitor) - (import - (chezscheme) - (jerboa prelude clean) - (secmon monitor events) - (secmon monitor suspicious) - (secmon stealth obfuscate)) - - (define on-freebsd? - (string-contains (symbol->string (machine-type)) "fb")) - - ;; Container escape monitor: detects escape attempts from containers/jails - (define (spawn-container-escape-monitor emit! poll-ms hostname) - (fork-thread - (lambda () - (when (is-containerized?) - (let ([known-mounts (make-hashtable string-hash string=?)] - [reported-privileged #f] - [reported-caps (make-hashtable string-hash string=?)]) - ;; Baseline mounts - (for-each - (lambda (m) (hashtable-set! known-mounts m #t)) - (read-mounts)) - ;; Poll loop - (let loop () - (guard (e [#t (void)]) - ;; Check new mounts - (for-each - (lambda (mount) - (unless (hashtable-ref known-mounts mount #f) - (hashtable-set! known-mounts mount #t) - (when (suspicious-mount? mount) - (emit! (make-escape-event hostname "suspicious_mount" - mount 'high))))) - (read-mounts)) - ;; Check for docker/containerd socket - (for-each - (lambda (path) - (when (file-exists? path) - (emit! (make-escape-event hostname "container_socket_access" - path 'critical)))) - (list (obfstr "/var/run/docker.sock") - (obfstr "/run/docker.sock") - (obfstr "/var/run/containerd/containerd.sock"))) - ;; Check capabilities / jail restrictions - (if on-freebsd? - ;; FreeBSD: check jail security restrictions via sysctl - (check-jail-restrictions emit! hostname reported-caps) - ;; Linux: check Linux capabilities - (let ([caps (read-effective-caps)]) - (when caps - ;; Full caps = privileged container - (when (and (not reported-privileged) - (or (= caps #x3fffffffff) - (= caps #xffffffffffffffff))) - (set! reported-privileged #t) - (emit! (make-escape-event hostname "privileged_container" - "" 'critical))) - ;; Check individual dangerous caps - (for-each - (lambda (cap-pair) - (let ([bit (car cap-pair)] [name (cdr cap-pair)]) - (when (and (not (zero? (bitwise-and caps - (bitwise-arithmetic-shift-left 1 bit)))) - (not (hashtable-ref reported-caps name #f))) - (hashtable-set! reported-caps name #t) - (emit! (make-escape-event hostname "dangerous_capability" - name 'high))))) - dangerous-capabilities))))) - (sleep (make-time 'time-duration (* (mod poll-ms 1000) 1000000) (quotient poll-ms 1000))) - (loop))))))) - - (define (is-containerized?) - (if on-freebsd? - ;; FreeBSD: check if running inside a jail - (guard (e [#t #f]) - (let ([output (shell-output "sysctl -n security.jail.jailed 2>/dev/null")]) - (string=? (string-trim output) "1"))) - ;; Linux: check for container indicators - (or (file-exists? (obfstr "/.dockerenv")) - (file-exists? (obfstr "/run/.containerenv")) - (guard (e [#t #f]) - (let ([cgroup (read-file-safe (obfstr "/proc/1/cgroup"))]) - (and cgroup - (or (string-contains cgroup (obfstr "docker")) - (string-contains cgroup (obfstr "lxc")) - (string-contains cgroup (obfstr "kubepods"))))))))) - - (define (read-mounts) - (guard (e [#t '()]) - (if on-freebsd? - ;; FreeBSD: parse mount command output - (let ([lines (shell-output-lines "/sbin/mount 2>/dev/null")]) - (filter-map - (lambda (line) - ;; Format: /dev/ada0p2 on / (ufs, local, ...) - (let ([on-pos (string-contains line " on ")]) - (and on-pos - (let ([rest (substring line (+ on-pos 4) (string-length line))]) - (let ([space (string-contains rest " (")]) - (if space (substring rest 0 space) - (string-trim rest))))))) - lines)) - ;; Linux: parse /proc/mounts - (let ([lines (local-read-file-lines (obfstr "/proc/mounts"))]) - (filter-map - (lambda (line) - (let ([parts (string-split line #\space)]) - (and (>= (length parts) 2) (cadr parts)))) - lines))))) - - (define (suspicious-mount? mount) - (or (string-prefix? (obfstr "/host") mount) - (string-prefix? (obfstr "/mnt/host") mount) - (string-contains mount (obfstr "docker.sock")) - (string-contains mount (obfstr "containerd.sock")))) - - ;; FreeBSD jail restriction checks via sysctl security.jail.* - ;; Jails that have relaxed restrictions are dangerous — equivalent to - ;; Linux's dangerous capabilities. - (define jail-restriction-checks - ;; (sysctl-name . description) — value "1" means ALLOWED (dangerous) - '(("security.jail.allow_raw_sockets" . "raw_sockets") - ("security.jail.mount_allowed" . "mount_allowed") - ("security.jail.chflags_allowed" . "chflags_allowed") - ("security.jail.sysvipc_allowed" . "sysvipc_allowed"))) - - (define (check-jail-restrictions emit! hostname reported-caps) - (guard (e [#t (void)]) - (for-each - (lambda (check) - (let ([sysctl-name (car check)] - [cap-name (cdr check)]) - (guard (e [#t (void)]) - (let ([output (shell-output - (format "/sbin/sysctl -n ~a 2>/dev/null" sysctl-name))]) - (when (string=? (string-trim output) "1")