Add memhole feature parity: access control, secure memory, lock/unlock
ober
4594391e9b9cb3a0bdac15699f517433fe3d3ea7
--- a/lib/chez/fuse.sls +++ b/lib/chez/fuse.sls @@ -45,14 +45,19 @@ EPERM EBADF ENOMEM ENOSPC EROFS ENAMETOOLONG ENODATA EOPNOTSUPP ENOTSUP FATTR-MODE FATTR-UID FATTR-GID FATTR-SIZE FATTR-ATIME FATTR-MTIME FATTR-ATIME-NOW FATTR-MTIME-NOW FATTR-CTIME - FOPEN-DIRECT-IO FOPEN-KEEP-CACHE FOPEN-NONSEEKABLE) + FOPEN-DIRECT-IO FOPEN-KEEP-CACHE FOPEN-NONSEEKABLE + + ;; Re-exports: Access control + make-access-controller access-check + access-controller-lock! access-controller-unlock! access-controller-locked?) (import (chezscheme) (chez fuse constants) (chez fuse types) (chez fuse codec) - (chez fuse mount)) + (chez fuse mount) + (chez fuse access)) ;; ====================================================================== ;; FFI: low-level read/write on the /dev/fuse fd @@ -198,6 +203,7 @@ [allow-other? (get-option options 'allow-other #t)] [fd (fuse-open-device)] [mtx (make-mutex)] + [ac (get-option options 'access-controller #f)] [session (make-fuse-session fd mountpoint #f #f FUSE-KERNEL-VERSION FUSE-KERNEL-MINOR-VERSION @@ -205,7 +211,8 @@ ops mtx ;; dispatch mutex #f ;; thread handle - (make-condition))] ;; done condition + (make-condition) ;; done condition + ac)] ;; access controller [uid (getuid)] [gid (getgid)]) (fuse-mount! fd mountpoint fsname uid gid allow-other?) @@ -259,6 +266,37 @@ ;; Request handler — dispatches a single request ;; ====================================================================== + ;; Opcodes that are always allowed (protocol handshake, no data exposure) + (define (always-allowed-opcode? op) + (or (= op FUSE-INIT) (= op FUSE-DESTROY) + (= op FUSE-INTERRUPT) (= op FUSE-STATFS))) + + ;; Stealth deny: denied processes see an empty directory, not errors. + ;; GETATTR on root → valid empty dir attr. Everything else → ENOENT. + (define (stealth-deny-response opcode unique nodeid) + (cond + ;; GETATTR on root → return stealth attr so mount point looks normal + [(and (= opcode FUSE-GETATTR) (= nodeid FUSE-ROOT-ID)) + (encode-attr-out unique 1 0 (stealth-deny-attr))] + ;; READDIR on root → return empty dir (. and .. only) + [(and (= opcode FUSE-READDIR) (= nodeid FUSE-ROOT-ID)) + (encode-dirents unique (stealth-deny-readdir FUSE-ROOT-ID) 4096)] + ;; ACCESS on root → allow (mount point must be accessible) + [(and (= opcode FUSE-ACCESS) (= nodeid FUSE-ROOT-ID)) + (encode-out-header unique 0 0)] + ;; OPENDIR on root → allow (so readdir works) + [(and (= opcode FUSE-OPENDIR) (= nodeid FUSE-ROOT-ID)) + (encode-open-out unique 0 0)] + ;; RELEASEDIR → always OK + [(= opcode FUSE-RELEASEDIR) + (encode-out-header unique 0 0)] + ;; FORGET → no response needed + [(or (= opcode FUSE-FORGET) (= opcode FUSE-BATCH-FORGET)) #f] + ;; LOOKUP → ENOENT (nothing in the directory) + [(= opcode FUSE-LOOKUP) (encode-error unique ENOENT)] + ;; Everything else → ENOENT + [else (encode-error unique ENOENT)])) + (define (handle-request session buf n debug?) (let* ([hdr (decode-in-header buf)] [opcode (fuse-request-opcode hdr)] @@ -271,22 +309,34 @@ [ops (fuse-session-ops session)] [fd (fuse-session-fd session)] [mtx (fuse-session-mutex session)] + [ac (fuse-session-access session)] [payload-off FUSE-IN-HEADER-SIZE]) (when debug? (printf "chez-fuse: op=~a unique=~a node=~a pid=~a\n" (opcode->name opcode) unique nodeid pid)) + ;; Access gate: check if caller PID is trusted (let ([response - (guard (exn - [else - (when debug? - (printf "chez-fuse: handler error op=~a: ~a\n" - opcode (exn-message exn))) - (encode-error unique EIO)]) - (with-mutex mtx - (dispatch-opcode - session ops opcode unique nodeid ctx buf payload-off n)))]) + (if (and ac + (not (always-allowed-opcode? opcode)) + (not (access-check ac pid))) + ;; Denied — stealth response + (begin + (when debug? + (printf "chez-fuse: DENIED pid=~a op=~a (stealth)\n" + pid (opcode->name opcode))) + (stealth-deny-response opcode unique nodeid)) + ;; Allowed — normal dispatch + (guard (exn + [else + (when debug? + (printf "chez-fuse: handler error op=~a: ~a\n" + opcode (exn-message exn))) + (encode-error unique EIO)]) + (with-mutex mtx + (dispatch-opcode + session ops opcode unique nodeid ctx buf payload-off n))))]) (when (and response (>= fd 0)) (fuse-write fd response))))) new file mode 100644 --- /dev/null +++ b/lib/chez/fuse/access.sls @@ -0,0 +1,138 @@ +(library (chez fuse access) + (export + ;; Access controller + make-access-controller ;; → controller (trusts current PID and descendants) + access-check ;; controller pid → #t (trusted) or #f (denied) + access-controller-lock! ;; controller → void (deny all, clear cache) + access-controller-unlock! ;; controller → void (re-enable normal checks) + access-controller-locked? ;; controller → boolean + + ;; Stealth deny helpers (for FUSE dispatch) + stealth-deny-attr ;; → fuse-attr (empty root-like) + stealth-deny-readdir ;; → list of dirents (just . and ..) + + ;; Process tree inspection + pid-is-descendant?) ;; pid ancestor-pid → boolean + + (import + (rnrs) + (only (chezscheme) + foreign-procedure make-time time-second current-time + make-eq-hashtable eq-hashtable-ref eq-hashtable-set! + eq-hashtable-delete! make-mutex with-mutex) + (chez fuse constants) + (chez fuse types) + (chez fuse mount)) ;; ensure shared lib loaded + + ;; ---- FFI: process tree ---- + + (define _lib-loaded (begin (ensure-mount-lib!) #t)) + + (define c-getpid + (foreign-procedure "chez_fuse_getpid" () int)) + (define c-getppid-of + (foreign-procedure "chez_fuse_getppid_of" (int) int)) + + ;; ---- Process tree walking ---- + + ;; Walk the parent chain of pid up to init (PID 1). + ;; Returns #t if ancestor-pid is found in the chain. + ;; Max depth prevents runaway loops from PID reuse races. + (define (pid-is-descendant? pid ancestor-pid) + (let loop ([current pid] [depth 0]) + (cond + [(= current ancestor-pid) #t] + [(<= current 1) #f] ;; reached init or invalid + [(> depth 64) #f] ;; safety limit + [else + (let ([ppid (c-getppid-of current)]) + (if (< ppid 0) #f ;; process gone or error + (loop ppid (+ depth 1))))]))) + + ;; ---- Access controller ---- + + ;; Cache entry: (pid . expiry-time) + ;; Trusted PIDs are cached for a short TTL to avoid repeated sysctl calls. + ;; Denied PIDs are NOT cached (process might become a child later, though + ;; unlikely — and we want to re-check in case of PID reuse). + (define CACHE-TTL 5) ;; seconds + + (define-record-type access-controller-state + (fields + (immutable owner-pid) ;; PID of jsh (the trusted root process) + (mutable locked?) ;; #t → deny all (vault locked) + (mutable cache) ;; eq-hashtable: pid → expiry-time + (mutable mutex))) + + (define (make-access-controller) + (make-access-controller-state + (c-getpid) #f (make-eq-hashtable) (make-mutex))) + + (define (access-controller-locked? ac) + (access-controller-state-locked? ac)) + + (define (access-controller-lock! ac) + (with-mutex (access-controller-state-mutex ac) + (access-controller-state-locked?-set! ac #t) + ;; Clear the trust cache + (access-controller-state-cache-set! ac (make-eq-hashtable)))) + + (define (access-controller-unlock! ac) + (with-mutex (access-controller-state-mutex ac) + (access-controller-state-locked?-set! ac #f))) + + ;; Check if a PID is trusted (is jsh or a descendant of jsh). + ;; Returns #t for trusted, #f for denied. + (define (access-check ac pid) + (with-mutex (access-controller-state-mutex ac) + (cond + ;; Locked → deny all + [(access-controller-state-locked? ac) #f] + ;; Owner PID → always trusted + [(= pid (access-controller-state-owner-pid ac)) #t] + ;; Check cache + [else + (let* ([cache (access-controller-state-cache ac)] + [now (time-second (current-time))] + [expiry (eq-hashtable-ref cache pid #f)]) + (cond + ;; Cache hit, not expired + [(and expiry (> expiry now)) #t] + ;; Cache miss or expired — do the walk + [else + (let ([trusted? (pid-is-descendant? + pid + (access-controller-state-owner-pid ac))]) + (when trusted? + ;; Cache positive result + (eq-hashtable-set! cache pid (+ now CACHE-TTL))) + trusted?)]))]))) + + ;; ---- Stealth deny responses ---- + ;; These create responses that make the vault look like an empty directory + ;; to unauthorized processes. No error codes — just... nothing there. + + (define (stealth-deny-attr) + ;; Return a minimal directory attr for the root node. + ;; This makes the mountpoint itself appear to exist (it must, since it's + ;; a mount point) but contain nothing. + (let ([now (time-second (current-time))]) + (make-fuse-attr + FUSE-ROOT-ID ;; ino + 0 ;; size + 0 ;; blocks + now now now ;; atime mtime ctime + 0 0 0 ;; nanoseconds + (bitwise-ior S-IFDIR #o755) ;; mode + 2 ;; nlink + 0 0 ;; uid gid + 0 ;; rdev + 4096))) ;; blksize + + (define (stealth-deny-readdir ino) + ;; Return just . and .. — an empty directory. + (list + (make-fuse-dirent ino 1 DT-DIR ".") + (make-fuse-dirent ino 2 DT-DIR ".."))) + +) ;; end library --- a/lib/chez/fuse/mount.sls +++ b/lib/chez/fuse/mount.sls @@ -7,7 +7,10 @@ fuse-get-errno fuse-close-device fuse-block-signal - fuse-unblock-signal) + fuse-unblock-signal + + ;; Ensure the shared library is loaded (used by secmem, access) + ensure-mount-lib!) (import (rnrs) @@ -30,6 +33,10 @@ (load-shared-object "./libchez_fuse_mount.so")) (set! loaded #t))))) + ;; Public: ensure the shared lib is loaded (called by secmem, access modules) + (define (ensure-mount-lib!) + (mount-lib-loaded?)) + ;; FFI bindings (define c-open-device #f) (define c-mount #f) new file mode 100644 --- /dev/null +++ b/lib/chez/fuse/secmem.sls @@ -0,0 +1,106 @@ +(library (chez fuse secmem) + (export + ;; Low-level secure memory (mlock'd, dump-excluded, volatile-zeroed) + secmem-alloc ;; size → foreign-pointer or #f + secmem-free! ;; ptr size → void + secmem-zero! ;; ptr size → void + + ;; Secure key holder — wraps a fixed-size key in mlock'd memory + make-secure-key ;; bytevector → secure-key (copies bv, then zeros bv) + secure-key? + secure-key-borrow ;; secure-key → bytevector (CALLER MUST ZERO AFTER USE) + secure-key-destroy! ;; secure-key → void (zeros and frees) + secure-key-size ;; secure-key → integer + secure-key-live? ;; secure-key → boolean (not yet destroyed?) + + ;; Convenience: run a thunk with the key as a temporary bytevector + call-with-secure-key) ;; secure-key (lambda (bv) ...) → result + + (import + (rnrs) + (only (chezscheme) + foreign-procedure load-shared-object + machine-type void) + (chez fuse mount)) ;; ensure shared lib is loaded + + ;; Ensure the shared library is loaded before defining FFI bindings. + (define _lib-loaded (begin (ensure-mount-lib!) #t)) + + (define c-secmem-alloc + (foreign-procedure "chez_fuse_secmem_alloc" (size_t) uptr)) + (define c-secmem-free + (foreign-procedure "chez_fuse_secmem_free" (uptr size_t) void)) + (define c-secmem-zero + (foreign-procedure "chez_fuse_secmem_zero" (uptr size_t) void)) + (define c-secmem-copy-in + (foreign-procedure "chez_fuse_secmem_copy_in" (uptr u8* size_t) void)) + (define c-secmem-copy-out + (foreign-procedure "chez_fuse_secmem_copy_out" (u8* uptr size_t) void)) + + ;; ---- Low-level API ---- + + (define (secmem-alloc size) + (let ([ptr (c-secmem-alloc size)]) + (if (= ptr 0) #f ptr))) + + (define (secmem-free! ptr size) + (c-secmem-free ptr size)) + + (define (secmem-zero! ptr size) + (c-secmem-zero ptr size)) + + ;; ---- Secure key holder ---- + ;; Stores a cryptographic key in mlock'd memory outside the GC heap. + ;; The GC cannot copy, move, or leave stale copies of this data. + + (define-record-type secure-key-record + (fields + (mutable ptr) ;; foreign pointer (uptr), 0 when destroyed + (immutable size) ;; key size in bytes + (mutable live?))) ;; #t until destroyed + + (define (secure-key? x) (secure-key-record? x)) + (define (secure-key-size sk) (secure-key-record-size sk)) + (define (secure-key-live? sk) (secure-key-record-live? sk)) + + ;; Create a secure key from a bytevector. The bytevector is zeroed after copy. + (define (make-secure-key bv) + (let* ([len (bytevector-length bv)] + [ptr (secmem-alloc len)]) + (unless ptr + (error 'make-secure-key "failed to allocate secure memory")) + (c-secmem-copy-in ptr bv len) + ;; Zero the source bytevector — the caller's copy is now dead + (bytevector-fill! bv 0) + (make-secure-key-record ptr len #t))) + + ;; Borrow the key as a temporary bytevector. + ;; WARNING: The caller MUST zero this bytevector when done. + ;; Use call-with-secure-key instead when possible. + (define (secure-key-borrow sk) + (unless (secure-key-record-live? sk) + (error 'secure-key-borrow "key has been destroyed")) + (let* ([len (secure-key-record-size sk)] + [bv (make-bytevector len 0)]) + (c-secmem-copy-out bv (secure-key-record-ptr sk) len) + bv)) + + ;; Destroy the key — zero and free the mlock'd memory. + (define (secure-key-destroy! sk) + (when (secure-key-record-live? sk) + (secmem-free! (secure-key-record-ptr sk) (secure-key-record-size sk)) + (secure-key-record-ptr-set! sk 0) + (secure-key-record-live?-set! sk #f))) + + ;; Run proc with the key as a temporary bytevector, guaranteed to be + ;; zeroed afterward even if proc raises an exception. + (define (call-with-secure-key sk proc) + (unless (secure-key-record-live? sk) + (error 'call-with-secure-key "key has been destroyed")) + (let ([bv (secure-key-borrow sk)]) + (dynamic-wind + (lambda () (void)) + (lambda () (proc bv)) + (lambda () (bytevector-fill! bv 0))))) + +) ;; end library --- a/lib/chez/fuse/types.sls +++ b/lib/chez/fuse/types.sls @@ -48,7 +48,8 @@ fuse-session-ops fuse-session-ops-set! fuse-session-mutex fuse-session-mutex-set! fuse-session-thread fuse-session-thread-set! - fuse-session-done fuse-session-done-set!) + fuse-session-done fuse-session-done-set! + fuse-session-access fuse-session-access-set!) (import (chezscheme)) @@ -141,6 +142,7 @@ (mutable ops) ;; hashtable of symbol -> procedure (mutable mutex) ;; dispatch mutex for thread safety (mutable thread) ;; background thread handle (or #f) - (mutable done))) ;; completion flag + (mutable done) ;; condition variable for join + (mutable access))) ;; access-controller or #f (stealth deny) ) ;; end library --- a/lib/chez/vault.sls +++ b/lib/chez/vault.sls @@ -4,7 +4,10 @@ vault-create! ;; path passphrase total-blocks → vault vault-open ;; path passphrase → vault vault-close! ;; vault → void - vault->fuse-ops ;; vault → ops-hashtable + vault-lock! ;; vault → void (clear key, deny all I/O) + vault-unlock! ;; vault passphrase → void (re-derive key) + vault-locked? ;; vault → boolean + vault->fuse-ops ;; vault → ops-hashtable (with access gating) ;; Shell integration vault-mount! ;; path passphrase mountpoint . opts → (cons vault session) vault-unmount!) ;; (cons vault session) → void @@ -14,6 +17,8 @@ (chez fuse) (chez fuse constants) (chez fuse types) + (chez fuse access) + (chez fuse secmem) (chez vault format) (chez vault crypto) (chez vault blockstore)) @@ -47,15 +52,18 @@ (define-record-type vault-state (fields (mutable bs) ;; blockstore-state - (mutable master-key) ;; 32-byte bytevector (copy also in bs) + (mutable master-key) ;; secure-key (mlock'd) — also set in bs (mutable root-block) ;; block-num of root inode (mutable bitmap-start) ;; first bitmap block number (mutable bitmap-nblocks) ;; number of bitmap blocks (mutable generation) ;; superblock generation counter + (mutable policy-block) ;; block-num for persistent policies (or VAULT-BLOCK-INVALID) (mutable bitmap) ;; flat bytevector, in-memory (mutable bitmap-dirty?) (mutable next-fh) ;; file handle counter (mutable open-fhs) ;; eq-hashtable: fh -> inode-block-num + (mutable access) ;; access-controller (or #f) + (mutable header-bv) ;; cached raw header (for lock/unlock re-derive) (mutable mutex))) ;; ====================================================================== @@ -183,7 +191,8 @@ (vault-state-root-block vault) (vault-state-bitmap-start vault) (vault-state-bitmap-nblocks vault) - gen)))) + gen + (vault-state-policy-block vault))))) ;; ====================================================================== ;; File handle management @@ -505,14 +514,18 @@ ;; Write header (let ([hdr (encode-vault-header total-blocks salt KDF-ITERATIONS mk-enc sb-enc)]) (blockstore-write-header! bs hdr)) - ;; Set master key + ;; Set master key (moves into secure memory) (blockstore-set-key! bs master-key) ;; Build in-memory bitmap: mark reserved blocks as used (let* ([bm-bytes (* bitmap-nblks BLOCK-PAYLOAD)] [bm (make-bytevector bm-bytes 0)] [vault (make-vault-state - bs master-key root-block bitmap-start bitmap-nblks 0 - bm #f 1 (make-eq-hashtable) (make-mutex))]) + bs #f root-block bitmap-start bitmap-nblks 0 + VAULT-BLOCK-INVALID ;; policy-block + bm #f 1 (make-eq-hashtable) + #f ;; access controller + #f ;; header-bv (not needed for create) + (make-mutex))]) ;; Mark blocks 0 (superblock), 1 (root inode), 2...(1+bitmap-nblks) (bitmap) (bitmap-set! vault 0 #t) ;; superblock (bitmap-set! vault 1 #t) ;; root inode @@ -572,7 +585,8 @@ (let ([sb-pay (blockstore-read-block bs sb-block)]) (unless sb-pay (error 'vault-open "cannot read superblock")) - (let-values ([(root-block bitmap-start bitmap-nblks generation) + (let-values ([(root-block bitmap-start bitmap-nblks generation + policy-block) (decode-superblock sb-pay)]) ;; Load bitmap into memory (let* ([bm-bytes (* bitmap-nblks BLOCK-PAYLOAD)] @@ -587,8 +601,12 @@ ;; Zero passphrase key (bytevector-fill! pk 0) (make-vault-state - bs master-key root-block bitmap-start bitmap-nblks generation - bm #f 1 (make-eq-hashtable) (make-mutex)))))))))))) + bs #f root-block bitmap-start bitmap-nblks generation + policy-block + bm #f 1 (make-eq-hashtable) + #f ;; access controller + hdr-bv ;; cached header for lock/unlock + (make-mutex)))))))))))) ;; ====================================================================== ;; vault-close! @@ -596,13 +614,74 @@ (define (vault-close! vault) (with-mutex (vault-state-mutex vault) - (flush-superblock! vault) - (flush-bitmap! vault) - (blockstore-sync! (vault-state-bs vault)) + (when (blockstore-key-live? (vault-state-bs vault)) + (flush-superblock! vault) + (flush-bitmap! vault) + (blockstore-sync! (vault-state-bs vault))) (blockstore-clear-key! (vault-state-bs vault)) (blockstore-close! (vault-state-bs vault)) - (bytevector-fill! (vault-state-master-key vault) 0) - (vault-state-master-key-set! vault #f))) + (vault-state-master-key-set! vault #f) + (vault-state-header-bv-set! vault #f))) + + ;; ====================================================================== + ;; vault-lock! / vault-unlock! + ;; ====================================================================== + + ;; Lock: clear the master key from memory without unmounting. + ;; All I/O operations will fail until vault-unlock! is called. + ;; The FUSE mount stays alive — unauthorized processes see an empty dir. + (define (vault-lock! vault) + (with-mutex (vault-state-mutex vault) + ;; Flush pending state while we still have the key + (when (blockstore-key-live? (vault-state-bs vault)) + (flush-superblock! vault) + (flush-bitmap! vault) + (blockstore-sync! (vault-state-bs vault))) + ;; Destroy the master key + (blockstore-clear-key! (vault-state-bs vault)) + (vault-state-master-key-set! vault #f) + ;; Lock the access controller + (let ([ac (vault-state-access vault)]) + (when ac (access-controller-lock! ac))))) + + ;; Unlock: re-derive the master key from passphrase using cached header. + ;; Returns #t on success, raises on wrong passphrase. + (define (vault-unlock! vault passphrase) + (with-mutex (vault-state-mutex vault) + (let ([hdr-bv (vault-state-header-bv vault)]) + (unless hdr-bv + (error 'vault-unlock! "no cached header — vault was not opened with vault-open")) + (let* ([pass-bv (if (string? passphrase) (string->utf8 passphrase) passphrase)]) + (let-values ([(_magic _ver _blksz _total salt kdf-iter mk-enc sb-enc) + (decode-vault-header hdr-bv)]) + (let ([pk (vault-pbkdf2 pass-bv salt kdf-iter VAULT-KEY-LEN)]) + (let ([master-key (vault-decrypt-small pk mk-enc)]) + (bytevector-fill! pk 0) + (unless master-key + (error 'vault-unlock! "wrong passphrase")) + ;; Restore the key in blockstore (moves to secure memory) + (blockstore-set-key! (vault-state-bs vault) master-key) + ;; Reload bitmap from disk (may have been modified before lock) + (let* ([bitmap-nblks (vault-state-bitmap-nblocks vault)] + [bm-bytes (* bitmap-nblks BLOCK-PAYLOAD)] + [bm (make-bytevector bm-bytes 0)] + [bs (vault-state-bs vault)] + [bitmap-start (vault-state-bitmap-start vault)]) + (let loop ([i 0]) + (when (< i bitmap-nblks) + (let ([blk-pay (blockstore-read-block bs (+ bitmap-start i))]) + (when blk-pay + (bytevector-copy! blk-pay 0 bm (* i BLOCK-PAYLOAD) BLOCK-PAYLOAD))) + (loop (+ i 1)))) + (vault-state-bitmap-set! vault bm) + (vault-state-bitmap-dirty?-set! vault #f)) + ;; Unlock access controller + (let ([ac (vault-state-access vault)]) + (when ac (access-controller-unlock! ac))) + #t))))))) + + (define (vault-locked? vault) + (not (blockstore-key-live? (vault-state-bs vault)))) ;; ====================================================================== ;; FUSE op implementations @@ -879,13 +958,20 @@ (define (vault-mount! path passphrase mountpoint . opts) ;; Open vault, mount as FUSE filesystem in background. + ;; Creates an access controller: only jsh (current PID) and its + ;; subprocesses can access the vault. Everyone else (including root) + ;; sees an empty directory. ;; Returns (cons vault session) — pass to vault-unmount! (let* ([vault (vault-open path passphrase)] - [ops (vault->fuse-ops vault)] - [session (apply fuse-start-background! ops mountpoint - 'fsname "vault" - opts)]) - (cons vault session))) + [ac (make-access-controller)] + [ops (vault->fuse-ops vault)]) + ;; Store access controller in vault for lock/unlock + (vault-state-access-set! vault ac) + (let ([session (apply fuse-start-background! ops mountpoint + 'fsname "vault" + 'access-controller ac + opts)]) + (cons vault session)))) (define (vault-unmount! handle) ;; handle = (cons vault session) --- a/lib/chez/vault/blockstore.sls +++ b/lib/chez/vault/blockstore.sls @@ -11,11 +11,14 @@ blockstore-read-block ;; block-num → BLOCK-PAYLOAD bv or #f blockstore-write-block! ;; block-num payload → void blockstore-sync! - blockstore-total-blocks) + blockstore-total-blocks + blockstore-key-live?) (import (chezscheme) (chez vault format) - (chez vault crypto)) + (chez vault crypto) + (chez fuse mount) ;; ensure shared lib loaded + (chez fuse secmem)) ;; ---- OS file I/O FFI ---- ;; Load libc for pread, pwrite, open, close, fsync. @@ -56,7 +59,7 @@ (fields (mutable fd) (mutable total-blocks) - (mutable master-key) ;; #f or 32-byte bytevector + (mutable master-key) ;; #f or secure-key (mlock'd, outside GC heap) (mutable mutex))) (define (make-blockstore) @@ -145,19 +148,31 @@ (blockstore-state-fd-set! bs -1)))) ;; ---- Key management ---- + ;; Master key is stored in mlock'd memory outside the GC heap. + ;; It is never exposed as a plain bytevector at rest — only borrowed + ;; temporarily for crypto operations, then immediately zeroed. (define (blockstore-set-key! bs key-bv) - ;; Copy the 32-byte master key into the blockstore. + ;; Move the 32-byte master key into secure memory. + ;; key-bv is zeroed by make-secure-key. + (let ([old (blockstore-state-master-key bs)]) + (when old (secure-key-destroy! old))) (let ([copy (make-bytevector VAULT-KEY-LEN 0)]) (bytevector-copy! key-bv 0 copy 0 VAULT-KEY-LEN) - (blockstore-state-master-key-set! bs copy))) + (blockstore-state-master-key-set! bs (make-secure-key copy)))) (define (blockstore-clear-key! bs) - ;; Zero and discard the master key. - (let ([k (blockstore-state-master-key bs)]) - (when k (bytevector-fill! k 0))) + ;; Securely destroy the master key (zeros mlock'd memory + munmap). + (let ([sk (blockstore-state-master-key bs)]) + (when (and sk (secure-key? sk) (secure-key-live? sk)) + (secure-key-destroy! sk))) (blockstore-state-master-key-set! bs #f)) + (define (blockstore-key-live? bs) + ;; Is the master key currently available? + (let ([sk (blockstore-state-master-key bs)]) + (and sk (secure-key? sk) (secure-key-live? sk)))) + ;; ---- Header I/O (unencrypted) ---- (define (blockstore-read-header bs) @@ -169,31 +184,41 @@ (raw-write! bs 0 bv)) ;; ---- Block I/O (encrypted) ---- + ;; The master key is borrowed from secure memory only for the duration + ;; of the crypto operation. The temporary bytevector is zeroed afterward. (define (blockstore-read-block bs block-num) ;; Returns decrypted BLOCK-PAYLOAD-byte bv, or #f on auth failure / I/O error. (with-mutex (blockstore-state-mutex bs) - (let ([mk (blockstore-state-master-key bs)]) - (and mk - (let* ([raw-bv (make-bytevector BLOCK-SIZE 0)] - [offset (block-offset block-num)]) + (let ([sk (blockstore-state-master-key bs)]) + (and sk (secure-key? sk) (secure-key-live? sk) + (let* ([raw-bv (make-bytevector BLOCK-SIZE 0)] + [offset (block-offset block-num)]) (guard (exn [#t #f]) (raw-read! bs offset raw-bv) - (let ([bk (vault-block-key mk block-num)]) - (vault-decrypt-block bk raw-bv)))))))) + (call-with-secure-key sk + (lambda (mk-bv) + (let* ([bk (vault-block-key mk-bv block-num)] + [result (vault-decrypt-block bk raw-bv)]) + (bytevector-fill! bk 0) + result))))))))) (define (blockstore-write-block! bs block-num payload-bv) ;; Encrypts payload and writes to disk. payload-bv must be BLOCK-PAYLOAD bytes. (with-mutex (blockstore-state-mutex bs) - (let ([mk (blockstore-state-master-key bs)]) - (unless mk (error 'blockstore-write-block! "no master key set")) + (let ([sk (blockstore-state-master-key bs)]) + (unless (and sk (secure-key? sk) (secure-key-live? sk)) + (error 'blockstore-write-block! "no master key set")) (unless (= (bytevector-length payload-bv) BLOCK-PAYLOAD) (error 'blockstore-write-block! "wrong payload size" (bytevector-length payload-bv))) - (let* ([bk (vault-block-key mk block-num)] - [encrypted (vault-encrypt-block bk payload-bv)] - [offset (block-offset block-num)]) - (raw-write! bs offset encrypted))))) + (call-with-secure-key sk + (lambda (mk-bv) + (let* ([bk (vault-block-key mk-bv block-num)] + [encrypted (vault-encrypt-block bk payload-bv)] + [offset (block-offset block-num)]) + (bytevector-fill! bk 0) + (raw-write! bs offset encrypted))))))) ;; ---- Sync ---- --- a/lib/chez/vault/format.sls +++ b/lib/chez/vault/format.sls @@ -129,23 +129,28 @@ ;; 8 8 bitmap_start (u64 LE) ;; 16 8 bitmap_blocks (u64 LE) ;; 24 8 generation (u64 LE) - ;; 32 4036 padding + ;; 32 8 policy_block (u64 LE, VAULT-BLOCK-INVALID = none) + ;; 40 4028 padding - (define (encode-superblock root-inode-block bitmap-start bitmap-blocks generation) + (define (encode-superblock root-inode-block bitmap-start bitmap-blocks + generation policy-block) (let ([bv (make-bytevector BLOCK-PAYLOAD 0)]) (bv-set-u64le! bv 0 root-inode-block) (bv-set-u64le! bv 8 bitmap-start) (bv-set-u64le! bv 16 bitmap-blocks) (bv-set-u64le! bv 24 generation) + (bv-set-u64le! bv 32 policy-block) bv)) (define (decode-superblock bv) - ;; Returns: (values root-inode-block bitmap-start bitmap-blocks generation) + ;; Returns: (values root-inode-block bitmap-start bitmap-blocks + ;; generation policy-block) (values (bv-u64le bv 0) (bv-u64le bv 8) (bv-u64le bv 16) - (bv-u64le bv 24))) + (bv-u64le bv 24) + (bv-u64le bv 32))) ;; ---- Inode ---- ;; Encrypted; occupies one BLOCK-PAYLOAD-byte block. --- a/src/mount_helper.c +++ b/src/mount_helper.c @@ -1,14 +1,26 @@ /* - * chez-fuse mount helper — tiny C shim for platform-specific mount/unmount. + * chez-fuse mount helper — C shim for platform-specific operations. * Compiled as a shared library, loaded by Chez Scheme via load-shared-object. * * Exports: - * int chez_fuse_open_device(void) - * int chez_fuse_mount(int fd, const char *mountpoint, const char *fsname, - * int uid, int gid, int allow_other) - * int chez_fuse_unmount(const char *mountpoint) - * int chez_fuse_unmount_lazy(const char *mountpoint) - * int chez_fuse_get_errno(void) + * Mount/unmount: + * int chez_fuse_open_device(void) + * int chez_fuse_mount(int fd, const char *mountpoint, const char *fsname, + * int uid, int gid, int allow_other) + * int chez_fuse_unmount(const char *mountpoint) + * int chez_fuse_unmount_lazy(const char *mountpoint) + * int chez_fuse_get_errno(void) + * + * Secure memory (mlock'd, excluded from core dumps): + * void *chez_fuse_secmem_alloc(size_t size) + * void chez_fuse_secmem_free(void *ptr, size_t size) + * void chez_fuse_secmem_copy_in(void *dst, const uint8_t *src, size_t len) + * void chez_fuse_secmem_copy_out(uint8_t *dst, const void *src, size_t len) + * void chez_fuse_secmem_zero(void *ptr, size_t size) + * + * Process tree inspection: + * int chez_fuse_getpid(void) + * int chez_fuse_getppid_of(int pid) */ #include <errno.h> @@ -18,21 +30,139 @@ #include <string.h> #include <unistd.h> #include <signal.h> +#include <sys/mman.h> #include <sys/wait.h> #if defined(FREEBSD) #include <sys/param.h> #include <sys/mount.h> #include <sys/uio.h> +#include <sys/types.h> +#include <sys/sysctl.h> +#include <sys/user.h> #elif defined(LINUX) #include <sys/mount.h> +#include <sys/prctl.h> #ifndef MNT_DETACH #define MNT_DETACH 2 #endif #elif defined(DARWIN) -/* macOS uses FUSE-T or macFUSE — needs separate handling */ +#include <libproc.h> +#include <sys/proc_info.h> #endif +/* ==================================================================== + * Secure memory — mlock'd, core-dump excluded, volatile-zeroed on free + * ==================================================================== */ + +void *chez_fuse_secmem_alloc(size_t size) { + /* Use mmap for page-aligned allocation we fully control */ + void *p = mmap(NULL, size, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (p == MAP_FAILED) return NULL; + + /* Lock into RAM — prevent swapping */ + mlock(p, size); /* best-effort; may fail without RLIMIT_MEMLOCK */ + + /* Exclude from core dumps */ +#if defined(FREEBSD) + madvise(p, size, MADV_NOCORE); +#elif defined(LINUX) + madvise(p, size, MADV_DONTDUMP); +#endif + + memset(p, 0, size); + return p; +} + +void chez_fuse_secmem_free(void *ptr, size_t size) { + if (!ptr) return; + /* Volatile-safe zeroing — compiler cannot optimize this away */ + volatile unsigned char *vp = (volatile unsigned char *)ptr; + for (size_t i = 0; i < size; i++) vp[i] = 0; + munlock(ptr, size); + munmap(ptr, size); +} + +void chez_fuse_secmem_zero(void *ptr, size_t size) { + if (!ptr) return; + volatile unsigned char *vp = (volatile unsigned char *)ptr; + for (size_t i = 0; i < size; i++) vp[i] = 0; +} + +void chez_fuse_secmem_copy_in(void *dst, const unsigned char *src, size_t len) { + memcpy(dst, src, len); +} + +void chez_fuse_secmem_copy_out(unsigned char *dst, const void *src, size_t len) { + memcpy(dst, src, len); +} + +/* ==================================================================== + * Process tree inspection + * ==================================================================== */ + +int chez_fuse_getpid(void) { + return (int)getpid(); +} + +#if defined(FREEBSD) + +/* Get parent PID of any process via sysctl. Returns -1 on error. */ +int chez_fuse_getppid_of(int pid) { + struct kinfo_proc kp; + size_t len = sizeof(kp); + int mib[4] = { CTL_KERN, KERN_PROC, KERN_PROC_PID, pid }; + if (sysctl(mib, 4, &kp, &len, NULL, 0) < 0) return -1; + if (len == 0) return -1; /* process doesn't exist */ + return (int)kp.ki_ppid; +} + +#elif defined(LINUX) + +/* Get parent PID by reading /proc/<pid>/stat. Returns -1 on error. */ +int chez_fuse_getppid_of(int pid) { + char path[64]; + snprintf(path, sizeof(path), "/proc/%d/stat", pid); + FILE *f = fopen(path, "r"); + if (!f) return -1; + /* Format: pid (comm) state ppid ... */ + /* comm can contain spaces and parens, so find last ')' first */ + char buf[512]; + size_t n = fread(buf, 1, sizeof(buf) - 1, f); + fclose(f); + if (n == 0) return -1; + buf[n] = '\0'; + char *p = strrchr(buf, ')'); + if (!p) return -1; + int ppid = -1; + /* After ')' comes: space, state char, space, ppid */ + if (sscanf(p + 2, "%*c %d", &ppid) != 1) return -1; + return ppid; +} + +#elif defined(DARWIN) + +int chez_fuse_getppid_of(int pid) { + struct proc_bsdinfo info; + int ret = proc_pidinfo(pid, PROC_PIDTBSDINFO, 0, &info, sizeof(info)); + if (ret <= 0) return -1; + return (int)info.pbi_ppid; +} + +#else + +int chez_fuse_getppid_of(int pid) { + (void)pid; + return -1; +} + +#endif + +/* ==================================================================== + * FUSE device and errno + * ==================================================================== */ + /* Open /dev/fuse and return the file descriptor, or -1 on error. * Sets O_CLOEXEC so forked children don't inherit the fd. */ int chez_fuse_open_device(void) { @@ -61,6 +191,10 @@ int chez_fuse_unblock_signal(int signum) { return sigprocmask(SIG_UNBLOCK, &set, NULL); } +/* ==================================================================== + * Platform-specific mount/unmount + * ==================================================================== */ + #if defined(FREEBSD) /* new file mode 100644 --- /dev/null +++ b/tests/test-access.ss @@ -0,0 +1,69 @@ +;;; test-access.ss — tests for the process-tree access controller +;;; Run with: scheme --libdirs lib --script tests/test-access.ss + +(import (chezscheme)) +(import (chez fuse access)) + +(define pass 0) +(define fail 0) + +(define (test-assert name expr) + (if expr + (begin (set! pass (+ pass 1)) + (display " PASS: ") (display name) (newline)) + (begin (set! fail (+ fail 1)) + (display " FAIL: ") (display name) (newline)))) + +(display "=== access controller ===") (newline) + +;; Our own PID should always be trusted +(define ac (make-access-controller)) +(define my-pid + ((foreign-procedure "chez_fuse_getpid" () int))) + +(test-assert "own PID is trusted" + (access-check ac my-pid)) + +;; PID 1 (init/launchd) should NOT be trusted (not our descendant) +(test-assert "PID 1 is not trusted" + (not (access-check ac 1))) + +;; A bogus PID that almost certainly doesn't exist +(test-assert "nonexistent PID is not trusted" + (not (access-check ac 999999999))) + +;; Lock should deny everything +(access-controller-lock! ac) +(test-assert "locked: own PID denied" + (not (access-check ac my-pid)))