Add reusable Landlock connect-port sandboxing

ober

4287d6599799657b73a48e94528f7ce461990605

diff --git a/lib/std/os/landlock-native.ss b/lib/std/os/landlock-native.ss
index 6d295c5..b543a41 100644
--- a/lib/std/os/landlock-native.ss
+++ b/lib/std/os/landlock-native.ss
@@ -7,8 +7,10 @@
 (library (std os landlock-native)
   (export
     landlock-available?
+    landlock-net-available?
     landlock-abi-version
     landlock-enforce!
+    landlock-enforce-connect-port!
     ;; Low-level API for fine-grained control
     landlock-create-ruleset
     landlock-add-path-rule
@@ -96,6 +98,9 @@
   (def (landlock-available?)
     (>= (c-landlock-abi-version) 1))
 
+  (def (landlock-net-available?)
+    (>= (c-landlock-abi-version) 4))
+
   (def (landlock-abi-version)
     (c-landlock-abi-version))
 
@@ -180,4 +185,51 @@
             (landlock-restrict-self! ruleset)
             #t)))))
 
+  (def (landlock-enforce-connect-port! read-paths write-paths exec-paths
+                                       connect-port)
+    (let ([abi (c-landlock-abi-version)])
+      (if (< abi 4)
+        'unsupported
+        (let ([ruleset
+               (landlock-create-ruleset
+                 all-fs-v1
+                 LANDLOCK_ACCESS_NET_CONNECT_TCP)])
+          ;; Reuse filesystem setup from landlock-enforce! style rules.
+          (for-each
+            (lambda (p)
+              (try (landlock-add-path-rule ruleset p
+                    (bitwise-ior LANDLOCK_ACCESS_FS_READ_FILE
+                                 LANDLOCK_ACCESS_FS_READ_DIR
+                                 LANDLOCK_ACCESS_FS_EXECUTE))
+                   (catch (e) (void))))
+            '("/usr" "/lib" "/lib64" "/bin" "/sbin" "/etc" "/proc" "/dev"))
+          (for-each
+            (lambda (p)
+              (landlock-add-path-rule ruleset p
+                (bitwise-ior LANDLOCK_ACCESS_FS_READ_FILE
+                             LANDLOCK_ACCESS_FS_READ_DIR)))
+            read-paths)
+          (for-each
+            (lambda (p)
+              (landlock-add-path-rule ruleset p
+                (bitwise-ior LANDLOCK_ACCESS_FS_READ_FILE
+                             LANDLOCK_ACCESS_FS_READ_DIR
+                             LANDLOCK_ACCESS_FS_WRITE_FILE
+                             LANDLOCK_ACCESS_FS_REMOVE_FILE
+                             LANDLOCK_ACCESS_FS_REMOVE_DIR
+                             LANDLOCK_ACCESS_FS_MAKE_REG
+                             LANDLOCK_ACCESS_FS_MAKE_DIR)))
+            write-paths)
+          (for-each
+            (lambda (p)
+              (landlock-add-path-rule ruleset p
+                (bitwise-ior LANDLOCK_ACCESS_FS_READ_FILE
+                             LANDLOCK_ACCESS_FS_READ_DIR
+                             LANDLOCK_ACCESS_FS_EXECUTE)))
+            exec-paths)
+          (landlock-add-net-rule ruleset connect-port
+                                 LANDLOCK_ACCESS_NET_CONNECT_TCP)
+          (landlock-restrict-self! ruleset)
+          #t))))
+
   ) ;; end library
diff --git a/lib/std/os/landlock.ss b/lib/std/os/landlock.ss
index bc3dc61..225de84 100644
--- a/lib/std/os/landlock.ss
+++ b/lib/std/os/landlock.ss
@@ -11,6 +11,7 @@
 ;;; For static binaries: register symbols via Sforeign_symbol():
 ;;;   Sforeign_symbol("jerboa_landlock_abi_version", (void*)jerboa_landlock_abi_version);
 ;;;   Sforeign_symbol("jerboa_landlock_sandbox", (void*)jerboa_landlock_sandbox);
+;;;   Sforeign_symbol("jerboa_landlock_sandbox_ex", (void*)jerboa_landlock_sandbox_ex);
 ;;;
 ;;; For dynamic binaries: compile and load the shared library:
 ;;;   gcc -shared -fPIC -O2 -o libjerboa-landlock.so support/landlock-shim.c
@@ -19,8 +20,10 @@
 (library (std os landlock)
   (export
     landlock-available?
+    landlock-net-available?
     landlock-abi-version
     landlock-enforce!
+    landlock-enforce-connect-port!
 
     ;; Condition type for enforcement failures
     &landlock-error make-landlock-error landlock-error?
@@ -45,12 +48,20 @@
     (foreign-procedure "jerboa_landlock_sandbox"
       (string string string) int))
 
+  (def c-landlock-sandbox-ex
+    (foreign-procedure "jerboa_landlock_sandbox_ex"
+      (string string string int int unsigned-64) int))
+
   ;; ========== Public API ==========
 
   ;; Check if Landlock is supported by the running kernel.
   (def (landlock-available?)
     (>= (c-landlock-abi-version) 1))
 
+  ;; Landlock TCP port restrictions require ABI v4.
+  (def (landlock-net-available?)
+    (>= (c-landlock-abi-version) 4))
+
   ;; Return the Landlock ABI version (1-6+), or -1 if unsupported.
   (def (landlock-abi-version)
     (c-landlock-abi-version))
@@ -84,6 +95,27 @@
                     (make-message-condition
                       "Failed to apply Landlock restrictions"))))))))
 
