Fix Capsicum/Seatbelt FFI and add FreeBSD VM test harness

ober

186171fe7fe2c9c6c638c21150b49d5c05e82eac

diff --git a/.gitignore b/.gitignore
index 8692303..7671094 100644
--- a/.gitignore
+++ b/.gitignore
@@ -13,3 +13,13 @@ new.txt
 
 # External project stubs (belong in their own repos)
 lib/gerbil-litehtml/
+
+# VM test artifacts (large images, keys, ISOs)
+tests/vm/*.qcow2
+tests/vm/*.qcow2.xz
+tests/vm/*.iso
+tests/vm/vm_key
+tests/vm/vm_key.pub
+tests/vm/seed/
+tests/vm/*.log
+tests/vm/*.pid
diff --git a/lib/std/security/capsicum.sls b/lib/std/security/capsicum.sls
index 9276aef..ca15c4b 100644
--- a/lib/std/security/capsicum.sls
+++ b/lib/std/security/capsicum.sls
@@ -57,6 +57,14 @@
 
   ;; ========== FFI ==========
 
+  ;; Load libc on FreeBSD (required for cap_enter, cap_getmode, etc.)
+  (define _libc
+    (if (freebsd?)
+      (or (guard (e [#t #f]) (load-shared-object "libc.so.7"))
+          (guard (e [#t #f]) (load-shared-object "libc.so"))
+          (guard (e [#t #f]) (load-shared-object "")))
+      #f))
+
   ;; cap_enter(void) -> int  (0 on success, -1 on error)
   (define c-cap-enter
     (if (freebsd?)
@@ -100,30 +108,41 @@
             (foreign-ref 'int loc 0)))))
 
   ;; ========== Capsicum Rights Constants ==========
-  ;; From sys/capsicum.h — these are bit positions in the rights bitmask
-
-  ;; Index 0 rights (general operations)
-  (define capsicum-right-read       (bitwise-arithmetic-shift-left 1 57))   ;; CAP_READ
-  (define capsicum-right-write      (bitwise-arithmetic-shift-left 1 58))   ;; CAP_WRITE
-  (define capsicum-right-seek       (bitwise-arithmetic-shift-left 1 11))   ;; CAP_SEEK
-  (define capsicum-right-mmap       (bitwise-arithmetic-shift-left 1 24))   ;; CAP_MMAP
-  (define capsicum-right-fstat      (bitwise-arithmetic-shift-left 1 40))   ;; CAP_FSTAT
-  (define capsicum-right-ftruncate  (bitwise-arithmetic-shift-left 1 42))   ;; CAP_FTRUNCATE
-  (define capsicum-right-event      (bitwise-arithmetic-shift-left 1 46))   ;; CAP_EVENT
-  (define capsicum-right-lookup     (bitwise-arithmetic-shift-left 1 56))   ;; CAP_LOOKUP
+  ;;
+  ;; From sys/capsicum.h:
+  ;;   #define CAPRIGHT(idx, bit) ((1ULL << (57 + (idx))) | (bit))
+  ;;   cap_rights_t = struct { uint64_t cr_rights[2]; }
+  ;;   cr_rights[0] = (1 << 57) | index-0-rights
+  ;;   cr_rights[1] = (1 << 58) | index-1-rights
+  ;;
+  ;; Each right has an index (0 or 1) and a bit value.
+  ;; We store them as (index . bit) pairs for correct packing.
+
+  ;; Index 0 rights — stored as raw bit values (no index marker)
+  (define capsicum-right-read       #x0000000000000001)  ;; CAP_READ
+  (define capsicum-right-write      #x0000000000000002)  ;; CAP_WRITE
+  (define capsicum-right-seek       #x000000000000000c)  ;; CAP_SEEK
+  (define capsicum-right-mmap       #x0000000000000010)  ;; CAP_MMAP
+  (define capsicum-right-fstat      #x0000000000080000)  ;; CAP_FSTAT
+  (define capsicum-right-ftruncate  #x0000000000000200)  ;; CAP_FTRUNCATE
+  (define capsicum-right-lookup     #x0000000000000400)  ;; CAP_LOOKUP
+
+  ;; Index 1 rights
+  (define capsicum-right-event      #x0000000000000020)  ;; CAP_EVENT (index 1)
 
   ;; ========== Rights Helpers ==========
 
-  (define (symbol->right sym)
+  ;; Returns (values bit-value index) for a right symbol.
+  (define (symbol->right+index sym)
     (case sym
-      [(read)      capsicum-right-read]
-      [(write)     capsicum-right-write]
-      [(seek)      capsicum-right-seek]
-      [(mmap)      capsicum-right-mmap]
-      [(fstat)     capsicum-right-fstat]
-      [(ftruncate) capsicum-right-ftruncate]
-      [(event)     capsicum-right-event]
-      [(lookup)    capsicum-right-lookup]
+      [(read)      (values capsicum-right-read       0)]
+      [(write)     (values capsicum-right-write      0)]
+      [(seek)      (values capsicum-right-seek       0)]
+      [(mmap)      (values capsicum-right-mmap       0)]
+      [(fstat)     (values capsicum-right-fstat      0)]
+      [(ftruncate) (values capsicum-right-ftruncate  0)]
+      [(lookup)    (values capsicum-right-lookup     0)]
+      [(event)     (values capsicum-right-event      1)]
       [else (error 'capsicum-limit-fd!
               "unknown right; expected read, write, seek, mmap, fstat, ftruncate, event, or lookup"
               sym)]))
@@ -131,20 +150,24 @@
   (define (pack-rights right-symbols)
     ;; Pack a list of right symbols into a cap_rights_t foreign structure.
     ;; Returns a foreign pointer that must be freed by the caller.
-    (let ([rights-mem (foreign-alloc CAP_RIGHTS_SIZE)]
-          [mask (fold-left
-                  (lambda (acc sym) (bitwise-ior acc (symbol->right sym)))
-                  0
-                  right-symbols)])
-      ;; cap_rights_t = { cr_rights[0] = version_and_rights, cr_rights[1] = 0 }
-      ;; cr_rights[0] bits 57..62 encode the version (CAP_RIGHTS_VERSION = 0)
-      ;; The actual rights are OR'd in
-      (foreign-set! 'unsigned-64 rights-mem 0
-        (bitwise-ior
-          (bitwise-arithmetic-shift-left (+ CAP_RIGHTS_VERSION 2) 57)
-          mask))
-      (foreign-set! 'unsigned-64 rights-mem 8 0)
-      rights-mem))
+    ;;
+    ;; cap_rights_t layout:
+    ;;   cr_rights[0] = (1 << 57) | all index-0 right bits
+    ;;   cr_rights[1] = (1 << 58) | all index-1 right bits
+    (let loop ([syms right-symbols] [idx0-bits 0] [idx1-bits 0])
+      (if (null? syms)
+        (let ([rights-mem (foreign-alloc CAP_RIGHTS_SIZE)])
+          ;; cr_rights[0]: version marker (1 << 57) | index-0 rights
+          (foreign-set! 'unsigned-64 rights-mem 0
+            (bitwise-ior (bitwise-arithmetic-shift-left 1 57) idx0-bits))
+          ;; cr_rights[1]: version marker (1 << 58) | index-1 rights
+          (foreign-set! 'unsigned-64 rights-mem 8
+            (bitwise-ior (bitwise-arithmetic-shift-left 1 58) idx1-bits))
+          rights-mem)
+        (let-values ([(bit idx) (symbol->right+index (car syms))])
+          (if (= idx 0)
+            (loop (cdr syms) (bitwise-ior idx0-bits bit) idx1-bits)
+            (loop (cdr syms) idx0-bits (bitwise-ior idx1-bits bit)))))))
 
   ;; ========== Availability ==========
 
diff --git a/lib/std/security/seatbelt.sls b/lib/std/security/seatbelt.sls
index 0eaf2ec..3d60747 100644
--- a/lib/std/security/seatbelt.sls
+++ b/lib/std/security/seatbelt.sls
@@ -60,6 +60,14 @@
 
   ;; ========== FFI ==========
 
+  ;; Load libsystem_sandbox on macOS (required for sandbox_init)
+  (define _libsandbox
+    (if (macos?)
+      (or (guard (e [#t #f]) (load-shared-object "libsandbox.dylib"))
+          (guard (e [#t #f]) (load-shared-object "/usr/lib/libsandbox.1.dylib"))
+          (guard (e [#t #f]) (load-shared-object "")))
+      #f))
+
   ;; sandbox_init(const char *profile, uint64_t flags, char **errorbuf) -> int
   ;; Returns 0 on success, -1 on failure (errorbuf set).
   (define c-sandbox-init
diff --git a/tests/vm/run-freebsd-tests.sh b/tests/vm/run-freebsd-tests.sh
new file mode 100755
index 0000000..3180882
--- /dev/null
+++ b/tests/vm/run-freebsd-tests.sh
@@ -0,0 +1,235 @@
+#!/bin/bash
+# run-freebsd-tests.sh — Boot FreeBSD cloud-init VM, run Capsicum tests
+#
+# Prerequisites (one-time setup):
+#   cd tests/vm
+#   # 1. Download FreeBSD cloud-init image:
+#   curl -L -o FreeBSD-14.4-RELEASE-amd64-BASIC-CLOUDINIT-ufs.qcow2.xz \
+#     https://download.freebsd.org/releases/VM-IMAGES/14.4-RELEASE/amd64/Latest/FreeBSD-14.4-RELEASE-amd64-BASIC-CLOUDINIT-ufs.qcow2.xz
+#   xz -dk FreeBSD-14.4-RELEASE-amd64-BASIC-CLOUDINIT-ufs.qcow2.xz
+#   qemu-img resize FreeBSD-14.4-RELEASE-amd64-BASIC-CLOUDINIT-ufs.qcow2 10G
+#
+#   # 2. Generate SSH key:
+#   ssh-keygen -t ed25519 -f vm_key -N ""
+#
+#   # 3. Create cloud-init seed ISO:
+#   mkdir -p seed
+#   cat > seed/meta-data <<EOF
+#   instance-id: freebsd-test
+#   local-hostname: freebsd-test
+#   EOF
+#   cat > seed/user-data <<EOF
+#   #cloud-config
+#   ssh_pwauth: true
+#   disable_root: false
+#   chpasswd:
+#     list: |
+#       root:testpass123
+#     expire: false
+#   users:
+#     - name: root
+#       lock_passwd: false
+#       ssh_authorized_keys:
+#         - $(cat vm_key.pub)
+#   runcmd:
+#     - sed -i '' 's/^#*PermitRootLogin.*/PermitRootLogin yes/' /etc/ssh/sshd_config
+#     - service sshd restart
+#   EOF
+#   mkisofs -output seed.iso -volid cidata -joliet -rock seed/user-data seed/meta-data
+#
+# Requires: qemu-system-x86_64 with KVM
+
+set -euo pipefail
+
+SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)"
+PROJECT_DIR="$(cd "$SCRIPT_DIR/../.." && pwd)"
+VM_IMAGE="$SCRIPT_DIR/FreeBSD-14.4-RELEASE-amd64-BASIC-CLOUDINIT-ufs.qcow2"
+SEED_ISO="$SCRIPT_DIR/seed.iso"
+SSH_KEY="$SCRIPT_DIR/vm_key"
+SNAPSHOT="$SCRIPT_DIR/freebsd-test-snapshot.qcow2"
+SSH_PORT=2222
+VM_PID=""
+
+cleanup() {
+    [[ -n "$VM_PID" ]] && kill -0 "$VM_PID" 2>/dev/null && {
+        echo "==> Shutting down VM..."
+        kill "$VM_PID" 2>/dev/null; wait "$VM_PID" 2>/dev/null || true
+    }
+    rm -f "$SNAPSHOT" "$SCRIPT_DIR/vm.pid" /tmp/fbsd-*.ss
+}
+trap cleanup EXIT
+
+for f in "$VM_IMAGE" "$SEED_ISO" "$SSH_KEY"; do
+    [[ -f "$f" ]] || { echo "ERROR: missing $f"; exit 1; }
+done
+
+echo "==> Creating snapshot overlay..."
+rm -f "$SNAPSHOT"
+qemu-img create -f qcow2 -b "$VM_IMAGE" -F qcow2 "$SNAPSHOT" 2>/dev/null
+
+echo "==> Booting FreeBSD VM (SSH→:$SSH_PORT)..."
+qemu-system-x86_64 \
+    -enable-kvm -m 2048 -smp 2 \
+    -drive file="$SNAPSHOT",format=qcow2 \
+    -cdrom "$SEED_ISO" \
+    -net nic -net user,hostfwd=tcp::${SSH_PORT}-:22 \
+    -display none -daemonize \
+    -pidfile "$SCRIPT_DIR/vm.pid"
+VM_PID=$(cat "$SCRIPT_DIR/vm.pid")
+echo "    VM PID: $VM_PID"
+
+# SSH helper (key-based, IdentitiesOnly to avoid agent key flooding)
+vm_ssh() {
+    ssh -o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null \
+        -o IdentitiesOnly=yes -o LogLevel=ERROR \
+        -i "$SSH_KEY" -p $SSH_PORT root@localhost "$@"
+}
+vm_scp() {
+    scp -o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null \
+        -o IdentitiesOnly=yes -o LogLevel=ERROR \
+        -i "$SSH_KEY" -P $SSH_PORT "$@"
+}
+
+# Wait for SSH
+echo "==> Waiting for VM + cloud-init..."
+MAX_WAIT=300; WAITED=0
+while ! vm_ssh echo "SSH_OK" 2>/dev/null | grep -q "SSH_OK"; do
+    sleep 5; WAITED=$((WAITED + 5))
+    kill -0 "$VM_PID" 2>/dev/null || { echo "ERROR: VM died"; exit 1; }
+    [[ $WAITED -lt $MAX_WAIT ]] || { echo "ERROR: no SSH after ${MAX_WAIT}s"; exit 1; }
+    printf "    %ds...\n" "$WAITED"
+done
+echo "==> SSH ready after ${WAITED}s"
+vm_ssh "uname -rms"
+
+# Install Chez Scheme
+echo ""; echo "==> Installing Chez Scheme..."
+vm_ssh "pkg install -y chez-scheme 2>&1" | tail -5
+SCHEME_CMD=$(vm_ssh "which scheme 2>/dev/null || which chez-scheme 2>/dev/null || echo ''")
+[[ -n "$SCHEME_CMD" ]] || { echo "ERROR: Chez Scheme not found"; exit 1; }
+echo "    $SCHEME_CMD $(vm_ssh "$SCHEME_CMD --version 2>&1")"
+
+# Copy project files
+echo ""; echo "==> Copying files..."
+vm_ssh "mkdir -p /root/jerboa/lib/std/security /root/jerboa/lib/std/os /root/jerboa/lib/std/error /root/jerboa/tests"
+for f in sandbox.sls seccomp.sls landlock.sls seatbelt.sls capsicum.sls capability.sls restrict.sls; do
+    [[ -f "$PROJECT_DIR/lib/std/security/$f" ]] && vm_scp "$PROJECT_DIR/lib/std/security/$f" "root@localhost:/root/jerboa/lib/std/security/"
+done
+for f in sandbox.sls platform.sls; do
+    [[ -f "$PROJECT_DIR/lib/std/os/$f" ]] && vm_scp "$PROJECT_DIR/lib/std/os/$f" "root@localhost:/root/jerboa/lib/std/os/"
+done
+[[ -f "$PROJECT_DIR/lib/std/safe-timeout.sls" ]] && vm_scp "$PROJECT_DIR/lib/std/safe-timeout.sls" "root@localhost:/root/jerboa/lib/std/"
+[[ -f "$PROJECT_DIR/lib/std/error/conditions.sls" ]] && vm_scp "$PROJECT_DIR/lib/std/error/conditions.sls" "root@localhost:/root/jerboa/lib/std/error/"
+for f in test-capsicum.ss test-seatbelt.ss; do
+    vm_scp "$PROJECT_DIR/tests/$f" "root@localhost:/root/jerboa/tests/"
+done
+
+# ============================================================
+# Run tests
+# ============================================================
+TOTAL_PASS=0; TOTAL_FAIL=0
+
+run_test() {
+    local label="$1" file="$2"
+    echo ""; echo "============================================"
+    echo "==> $label"; echo "============================================"
+    local out
+    out=$(vm_ssh "cd /root/jerboa && $SCHEME_CMD --libdirs lib --script tests/$file 2>&1") || true
+    echo "$out"
+    local p=$(echo "$out" | grep -oP '\d+(?= passed)' || echo 0)
+    local f=$(echo "$out" | grep -oP '\d+(?= failed)' || echo 0)
+    TOTAL_PASS=$((TOTAL_PASS + p)); TOTAL_FAIL=$((TOTAL_FAIL + f))
+}
+
+run_test "Capsicum unit tests" "test-capsicum.ss"
+run_test "Seatbelt unit tests (non-macOS)" "test-seatbelt.ss"
+
+# Capsicum functional test — real kernel enforcement
+cat > /tmp/fbsd-capsicum-functional.ss <<'SCHEME_EOF'
+#!chezscheme
+(import (chezscheme) (std security capsicum))
+(load-shared-object "libc.so.7")
+
+(define pass 0) (define fail 0)
+(define-syntax test
+  (syntax-rules ()
+    [(_ name expr expected)
+     (guard (exn [#t (set! fail (+ fail 1))
+                     (printf "FAIL ~a: ~a~%" name
+                       (if (message-condition? exn) (condition-message exn) exn))])
+       (let ([got expr])
+         (if (equal? got expected)
+           (begin (set! pass (+ pass 1)) (printf "  ok ~a~%" name))
+           (begin (set! fail (+ fail 1))
+                  (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))]))
+
+(define c-fork   (foreign-procedure "fork" () int))
+(define c-waitpid (foreign-procedure "waitpid" (int void* int) int))
+(define c-exit   (foreign-procedure "_exit" (int) void))
+(define c-open   (foreign-procedure "open" (string int) int))
+(define c-close  (foreign-procedure "close" (int) int))
+(define (wait-child pid)
+  (let ([buf (foreign-alloc 4)])
+    (c-waitpid pid buf 0)
+    (let ([raw (foreign-ref 'int buf 0)])
+      (foreign-free buf)
+      (bitwise-and (bitwise-arithmetic-shift-right raw 8) #xff))))
+
+(printf "--- Capsicum Functional Tests (FreeBSD kernel) ---~%~%")
+
+(test "capsicum-available?" (capsicum-available?) #t)
+(test "not in cap mode initially" (capsicum-in-capability-mode?) #f)
+
+;; cap_enter blocks open()
+(printf "~%-- cap_enter enforcement --~%")
+(let ([pid (c-fork)])
+  (cond
+    [(< pid 0) (set! fail (+ fail 1)) (printf "FAIL fork~%")]
+    [(= pid 0)
+     (capsicum-enter!)
+     (if (not (capsicum-in-capability-mode?)) (c-exit 2)
+       (let ([fd (c-open "/etc/passwd" 0)])
+         (if (< fd 0) (c-exit 0) (begin (c-close fd) (c-exit 1)))))]
+    [else
+     (let ([c (wait-child pid)])
+       (if (= c 0)
+         (begin (set! pass (+ pass 1)) (printf "  ok cap_enter blocks open()~%"))
+         (begin (set! fail (+ fail 1)) (printf "FAIL child=~a~%" c))))
+     (test "parent unaffected" (capsicum-in-capability-mode?) #f)
+     (let ([fd (c-open "/etc/passwd" 0)])
+       (test "parent can still open files" (>= fd 0) #t)
+       (when (>= fd 0) (c-close fd)))]))
+
+;; cap_rights_limit restricts write
+(printf "~%-- cap_rights_limit enforcement --~%")
+(let ([pid (c-fork)])
+  (cond
+    [(< pid 0) (set! fail (+ fail 1)) (printf "FAIL fork~%")]
+    [(= pid 0)
+     (let* ([c-wr (foreign-procedure "write" (int u8* size_t) ssize_t)]
+            [fd (c-open "/tmp/cap-test" 1538)])
+       (if (< fd 0) (c-exit 3)
+         (begin
+           (c-wr fd (string->utf8 "before") 6)
+           (capsicum-limit-fd! fd '(read fstat seek))
+           (let ([n (c-wr fd (string->utf8 "after") 5)])
+             (if (< n 0) (c-exit 0) (c-exit 1))))))]
+    [else
+     (let ([c (wait-child pid)])
+       (if (= c 0)
+         (begin (set! pass (+ pass 1)) (printf "  ok cap_rights_limit blocks write~%"))
+         (begin (set! fail (+ fail 1)) (printf "FAIL child=~a~%" c))))]))
+
+(printf "~%Capsicum functional: ~a passed, ~a failed~%" pass fail)
+(when (> fail 0) (exit 1))
+SCHEME_EOF
+
+vm_scp /tmp/fbsd-capsicum-functional.ss "root@localhost:/root/jerboa/tests/"
+run_test "Capsicum FUNCTIONAL (real kernel)" "fbsd-capsicum-functional.ss"
+
+echo ""
+echo "============================================"
+echo "==> TOTAL: $TOTAL_PASS passed, $TOTAL_FAIL failed"
+echo "============================================"
+[[ $TOTAL_FAIL -eq 0 ]] && echo "ALL TESTS PASSED" || echo "SOME TESTS FAILED"
+exit $TOTAL_FAIL