Add musl static binary build (make jcode-musl)
ober
ca8985b7d38f60c0c8ab1588db71f97aef5a91f9
--- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ TUI_SHIM_DIR := $(CURDIR)/vendor/termbox2 NATIVE_LIB_DIR := $(JERBOA_HOME)/lib LDPATH := $(SHIM_DIR):$(TUI_SHIM_DIR):$(SQLITE_LIB_DIR):$(NATIVE_LIB_DIR) -.PHONY: all build gen run test clean repl binary install tui-shim run-tui +.PHONY: all build gen run test clean repl binary install tui-shim run-tui jcode-musl all: build @@ -72,8 +72,17 @@ freebsd: build $(SCHEME) -q --libdirs $(JERBOA_HOME)/lib:./lib:vendor/chez-sqlite/src \ --script build-binary.ss +# ─── musl Static Binary ────────────────────────────────────────────────────── +# Build a fully static jcode binary using musl libc. +# Requires: musl-gcc, Chez Scheme built with musl (~/chez-musl), +# jerboa-native-rs built for x86_64-unknown-linux-musl. + +jcode-musl: gen + @echo "=== Building static jcode with musl ===" + ./build-jcode-musl.sh + clean: find lib/jcode -name "*.sls" -delete 2>/dev/null; true find . -name "*.so" -delete find . -name "*.wpo" -delete - rm -f jcode + rm -f jcode jcode-musl jcode-musl.sha256 new file mode 100755 --- /dev/null +++ b/build-jcode-musl.sh @@ -0,0 +1,69 @@ +#!/bin/bash +# build-jcode-musl.sh — Build jcode as a fully static binary using musl libc +# +# Prerequisites: +# - musl-gcc installed (apt install musl-tools) +# - Chez Scheme built with: ./configure --threads --static CC=musl-gcc +# and installed to ~/chez-musl (or set JERBOA_MUSL_CHEZ_PREFIX) +# - Jerboa libraries compiled +# - jerboa-native-rs built for musl target: +# cd ~/mine/jerboa/jerboa-native-rs && cargo build --release --target x86_64-unknown-linux-musl +# +# The build uses stock scheme (glibc) for the Scheme compilation steps, +# then musl-gcc for the C compilation and linking steps. +set -euo pipefail + +SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)" +HOME_DIR="${HOME:-/root}" +JERBOA_HOME="${JERBOA_HOME:-${HOME_DIR}/mine/jerboa}" +JERBOA_LIB="${JERBOA_HOME}/lib" + +echo "===================================" +echo "Building jcode with musl libc (static)" +echo "===================================" +echo "" +echo "Jerboa: $JERBOA_LIB" +echo "" + +# Check musl availability +if ! command -v musl-gcc &>/dev/null; then + echo "ERROR: musl-gcc not found" + echo "Install: sudo apt install musl-tools" + exit 1 +fi + +# Validate musl toolchain via jerboa +echo "[1/2] Validating musl toolchain via jerboa..." +scheme -q --libdirs "${JERBOA_LIB}" <<'VALIDATE' +(import (chezscheme) (jerboa build musl)) +(let ([result (validate-musl-setup)]) + (printf " ~a: ~a~n" (car result) (cdr result)) + (unless (eq? (car result) 'ok) + (exit 1))) +VALIDATE + +echo "" +echo "[2/2] Running musl build..." + +LD_LIBRARY_PATH="${SCRIPT_DIR}/vendor/chez-sqlite:${SCRIPT_DIR}/vendor/termbox2:${JERBOA_LIB}:." \ +JERBOA_HOME="${JERBOA_HOME}" \ +scheme -q --libdirs "${JERBOA_LIB}:./lib:vendor/chez-sqlite/src" \ + <build-jcode-musl.ss + +# Verify +if [ -f "jcode-musl" ]; then + echo "" + echo "===================================" + echo "jcode-musl built successfully!" + echo "===================================" + ls -lh jcode-musl + echo "" + file jcode-musl + echo "" + ldd jcode-musl 2>&1 || echo " (Fully static - no dependencies)" + echo "" + echo "Test: ./jcode-musl --help" +else + echo "ERROR: jcode-musl not created" + exit 1 +fi new file mode 100644 --- /dev/null +++ b/build-jcode-musl.ss @@ -0,0 +1,510 @@ +#!chezscheme +;;; build-jcode-musl.ss — Build a fully static jcode binary using musl libc +;;; +;;; Usage: scheme -q --libdirs <jerboa-lib>:./lib:vendor/chez-sqlite/src < build-jcode-musl.ss +;;; +;;; This script: +;;; 1. Compiles jcode modules (using stock scheme with glibc) +;;; 2. Creates boot file + optimized program .so +;;; 3. Generates C files with embedded boot data +;;; 4. Compiles C with musl-gcc against musl-built Chez's scheme.h +;;; 5. Links fully static binary with libkernel.a from musl-built Chez +;;; +;;; The resulting jcode-musl binary has zero runtime dependencies. + +(import + (except (chezscheme) void box box? unbox set-box! + andmap ormap iota last-pair find + 1+ 1- fx/ fx1+ fx1- + error error? raise with-exception-handler identifier? + hash-table? make-hash-table) + (jerboa build) + (jerboa build musl)) + +;; ========== Validate musl setup ========== + +(let ([result (validate-musl-setup)]) + (unless (eq? (car result) 'ok) + (printf "Error: ~a~n" (cdr result)) + (printf "~nTo build Chez Scheme with musl:~n") + (printf " cd ~/mine/ChezScheme~n") + (printf " ./configure --threads --static CC=musl-gcc --installprefix=$HOME/chez-musl~n") + (printf " make -j$(nproc) && make install~n") + (exit 1))) + +(printf "musl Chez found: ~a~n~n" (musl-chez-lib-dir)) + +;; ========== Locate directories ========== + +(define home-dir (or (getenv "HOME") "/root")) + +(define jerboa-dir + (let ([jh (getenv "JERBOA_HOME")]) + (if jh + (format "~a/lib" jh) + (format "~a/mine/jerboa/lib" home-dir)))) + +(define jerboa-dir-base + (let ([jh (getenv "JERBOA_HOME")]) + (or jh (format "~a/mine/jerboa" home-dir)))) + +(printf "Jerboa lib: ~a~n" jerboa-dir) + +;; ========== Module list ========== + +(define jcode-modules + '("lib/jcode/core/config" + "lib/jcode/core/log" + "lib/jcode/core/session" + "lib/jcode/core/message" + "lib/jcode/core/agent" + "lib/jcode/core/plugin" + "lib/jcode/provider/provider" + "lib/jcode/tool/registry" + "lib/jcode/tool/file" + "lib/jcode/tool/bash" + "lib/jcode/tool/web" + "lib/jcode/tool/batch" + "lib/jcode/tool/git" + "lib/jcode/tool/lsp" + "lib/jcode/mcp/client" + "lib/jcode/ui/tui-ffi" + "lib/jcode/ui/tui-theme" + "lib/jcode/ui/tui-keys" + "lib/jcode/ui/tui-markdown" + "lib/jcode/ui/tui-diff" + "lib/jcode/ui/tui-message" + "lib/jcode/ui/tui-status" + "lib/jcode/ui/tui-input" + "lib/jcode/ui/tui-sidebar" + "lib/jcode/ui/tui-dialog" + "lib/jcode/ui/tui" + "lib/jcode/ui/cli")) + +;; libc symbols needed by std/net/tcp (already linked in from musl) +(define libc-symbols + '("socket" "bind" "listen" "accept" "connect" "close" + "setsockopt" "read" "write" "htons" "inet_pton" + "getsockname" "fcntl" "__errno_location")) + +;; FFI symbols that need Sforeign_symbol registration +(define ffi-symbols + '(;; chez-sqlite shim + "chez_sqlite_open" "chez_sqlite_close" "chez_sqlite_exec" + "chez_sqlite_prepare" "chez_sqlite_finalize" "chez_sqlite_reset" + "chez_sqlite_clear_bindings" "chez_sqlite_step" + "chez_sqlite_column_count" "chez_sqlite_column_name" + "chez_sqlite_column_type" "chez_sqlite_column_int64" + "chez_sqlite_column_double" "chez_sqlite_column_text" + "chez_sqlite_column_bytes" "chez_sqlite_column_blob" + "chez_sqlite_bind_int64" "chez_sqlite_bind_double" + "chez_sqlite_bind_text" "chez_sqlite_bind_blob" + "chez_sqlite_bind_null" "chez_sqlite_last_insert_rowid" + "chez_sqlite_changes" "chez_sqlite_errmsg" + "chez_SQLITE_ROW" "chez_SQLITE_DONE" "chez_SQLITE_OK" + ;; termbox2 TUI shim + "jcode_tb_init" "jcode_tb_shutdown" + "jcode_tb_width" "jcode_tb_height" + "jcode_tb_clear" "jcode_tb_present" + "jcode_tb_set_cursor" "jcode_tb_hide_cursor" + "jcode_tb_change_cell" "jcode_tb_set_clear_attrs" + "jcode_tb_print" "jcode_tb_printf" + "jcode_tb_set_input_mode" "jcode_tb_set_output_mode" + "jcode_tb_poll_event" "jcode_tb_peek_event" + "jcode_tb_event_type" "jcode_tb_event_mod" + "jcode_tb_event_key" "jcode_tb_event_ch" + "jcode_tb_event_w" "jcode_tb_event_h" + "jcode_tb_event_x" "jcode_tb_event_y" + ;; jerboa-native (TLS/rustls) + "jerboa_tls_server_new" "jerboa_tls_server_new_mtls" + "jerboa_tls_server_free" "jerboa_tls_accept" + "jerboa_tls_connect" "jerboa_tls_connect_pinned" + "jerboa_tls_connect_mtls" "jerboa_tls_close" + "jerboa_tls_read" "jerboa_tls_write" "jerboa_tls_flush" + "jerboa_tls_get_fd" "jerboa_tls_set_nonblock" + "jerboa_last_error")) + +;; ========== Step 0: Clean stale .so/.wpo files ========== + +(printf "[0/7] Cleaning stale .so/.wpo files...~n") +(for-each (lambda (m) + (let ((so (format "~a.so" m)) + (wpo (format "~a.wpo" m))) + (when (file-exists? so) (delete-file so)) + (when (file-exists? wpo) (delete-file wpo)))) + jcode-modules) +(system (format "find ~a -name '*.wpo' -delete 2>/dev/null" jerboa-dir)) + +;; ========== Step 0.5: Patch libraries for static linking ========== + +(printf "[0.5/7] Patching libraries for static linking...~n") + +;; Blanket-patch ALL .sls files to replace (load-shared-object ...) with (void). +;; In static builds, all FFI symbols are pre-registered via Sforeign_symbol — +;; load-shared-object is both unnecessary and unsupported. +;; This matches the approach used in jerboa-shell's musl build. +(printf " Blanket-patching load-shared-object in all libs...~n") +(system (format "find '~a' -name '*.sls' -exec sed -i 's/(load-shared-object[^)]*)/(void)/g' {} +" jerboa-dir)) +(system "find vendor/chez-sqlite -name '*.sls' -exec sed -i 's/(load-shared-object[^)]*)/(void)/g' {} +") +(system "find lib -name '*.sls' -exec sed -i 's/(load-shared-object[^)]*)/(void)/g' {} +") + +;; Fix multi-line load-shared-object in tui-ffi.sls (sed only handles single-line) +(system "perl -0777 -i -pe 's/\\(load-shared-object\\s*\\n\\s*\\(path-join[^)]*\\)\\s*\"[^\"]*\"\\)\\)/(void)/gs' lib/jcode/ui/tui-ffi.sls") + +;; Delete ALL compiled .so in jerboa lib to force recompile with patches +(printf " Deleting stale .so files in all libs...~n") +(system (format "find '~a' -name '*.so' -delete 2>/dev/null" jerboa-dir)) +(system "find vendor/chez-sqlite -name '*.so' -delete 2>/dev/null") +(system "find lib -name '*.so' -delete 2>/dev/null") + +;; ========== Step 1: Compile all modules ========== + +(printf "[1/7] Compiling all modules (optimize-level 3)...~n") +(parameterize ((compile-imported-libraries #t) + (optimize-level 3) + (cp0-effort-limit 500) + (cp0-score-limit 50) + (cp0-outer-unroll-limit 1) + (commonization-level 4) + (enable-unsafe-application #t) + (enable-unsafe-variable-reference #t) + (enable-arithmetic-left-associative #t) + (debug-level 0) + (generate-inspector-information #f)) + (compile-program "main-binary.ss")) + +;; ========== Step 2: Skip WPO for musl builds ========== +;; Use the direct main-binary.so from compile-program. +(printf "[2/7] Skipping WPO (using main-binary.so directly)...~n") +(define program-so "main-binary.so") + +;; ========== Step 3: Pre-compile boot-file dependencies ========== + +(printf "[3/7] Pre-compiling boot dependencies...~n") +(let ([boot-jerboa-modules + '("jerboa/core" "jerboa/runtime" + "std/error" "std/format" "std/sort" "std/pregexp" "std/sugar" + "std/typed" + "std/misc/string" "std/misc/list" "std/misc/alist" "std/misc/thread" + "std/misc/ports" "std/misc/retry" "std/misc/uuid" + "std/os/path" "std/os/shell" + "std/text/json" "std/text/glob" + "std/net/tcp" "std/net/tls-rustls" "std/net/request" + "std/db/sqlite")]) + (parameterize ([compile-imported-libraries #t] + [optimize-level 2] + [generate-inspector-information #f]) + (for-each + (lambda (m) + (let ([sls (format "~a/~a.sls" jerboa-dir m)] + [so (format "~a/~a.so" jerboa-dir m)]) + (when (and (file-exists? sls) (not (file-exists? so))) + (printf " Pre-compiling ~a~n" sls) + (compile-library sls)))) + boot-jerboa-modules))) + +;; ========== Step 4: Create libs-only boot file ========== + +(printf "[4/7] Creating libs-only boot file...~n") + +(define external-libs + (map (lambda (m) (format "~a/~a.so" jerboa-dir m)) + '("jerboa/core" + "jerboa/runtime" + "std/error" + "std/format" + "std/sort" + "std/pregexp" + "std/sugar" + "std/typed" + "std/misc/string" + "std/misc/list" + "std/misc/alist" + "std/misc/thread" + "std/misc/ports" + "std/misc/retry" + "std/misc/uuid" + "std/os/path" + "std/os/shell" + "std/text/json" + "std/text/glob" + "std/net/tcp" + "std/net/tls-rustls" + "std/net/request" + "std/db/sqlite"))) + +(define (existing-so-files paths) + (filter file-exists? paths)) + +(apply make-boot-file "jcode.boot" '("scheme" "petite") + (append + (existing-so-files external-libs) + (list "vendor/chez-sqlite/src/chez-sqlite.so") + (existing-so-files + (map (lambda (m) (format "~a.so" m)) jcode-modules)))) + +;; ========== Step 5: Generate C with embedded boot files + program ========== + +(printf "[5/7] Generating C with embedded boot files + program...~n") + +(define build-dir "/tmp/jerboa-musl-jcode-build") +(system (format "rm -rf '~a' && mkdir -p '~a'" build-dir build-dir)) + +(define musl-lib-dir (musl-chez-lib-dir)) +(define gcc (musl-gcc-path)) +(define scheme-h-dir musl-lib-dir) +(define harden-cflags + (string-append "-ffile-prefix-map=" (current-directory) "=." + " -ffile-prefix-map=" (or (getenv "HOME") "/root") "=~")) + +;; Get boot file paths from musl Chez installation +(define musl-boots (musl-boot-files)) +(define petite-boot-path (cdr (assoc "petite" musl-boots))) +(define scheme-boot-path (cdr (assoc "scheme" musl-boots))) + +;; Generate static_boot.c: embeds petite.boot + scheme.boot + jcode.boot +(define static-boot-c (format "~a/static_boot.c" build-dir)) +(call-with-output-file static-boot-c + (lambda (out) + (display "#include \"scheme.h\"\n\n" out) + (display (file->c-array petite-boot-path "petite_boot") out) + (newline out) + (display (file->c-array scheme-boot-path "scheme_boot") out) + (newline out) + (display (file->c-array "jcode.boot" "jcode_boot") out) + (newline out) + (display "void static_boot_init(void) {\n" out) + (display " Sregister_boot_file_bytes(\"petite\", petite_boot, petite_boot_len);\n" out) + (display " Sregister_boot_file_bytes(\"scheme\", scheme_boot, scheme_boot_len);\n" out) + (display " Sregister_boot_file_bytes(\"jcode\", jcode_boot, jcode_boot_len);\n" out) + (display "}\n" out)) + 'replace) + +;; Rust native library +(define native-lib-path + (format "~a/jerboa-native-rs/target/x86_64-unknown-linux-musl/release/libjerboa_native.a" + jerboa-dir-base)) +(define has-native-lib? (file-exists? native-lib-path)) +(unless has-native-lib? + ;; Fall back to non-musl release build + (set! native-lib-path + (format "~a/jerboa-native-rs/target/release/libjerboa_native.a" jerboa-dir-base)) + (set! has-native-lib? (file-exists? native-lib-path)) + (when has-native-lib? + (printf " Warning: using glibc jerboa-native (not musl target) — binary may not be fully static~n")) + (unless has-native-lib? + (printf " Warning: libjerboa_native.a not found — TLS will be unavailable~n"))) + +;; Generate jcode_main_musl.c +(define program-c (format "~a/jcode_main_musl.c" build-dir)) +(call-with-output-file program-c + (lambda (out) + (display "#define _GNU_SOURCE\n" out) + (display "#include <stdlib.h>\n" out) + (display "#include <string.h>\n" out) + (display "#include <stdio.h>\n" out) + (display "#include <unistd.h>\n" out) + (display "#include <sys/mman.h>\n" out) + (display "#include <sys/types.h>\n" out) + (display "#include <sys/stat.h>\n" out) + (display "#include <fcntl.h>\n" out) + (display "#include <signal.h>\n" out) + (display "#include <errno.h>\n" out) + (display "#include \"scheme.h\"\n\n" out) + ;; dlopen/dlsym stubs for static builds + (display "/* dlopen stubs — override musl's failing stubs in static builds */\n" out) + (display "void *dlopen(const char *filename, int flags) {\n" out) + (display " (void)flags; (void)filename;\n" out) + (display " return (void*)1; /* all symbols pre-registered via Sforeign_symbol */\n" out) + (display "}\n" out) + (display "void *dlsym(void *handle, const char *symbol) {\n" out) + (display " (void)handle; (void)symbol;\n" out) + (display " return NULL; /* symbols found via Sforeign_symbol */\n" out) + (display "}\n" out) + (display "int dlclose(void *handle) { (void)handle; return 0; }\n" out) + (display "char *dlerror(void) { return NULL; }\n\n" out) + ;; Embed program .so + (display (file->c-array program-so "jcode_program_data") out) + (newline out) + ;; Declare static_boot_init + (display "extern void static_boot_init(void);\n\n" out) + ;; Declare FFI symbols (project-specific shims) + (display "/* FFI symbols */\n" out) + (for-each + (lambda (name) (fprintf out "extern void ~a();\n" name)) + ffi-symbols) + (newline out) + ;; libc symbols — proper includes so prototypes match + (display "/* libc symbols for Sforeign_symbol registration */\n" out) + (display "#include <sys/socket.h>\n" out) + (display "#include <netinet/in.h>\n" out) + (display "#include <arpa/inet.h>\n" out) + (newline out) + ;; Register FFI symbols callback + (display "static void register_ffi(void) {\n" out) + (for-each + (lambda (name) + (fprintf out " Sforeign_symbol(\"~a\", (void*)~a);\n" name name)) + ffi-symbols) + ;; Register libc symbols (already in static binary from musl) + (for-each + (lambda (name) + (fprintf out " Sforeign_symbol(\"~a\", (void*)~a);\n" name name)) + libc-symbols) + (display "}\n\n" out) + ;; Main + (display "int main(int argc, char *argv[]) {\n" out) + (display " /* Write program .so to temp file for Sscheme_script */\n" out) + (display " char prog_path[256];\n" out) + (display " const char *tmpdir = getenv(\"TMPDIR\");\n" out) + (display " if (!tmpdir) tmpdir = \"/tmp\";\n" out) + (display " snprintf(prog_path, sizeof(prog_path), \"%s/jcode-XXXXXX\", tmpdir);\n" out) + (display " int fd = mkstemp(prog_path);\n" out) + (display " if (fd < 0) { perror(\"mkstemp\"); return 1; }\n" out) + (display " if (write(fd, jcode_program_data, jcode_program_data_len)\n" out) + (display " != (ssize_t)jcode_program_data_len) {\n" out) + (display " perror(\"write\"); close(fd); unlink(prog_path); return 1;\n" out) + (display " }\n" out) + (display " close(fd);\n\n" out) + (display " /* Prevent load-shared-object in std/net/tcp etc. */\n" out) + (display " setenv(\"JEMACS_STATIC\", \"1\", 1);\n" out) + (display "\n" out) + (display " Sscheme_init(NULL);\n" out) + (display " static_boot_init();\n" out) + (display " Sbuild_heap(NULL, register_ffi);\n" out) + (display " int status = Sscheme_script(prog_path, argc, (const char **)argv);\n" out) + (display " unlink(prog_path);\n" out) + (display " Sscheme_deinit();\n" out) + (display " return status;\n" out) + (display "}\n" out)) + 'replace) + +;; ========== Step 6: Compile C with musl-gcc ========== + +(printf "[6/7] Compiling C with musl-gcc...~n") + +(define (run-cmd cmd) + (printf " ~a~n" cmd) + (unless (= 0 (system cmd)) + (error 'build-jcode-musl "Command failed" cmd))) + +;; Compile static_boot.c +(run-cmd (format "~a -c -O2 ~a -I'~a' -o '~a/static_boot.o' '~a'" + gcc harden-cflags scheme-h-dir + build-dir static-boot-c)) + +;; Compile jcode_main_musl.c +(run-cmd (format "~a -c -O2 ~a -I'~a' -o '~a/jcode_main_musl.o' '~a'" + gcc harden-cflags scheme-h-dir + build-dir program-c)) + +;; Compile chez-sqlite shim +;; Copy sqlite3.h to build dir (can't use -I/usr/include with musl-gcc — glibc conflict) +(let ([shim-src "vendor/chez-sqlite/chez_sqlite_shim.c"] + [sqlite3-h "/usr/include/sqlite3.h"]) + (if (file-exists? shim-src) + (begin + (when (file-exists? sqlite3-h) + (system (format "cp '~a' '~a/'" sqlite3-h build-dir))) + (run-cmd (format "~a -c -O2 ~a -I'~a' -o '~a/chez-sqlite-shim.o' '~a' -Wall" + gcc harden-cflags build-dir build-dir shim-src))) + (begin + (printf " Note: chez-sqlite shim not found — creating stub~n") + (system (format "echo '' | ~a -c -x c -o '~a/chez-sqlite-shim.o' -" gcc build-dir))))) + +;; Compile termbox2 TUI shim +(run-cmd (format "~a -c -O2 ~a -DTB_OPT_ATTR_W=32 -Ivendor/termbox2 -o '~a/jcode-tui-shim.o' src/jcode/ui/jcode_tui_shim.c -Wall" + gcc harden-cflags build-dir)) + +;; Compile landlock shim from jerboa +(let ([landlock-src (format "~a/support/landlock-shim.c" jerboa-dir-base)]) + (if (file-exists? landlock-src) + (run-cmd (format "~a -c -O2 ~a -o '~a/landlock-shim.o' '~a' -Wall" + gcc harden-cflags build-dir landlock-src)) + (begin + (printf " Note: landlock-shim.c not found — creating stub~n") + (system (format "echo '' | ~a -c -x c -o '~a/landlock-shim.o' -" gcc build-dir))))) + +;; ========== Step 7: Link static binary ========== + +(printf "[7/7] Linking static jcode-musl binary...~n") + +(let ([link-cmd (apply musl-link-command + "jcode-musl" + (list (format "~a/jcode_main_musl.o" build-dir) + (format "~a/static_boot.o" build-dir) + (format "~a/chez-sqlite-shim.o" build-dir) + (format "~a/jcode-tui-shim.o" build-dir) + (format "~a/landlock-shim.o" build-dir)) + ;; Rust native lib includes sqlite3, TLS (rustls), regex, etc. + (if has-native-lib? + (list native-lib-path) + (list "/usr/lib/x86_64-linux-gnu/libsqlite3.a")) + '(no-harden: #t))]) + ;; GCC 13+ libgcc_eh.a references _dl_find_object (glibc 2.35+) which + ;; doesn't exist in musl. Stub it out with --defsym. + (run-cmd (string-append link-cmd + " -Wl,--allow-multiple-definition" + " -Wl,--defsym=_dl_find_object=0"))) + +;; ========== Hardening: strip + integrity hash ========== + +(when (file-exists? "jcode-musl") + (printf "~n[harden] Stripping symbols...~n") + (let ([pre-size (file-length (open-file-input-port "jcode-musl"))]) + (run-cmd "strip --strip-all jcode-musl") + (when (= 0 (system "objcopy --strip-section-headers jcode-musl 2>/dev/null")) + (printf " Section headers removed~n")) + (let ([post-size (file-length (open-file-input-port "jcode-musl"))]) + (printf " Stripped: ~a → ~a bytes (~a% reduction)~n" + pre-size post-size + (inexact->exact (round (* 100 (/ (- pre-size post-size) pre-size)))))))) + +;; Compute SHA-256 integrity hash +(when (file-exists? "jcode-musl") + (printf "[harden] Computing integrity hash...~n") + (system "sha256sum jcode-musl | cut -d' ' -f1 | tr -d '\\n' > /tmp/_jcode_hash.txt") + (let ([hash-hex (call-with-input-file "/tmp/_jcode_hash.txt" get-string-all)]) + (system "rm -f /tmp/_jcode_hash.txt") + (printf " SHA-256: ~a~n" hash-hex) + (when (= (string-length hash-hex) 64) + (let ([bv (make-bytevector 32)]) + (do ([i 0 (+ i 1)]) + ((= i 32)) + (bytevector-u8-set! bv i + (string->number (substring hash-hex (* i 2) (+ (* i 2) 2)) 16))) + (let ([port (open-file-output-port "jcode-musl.sha256" (file-options no-fail))]) + (put-bytevector port bv) + (close-port port)) + (printf " Wrote jcode-musl.sha256 (32 bytes)~n"))))) + +;; ========== Restore patched files ========== + +(printf "~n[cleanup] Restoring patched files...~n") +;; Restore blanket-patched jerboa lib via git checkout +(system (format "cd '~a' && git checkout -- ." jerboa-dir-base)) +;; Restore patched local files +(system "git checkout -- lib/jcode/") +(system "cd vendor/chez-sqlite && git checkout -- src/chez-sqlite.sls") + +;; Cleanup build dir +(system (format "rm -rf '~a'" build-dir)) + +;; Clean up .so and .wpo from compile-imported-libraries +(for-each (lambda (m) + (let ((so (format "~a.so" m)) + (wpo (format "~a.wpo" m))) + (when (file-exists? so) (delete-file so)) + (when (file-exists? wpo) (delete-file wpo)))) + jcode-modules) +(for-each (lambda (f) + (when (file-exists? f) (delete-file f))) + '("main-binary.so" "main-binary.wpo" "jcode.boot")) + +;; Summary +(printf "~n========================================~n") +(printf "Static binary created: jcode-musl~n~n") +(system "ls -lh jcode-musl") +(printf "~n") +(system "file jcode-musl") +(printf "~nTest: ./jcode-musl --help~n") --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -9,6 +9,8 @@ (import :std/text/json :std/net/request + :std/net/tls-rustls + :std/net/tcp :std/misc/string :std/misc/retry :jcode/core/log @@ -80,14 +82,238 @@ (callback response) response)) -;;; HTTP POST via (std net request) ;;; - +;;; HTTPS-capable HTTP POST ;;; +;;; Uses rustls for https:// and raw tcp for http:// + +;; Parse URL into (scheme host port path) +(def (parse-url-parts url) + (let ((parts (parse-url url))) + (values (url-parts-scheme parts) + (url-parts-host parts) + (url-parts-port parts) + (url-parts-path parts)))) + +;; Build raw HTTP request string +(def (build-http-request method path host headers body-str) + (let ((out (open-output-string))) + (put-string out (string-append method " " path " HTTP/1.1\r\n")) + (put-string out (string-append "Host: " host "\r\n")) + (for-each (lambda (h) + (put-string out (string-append (car h) ": " (cdr h) "\r\n"))) + headers) + (when body-str + (let ((bv (string->utf8 body-str))) + (put-string out (string-append "Content-Length: " (number->string (bytevector-length bv)) "\r\n")))) + (put-string out "\r\n") + (when body-str (put-string out body-str)) + (get-output-string out))) + +;; TLS I/O: write full string via rustls +(def (tls-write-string conn s) + (let ((bv (string->utf8 s))) + (let loop ((offset 0)) + (when (< offset (bytevector-length bv)) + (let* ((remaining (- (bytevector-length bv) offset)) + (chunk (if (> remaining 4096) + (let ((c (make-bytevector 4096))) + (bytevector-copy! bv offset c 0 4096) c) + (let ((c (make-bytevector remaining))) + (bytevector-copy! bv offset c 0 remaining) c))) + (n (rustls-write conn chunk (bytevector-length chunk)))) + (when (< n 0) (error 'tls-write-string "TLS write failed")) + (loop (+ offset n))))) + (rustls-flush conn))) + +;; TLS I/O: read one line (up to \n). Returns string or #f on EOF. +(def (tls-read-line conn) + (let ((out (open-output-string)) + (buf (make-bytevector 1)) + (got-any #f)) + (let loop () + (let ((n (rustls-read conn buf 1))) + (cond + ((<= n 0) + (if got-any (get-output-string out) #f)) + (else + (set! got-any #t) + (let ((ch (integer->char (bytevector-u8-ref buf 0)))) + (if (char=? ch #\newline) + (let ((s (get-output-string out))) + ;; Strip trailing \r + (if (and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\return)) + (substring s 0 (- (string-length s) 1)) + s)) + (begin (write-char ch out) (loop)))))))))) + +;; TLS I/O: read exactly n bytes as string +(def (tls-read-n conn n) + (let ((result (make-bytevector n)) + (buf (make-bytevector 4096))) + (let loop ((offset 0)) + (if (>= offset n) (utf8->string result) + (let* ((want (min 4096 (- n offset))) + (got (rustls-read conn buf want))) + (cond + ((<= got 0) (utf8->string (let ((r (make-bytevector offset))) + (bytevector-copy! result 0 r 0 offset) r))) + (else (bytevector-copy! buf 0 result offset got) + (loop (+ offset got))))))))) + +;; TLS I/O: read until EOF +(def (tls-read-all conn) + (let ((out (open-output-string)) + (buf (make-bytevector 4096))) + (let loop () + (let ((n (rustls-read conn buf 4096))) + (if (<= n 0) (get-output-string out) + (begin + (put-string out (utf8->string + (let ((r (make-bytevector n))) + (bytevector-copy! buf 0 r 0 n) r))) + (loop))))))) + +;; Parse HTTP status line "HTTP/1.1 200 OK" -> 200 +(def (parse-http-status line) + (if (and (string? line) (> (string-length line) 12)) + (or (string->number (substring line 9 12)) 0) + 0)) + +;; Parse headers until blank line, returns alist +(def (read-tls-headers conn) + (let loop ((headers '())) + (let ((line (tls-read-line conn))) + (if (or (not line) (string-empty? line)) + (reverse headers) + (let ((colon (string-contains line ":"))) + (if colon + (loop (cons (cons (string-downcase (substring line 0 colon)) + (string-trim (substring line (+ colon 1) (string-length line)))) + headers)) + (loop headers))))))) + +;; TCP port I/O: write string, read line, read all +(def (port-write-string out s) + (put-string out s) + (flush-output-port out)) + +(def (port-read-line in) + (let ((out (open-output-string))) + (let loop () + (let ((c (read-char in))) + (cond + ((eof-object? c) (get-output-string out)) + ((char=? c #\newline) + (let ((s (get-output-string out))) + (if (and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\return)) + (substring s 0 (- (string-length s) 1)) + s))) + (else (write-char c out) (loop))))))) + +(def (port-read-headers in) + (let loop ((headers '())) + (let ((line (port-read-line in))) + (if (or (string-empty? line) (equal? line "")) + (reverse headers) + (let ((colon (string-contains line ":"))) + (if colon + (loop (cons (cons (string-downcase (substring line 0 colon)) + (string-trim (substring line (+ colon 1) (string-length line)))) + headers)) + (loop headers))))))) + +(def (port-read-all in) + (let ((out (open-output-string))) + (let loop () + (let ((c (read-char in))) + (if (eof-object? c) (get-output-string out) + (begin (write-char c out) (loop))))))) + +;; Generic HTTP POST with JSON body, returns (values status body-string) (def (http-post-json url headers body-json) - (let* ((resp (http-post url headers body-json)) - (status (request-status resp)) - (body (request-text resp))) - (request-close resp) - (values status body))) + (let-values (((scheme host port path) (parse-url-parts url))) + (let ((req (build-http-request "POST" path host headers body-json))) + (if (equal? scheme "https") + ;; HTTPS via rustls + (let ((conn (rustls-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (tls-write-string conn req) + (let* ((status-line (tls-read-line conn)) + (status (parse-http-status status-line)) + (resp-headers (read-tls-headers conn)) + (cl (assoc "content-length" resp-headers)) + (body (if cl + (tls-read-n conn (string->number (cdr cl))) + (tls-read-all conn)))) + (values status body))) + (lambda () (rustls-close conn)))) + ;; Plain HTTP via tcp + (let-values (((in out) (tcp-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (port-write-string out req) + (let* ((status-line (port-read-line in)) + (status (parse-http-status status-line)) + (resp-headers (port-read-headers in)) + (body (port-read-all in))) + (values status body))) + (lambda () + (close-port in) + (close-port out)))))))) + +;; Streaming HTTP POST: calls line-cb with each line of the response body. +;; Used for SSE (Server-Sent Events) streaming from LLM APIs. +(def (http-post-stream url headers body-json line-cb) + (let-values (((scheme host port path) (parse-url-parts url))) + (let ((req (build-http-request "POST" path host headers body-json))) + (if (equal? scheme "https") + ;; HTTPS via rustls + (let ((conn (rustls-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (tls-write-string conn req) + (let* ((status-line (tls-read-line conn)) + (status (parse-http-status status-line)) + (_headers (read-tls-headers conn))) + (unless (= status 200) + (let ((body (tls-read-all conn))) + (error 'http-post-stream + (format "API error ~a: ~a" status body)))) + ;; Read SSE lines until EOF + (let loop () + (let ((line (tls-read-line conn))) + (when line + (line-cb line) + (loop)))))) + (lambda () (rustls-close conn)))) + ;; Plain HTTP via tcp + (let-values (((in out) (tcp-connect host port))) + (dynamic-wind + (lambda () (void)) + (lambda () + (port-write-string out req) + (let* ((status-line (port-read-line in)) + (status (parse-http-status status-line)) + (_headers (port-read-headers in))) + (unless (= status 200) + (let ((body (port-read-all in))) + (error 'http-post-stream + (format "API error ~a: ~a" status body)))) + ;; Read SSE lines + (let loop () + (let ((c (peek-char in))) + (unless (eof-object? c) + (let ((line (port-read-line in))) + (line-cb line) + (loop))))))) + (lambda () + (close-port in) + (close-port out)))))))) ;;; OpenAI-compatible API ;;;