+  ;; Apply filesystem restrictions and allow TCP connect only to CONNECT-PORT.
+  ;; The network rule is port-based, matching Landlock ABI v4 semantics; callers
+  ;; that need host allowlists should connect through a loopback proxy bound to
+  ;; a fresh random port and enforce host policy in that proxy.
+  (def (landlock-enforce-connect-port! read-paths write-paths exec-paths
+                                       connect-port)
+    (let ((packed-read  (pack-paths read-paths))
+          (packed-write (pack-paths write-paths))
+          (packed-exec  (pack-paths exec-paths)))
+      (let ((ret (c-landlock-sandbox-ex packed-read packed-write packed-exec
+                                        1 2 connect-port)))
+        (cond
+          ((= ret 0) #t)
+          ((= ret 1) 'unsupported)
+          (else
+           (raise (condition
+                    (make-landlock-error
+                      "Landlock filesystem/network enforcement failed")
+                    (make-message-condition
+                      "Failed to apply Landlock restrictions")))))))))
+
   ;; ========== Internal Helpers ==========
 
   ;; Pack a list of path strings with SOH (\x01) separator for C FFI.
diff --git a/lib/std/os/limits/sandbox.ss b/lib/std/os/limits/sandbox.ss
index b0cf3aa..51de84c 100644
--- a/lib/std/os/limits/sandbox.ss
+++ b/lib/std/os/limits/sandbox.ss
@@ -24,6 +24,7 @@
 ;;;   deny-exec-paths  list of execute-denied paths overriding broad grants
 ;;;   net           'allow | 'deny | 'local-only | 'allowlist
 ;;;   net-allow     list of host:port for 'allowlist
+;;;   net-connect-ports list of TCP destination ports allowed by Landlock
 ;;;   syscalls      'unrestricted | 'safe | 'minimal (Linux seccomp hint)
 ;;;   ptrace?       whether the child may be ptraced (defaults #f)
 ;;;   no-new-privs? whether to set PR_SET_NO_NEW_PRIVS (Linux only)
@@ -64,6 +65,8 @@
 
     sandbox-launch
     sandbox-prepare-child!
+    sandbox-child-preexec-needed?
+    sandbox-child-preexec-available?
     sandbox-command-wrapper-needed?
     sandbox-command-wrapper-available?
     sandbox-wrap-command
@@ -127,6 +130,7 @@
        (deny-exec-paths  . ())
        (net           . deny)
        (net-allow     . ())
+       (net-connect-ports . ())
        (syscalls      . safe)
        (ptrace?       . #f)
        (no-new-privs? . #t)))
@@ -134,7 +138,8 @@
   (def *sandbox-policy-keys*
     '(read-paths: write-paths: exec-paths:
       deny-read-paths: deny-write-paths: deny-exec-paths:
-      net: net-allow: syscalls: ptrace?: no-new-privs?:))
+      net: net-allow: net-connect-ports:
+      syscalls: ptrace?: no-new-privs?:))
 
   (def (sandbox-policy . args)
     ;; Accepts keyword args (e.g. `'net: 'deny`) to override individual
@@ -219,7 +224,9 @@
          `((backend  . landlock)
            (fs       . installed)
            (exec     . installed)
-           (net      . degraded)       ;; needs seccomp + cgroup for full
+           (net      . ,(if (linux-landlock-net-available?)
+                            'installed
+                            'degraded))
            (syscalls . installed)      ;; via seccomp
            (ptrace   . installed)
            (limits   . ,(limits-capabilities)))]
@@ -258,6 +265,47 @@
 
   ;; ---------- Child-side preparer ----------
 
+  (def (linux-landlock-abi-version)
+    (try
+      (let ([abi (foreign-procedure "jerboa_landlock_abi_version" () int)])
+        (abi))
+      (catch (e) -1)))
+
+  (def (linux-landlock-net-available?)
+    (>= (linux-landlock-abi-version) 4))
+
+  (def (valid-tcp-port? p)
+    (and (integer? p) (> p 0) (<= p 65535)))
+
+  (def (linux-net-port pol)
+    (let loop ([xs (sandbox-policy-get pol 'net-connect-ports)])
+      (cond
+        [(null? xs) 0]
+        [(valid-tcp-port? (car xs)) (car xs)]
+        [else (loop (cdr xs))])))
+
+  (def (linux-net-mode pol)
+    (case (sandbox-policy-get pol 'net)
+      [(allow) 0]
+      [(deny no-internet) 1]
+      [(local-only allowlist)
+       (if (valid-tcp-port? (linux-net-port pol)) 2 1)]
+      [else 1]))
+
+  (def (linux-net-status-for pol net-install? fs-status)
+    (let ([net (sandbox-policy-get pol 'net)]
+          [port (linux-net-port pol)])
+      (cond
+        [(eq? net 'allow) 'installed]
+        [(not net-install?) 'unavailable]
+        [(not (eq? fs-status 'installed)) fs-status]
+        [(memq net '(deny no-internet)) 'installed]
+        [(and (memq net '(local-only allowlist))
+              (valid-tcp-port? port))
+         'installed]
+        [(memq net '(local-only allowlist)) 'degraded]
+        [else 'degraded])))
+
   (def (sandbox-prepare-child! pol)
     ;; Called inside the forked child, before exec.  Applies the policy
     ;; using whichever backend is available, and returns a report alist
@@ -286,15 +334,25 @@
            [write (sandbox-policy-get pol 'write-paths)]
            [exec  (sandbox-policy-get pol 'exec-paths)]
            [has-denies? (sandbox-policy-has-deny-paths? pol)]
+           [fs-mode (if (sandbox-policy-has-paths? pol) 1 0)]
+           [net-mode (linux-net-mode pol)]
+           [net-port (linux-net-port pol)]
+           [net-install? (or (= net-mode 0)
+                             (linux-landlock-net-available?))]
            [fs-status
             (try
-              (let ([ll-sandbox (foreign-procedure
-                                 "jerboa_landlock_sandbox"
-                                 (string string string) int)])
-                (let ([ret (ll-sandbox (pack-paths read)
-                                       (pack-paths write)
-                                       (pack-paths exec))])
+              (let ([ll-sandbox-ex (foreign-procedure
+                                    "jerboa_landlock_sandbox_ex"
+                                    (string string string int int unsigned-64)
+                                    int)])
+                (let ([ret (ll-sandbox-ex (pack-paths read)
+                                          (pack-paths write)
+                                          (pack-paths exec)
+                                          fs-mode
+                                          (if net-install? net-mode 0)
+                                          net-port)])
                   (cond
+                    [(and (= ret 0) (= fs-mode 0)) 'installed]
                     [(= ret 0) (if has-denies? 'degraded 'installed)]
                     [(= ret 1) 'unavailable]
                     [else 'failed])))
@@ -302,7 +360,7 @@
       `((backend  . landlock)
         (fs       . ,fs-status)
         (exec     . ,fs-status)
-        (net      . ,(net-status-for pol))
+        (net      . ,(linux-net-status-for pol net-install? fs-status))
         (syscalls . degraded))))
 
   (def (prepare-macos! pol)
@@ -389,6 +447,23 @@
         (pair? (sandbox-policy-get pol 'exec-paths))
         (sandbox-policy-has-deny-paths? pol)))
 
+  (def (sandbox-child-preexec-needed? pol)
+    ;; Linux and similar pre-exec backends install policy directly in the
+    ;; already-forked child. This is useful for launchers that own fork/exec
+    ;; and cannot route the command through an external wrapper.
+    (and (platform-linux?)
+         (or (sandbox-policy-has-paths? pol)
+             (sandbox-policy-net-wrapper-needed? pol)
+             (memq (sandbox-policy-get pol 'net) '(deny no-internet)))))
+
+  (def (sandbox-child-preexec-available? pol)
+    (or (not (sandbox-child-preexec-needed? pol))
+        (and (platform-linux?)
+             (>= (linux-landlock-abi-version) 1)
+             (or (not (memq (sandbox-policy-get pol 'net)
+                             '(deny no-internet local-only allowlist)))
+                 (linux-landlock-net-available?)))))
+
   (def (sandbox-command-wrapper-needed? pol)
     ;; Some backends install policy directly in the child between fork and
     ;; exec. macOS path policies are different: they must exec through
diff --git a/support/landlock-shim.c b/support/landlock-shim.c
index d341363..a80a21a 100644
--- a/support/landlock-shim.c
+++ b/support/landlock-shim.c
@@ -54,7 +54,11 @@
 #define LANDLOCK_ACCESS_FS_TRUNCATE     (1ULL << 14)
 #define LANDLOCK_ACCESS_FS_IOCTL_DEV    (1ULL << 15)
 
+#define LANDLOCK_ACCESS_NET_BIND_TCP    (1ULL << 0)
+#define LANDLOCK_ACCESS_NET_CONNECT_TCP (1ULL << 1)
+
 #define LANDLOCK_RULE_PATH_BENEATH 1
+#define LANDLOCK_RULE_NET_PORT 2
 
 struct landlock_ruleset_attr {
     uint64_t handled_access_fs;
@@ -66,6 +70,11 @@ struct landlock_path_beneath_attr {
     int32_t  parent_fd;
 } __attribute__((packed));
 
+struct landlock_net_port_attr {
+    uint64_t allowed_access;
+    uint64_t port;
+};
+
 /* ========== Aggregate Access Masks ========== */
 
 #define ACCESS_FS_READ ( \
@@ -87,6 +96,13 @@ struct landlock_path_beneath_attr {
 
 /* ========== API Functions ========== */
 
+int jerboa_landlock_sandbox_ex(const char *packed_read,
+                               const char *packed_write,
+                               const char *packed_exec,
+                               int fs_mode,
+                               int net_mode,
+                               unsigned long long connect_port);
+
 /* Query Landlock ABI version. Returns version (>=1) or -1 if unsupported. */
 int jerboa_landlock_abi_version(void) {
     int v = syscall(__NR_landlock_create_ruleset, NULL, 0,
@@ -119,6 +135,32 @@ static uint64_t landlock_handled_fs(int abi) {
 int jerboa_landlock_sandbox(const char *packed_read,
                             const char *packed_write,
                             const char *packed_exec) {
+    return jerboa_landlock_sandbox_ex(packed_read, packed_write, packed_exec,
+                                      1, 0, 0);
+}
+
+/*
+ * jerboa_landlock_sandbox_ex — Apply filesystem and/or TCP connect rules.
+ *
+ * fs_mode:
+ *   0 — do not handle filesystem accesses
+ *   1 — apply the same filesystem allowlist as jerboa_landlock_sandbox
+ *
+ * net_mode:
+ *   0 — do not handle network accesses
+ *   1 — deny all TCP connect(2)
+ *   2 — allow TCP connect(2) only to connect_port
+ *
+ * Landlock network rules are port-based (ABI v4+). They cannot match the
+ * destination address, so callers that need host allowlists should pair this
+ * with a loopback proxy on a freshly allocated port.
+ */
+int jerboa_landlock_sandbox_ex(const char *packed_read,
+                               const char *packed_write,
+                               const char *packed_exec,
+                               int fs_mode,
+                               int net_mode,
+                               unsigned long long connect_port) {
     /* 1. Check ABI version */
     int abi = syscall(__NR_landlock_create_ruleset, NULL, 0,
                       LANDLOCK_CREATE_RULESET_VERSION);
@@ -127,12 +169,18 @@ int jerboa_landlock_sandbox(const char *packed_read,
             return 1;  /* unsupported — graceful degradation */
         return -1;
     }
+    if (net_mode != 0 && abi < 4)
+        return 1;  /* network rules require Landlock ABI v4 */
+    if (net_mode == 2 && connect_port == 0)
+        return -1;
 
-    /* 2. Create ruleset handling all known FS access types */
-    uint64_t handled = landlock_handled_fs(abi);
+    /* 2. Create ruleset handling requested access types */
+    uint64_t handled = fs_mode ? landlock_handled_fs(abi) : 0;
+    uint64_t handled_net = net_mode ? LANDLOCK_ACCESS_NET_CONNECT_TCP : 0;
     struct landlock_ruleset_attr attr;
     memset(&attr, 0, sizeof(attr));
     attr.handled_access_fs = handled;
+    attr.handled_access_net = handled_net;
 
     int ruleset_fd = syscall(__NR_landlock_create_ruleset,
                              &attr, sizeof(attr), 0);
@@ -158,57 +206,71 @@ int jerboa_landlock_sandbox(const char *packed_read,
         free(resolved); \
     } while(0)
 
-    /* 3. Always allow read access to essential system paths */
-    ADD_RULE("/usr", ACCESS_FS_READ);
-    ADD_RULE("/lib", ACCESS_FS_READ);
-    ADD_RULE("/lib64", ACCESS_FS_READ);
-    ADD_RULE("/bin", ACCESS_FS_READ);
-    ADD_RULE("/sbin", ACCESS_FS_READ);
-    ADD_RULE("/etc", ACCESS_FS_READ);
-    ADD_RULE("/proc", ACCESS_FS_READ);
-    ADD_RULE("/dev", ACCESS_FS_READ | LANDLOCK_ACCESS_FS_WRITE_FILE);
-
-    /* 4. Parse packed paths and add user rules */
-
-    /* Helper: parse SOH-separated packed paths and add rules */
-    #define PARSE_AND_ADD(packed, access_flags) do { \
-        if ((packed) && (packed)[0]) { \
-            const char *p = (packed); \
-            while (*p) { \
-                const char *end = p; \
-                while (*end && *end != '\001') end++; \
-                int len = (int)(end - p); \
-                if (len > 0 && len < PATH_MAX) { \
-                    char *path = malloc(len + 1); \
-                    if (path) { \
-                        memcpy(path, p, len); \
-                        path[len] = '\0'; \
-                        /* Reject paths with embedded NUL (shouldn't happen, \
-                         * but defense in depth) */ \
-                        if ((int)strlen(path) == len) { \
-                            ADD_RULE(path, access_flags); \
+    if (fs_mode) {
+        /* 3. Always allow read access to essential system paths */
+        ADD_RULE("/usr", ACCESS_FS_READ);
+        ADD_RULE("/lib", ACCESS_FS_READ);
+        ADD_RULE("/lib64", ACCESS_FS_READ);
+        ADD_RULE("/bin", ACCESS_FS_READ);
+        ADD_RULE("/sbin", ACCESS_FS_READ);
+        ADD_RULE("/etc", ACCESS_FS_READ);
+        ADD_RULE("/proc", ACCESS_FS_READ);
+        ADD_RULE("/dev", ACCESS_FS_READ | LANDLOCK_ACCESS_FS_WRITE_FILE);
+
+        /* 4. Parse packed paths and add user rules */
+
+        /* Helper: parse SOH-separated packed paths and add rules */
+        #define PARSE_AND_ADD(packed, access_flags) do { \
+            if ((packed) && (packed)[0]) { \
+                const char *p = (packed); \
+                while (*p) { \
+                    const char *end = p; \
+                    while (*end && *end != '\001') end++; \
+                    int len = (int)(end - p); \
+                    if (len > 0 && len < PATH_MAX) { \
+                        char *path = malloc(len + 1); \
+                        if (path) { \
+                            memcpy(path, p, len); \
+                            path[len] = '\0'; \
+                            /* Reject paths with embedded NUL (shouldn't happen, \
+                             * but defense in depth) */ \
+                            if ((int)strlen(path) == len) { \
+                                ADD_RULE(path, access_flags); \
+                            } \
+                            free(path); \
                         } \
-                        free(path); \
                     } \
+                    p = *end ? end + 1 : end; \
                 } \
-                p = *end ? end + 1 : end; \
             } \
-        } \
-    } while(0)
+        } while(0)
 
-    /* Read-only paths */
-    PARSE_AND_ADD(packed_read, ACCESS_FS_READ);
+        /* Read-only paths */
+        PARSE_AND_ADD(packed_read, ACCESS_FS_READ);
 
-    /* Read+write paths */
-    PARSE_AND_ADD(packed_write, ACCESS_FS_READ | ACCESS_FS_WRITE);
+        /* Read+write paths */
+        PARSE_AND_ADD(packed_write, ACCESS_FS_READ | ACCESS_FS_WRITE);
 
-    /* Execute paths (read + execute) */
-    PARSE_AND_ADD(packed_exec, ACCESS_FS_READ | LANDLOCK_ACCESS_FS_EXECUTE);
+        /* Execute paths (read + execute) */
+        PARSE_AND_ADD(packed_exec, ACCESS_FS_READ | LANDLOCK_ACCESS_FS_EXECUTE);
 
-    #undef PARSE_AND_ADD
+        #undef PARSE_AND_ADD
+    }
 
     #undef ADD_RULE
 
+    if (net_mode == 2) {
+        struct landlock_net_port_attr np;
+        memset(&np, 0, sizeof(np));
+        np.allowed_access = LANDLOCK_ACCESS_NET_CONNECT_TCP;
+        np.port = (uint64_t)connect_port;
+        if (syscall(__NR_landlock_add_rule, ruleset_fd,
+                    LANDLOCK_RULE_NET_PORT, &np, 0) != 0) {
+            close(ruleset_fd);
+            return -1;
+        }
+    }
+
     /* 5. Set no_new_privs (mandatory before landlock_restrict_self) */
     if (prctl(PR_SET_NO_NEW_PRIVS, 1, 0, 0, 0)) {
         close(ruleset_fd);
diff --git a/tests/test-limits-primitives.ss b/tests/test-limits-primitives.ss
index e9dfa13..6183a4c 100644
--- a/tests/test-limits-primitives.ss
+++ b/tests/test-limits-primitives.ss
@@ -544,6 +544,18 @@
     sbpl
     (lambda (s) (string-contains? s "(allow network* (local ip))"))))
 
+(let ([pol (sandbox-policy 'net: 'allowlist
+                           'net-connect-ports: '(43125))])
+  (test "sandbox policy stores Landlock connect ports"
+    (sandbox-policy-get pol 'net-connect-ports)
+    '(43125))
+  (test "sandbox child preexec need is platform-aware"
+    (sandbox-child-preexec-needed? pol)
+    (platform-linux?))
+  (test "sandbox child preexec availability is boolean"
+    (boolean? (sandbox-child-preexec-available? pol))
+    #t))
+
 (let* ([pol (sandbox-policy
              'write-paths: '("/tmp/project")
              'deny-read-paths: '("/tmp/project/secret")