Make jerbuild self-contained for package builds
ober
b1115d0b1b8634103946c5de496911348f12e0aa
--- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -4569,4 +4569,15 @@ "std-net-http" "startup") ("title" . - "Ensure libjerboa_native exists before building a Jerboa MCP server that uses HTTP"))) + "Ensure libjerboa_native exists before building a Jerboa MCP server that uses HTTP")) + (("code" + . + ";; .jerbuild\n(entry \"bin/tool.ss\")\n(output \"tool\")\n(requires \"cc\" \"cargo\")\n(libdirs \"lib\")\n(rust-crates\n (\"@bundle/jerboa-native-rs/Cargo.toml\" features: \"tls,sqlite,crypto\"))") ("id" . "jerbuild-bundled-native-crate") ("imports") + ("notes" + . + "Use @bundle/jerboa-native-rs/Cargo.toml when a package must build from a downloaded jerbuild/jerboa binary without a sibling checkout of the main Jerboa repo. The standalone and multicall jerbuild binaries set JERBUILD_BUNDLE_DIR before loading .jerbuild, so @bundle paths resolve to the extracted embedded stdlib/native crate bundle. Pick only the native features the package needs.") + ("tags" "jerbuild" "rust-crates" "bundle" "native" + "Cargo.toml" "standalone") + ("title" + . + "Use jerbuild's bundled native Rust crate from .jerbuild"))) --- a/jerbuild.ss +++ b/jerbuild.ss @@ -69,6 +69,31 @@ (and (>= slen plen) (string=? (substring str 0 plen) prefix)))) +(define (read-file-contents path) + (call-with-input-file path + (lambda (port) + (let ([p (open-output-string)]) + (let loop () + (let ([ch (read-char port)]) + (unless (eof-object? ch) + (write-char ch p) + (loop)))) + (get-output-string p))))) + +(define (strip-leading-shebang str) + ;; `read` accepts #!chezscheme but not Unix env shebangs such as + ;; #!/usr/bin/env scheme-script. For classification/wrapping, the shebang + ;; is launcher metadata rather than Scheme source. + (if (string-starts-with? str "#!") + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(>= i len) ""] + [(char=? (string-ref str i) #\newline) + (substring str (+ i 1) len)] + [else (loop (+ i 1))]))) + str)) + ;;;; ============================================================ ;;;; Path computation ;;;; ============================================================ @@ -344,15 +369,7 @@ ;; Read all top-level S-expressions from a .ss file. ;; Preprocesses Jerboa/Chez bracket syntax [x y z] → (x y z) ;; and hash-bang datums (#!void, #!eof). - (let* ([raw (call-with-input-file path - (lambda (port) - (let ([p (open-output-string)]) - (let loop () - (let ([ch (read-char port)]) - (unless (eof-object? ch) - (write-char ch p) - (loop)))) - (get-output-string p))))] + (let* ([raw (strip-leading-shebang (read-file-contents path))] [processed (preprocess-brackets raw)] [port (open-input-string processed)]) (let loop ([forms '()]) @@ -776,19 +793,52 @@ (define (entry-imports-chez? import-specs) (and (find chez-base-lib? (map unwrap-import-lib import-specs)) #t)) +(define *known-chez-import-conflicts* + '(((jerboa prelude) + make-hash-table hash-table? sort sort! printf fprintf format + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- partition + make-date make-time meta atom?) + ((jerboa prelude clean) + make-hash-table hash-table? sort sort! printf fprintf format + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- partition + make-date make-time meta atom?) + ((std format) format printf fprintf))) + +(define (known-conflicts-for-lib lib) + (let ([hit (assoc lib *known-chez-import-conflicts*)]) + (if hit (cdr hit) '()))) + +(define (maybe-copy-shebangless-entry entry obj-dir) + ;; compile-program may see a plain Unix shebang before Chez's script runner + ;; has a chance to consume it. If present, compile a temporary shebangless + ;; copy; otherwise preserve the original path for clearer diagnostics. + (let ([raw (read-file-contents entry)]) + (if (string-starts-with? raw "#!") + (let ([out (format "~a/jerboa-entry-shebangless.ss" obj-dir)]) + (call-with-output-file out + (lambda (port) + (display "#!chezscheme\n" port) + (display (strip-leading-shebang raw) port)) + 'replace) + out) + entry))) + (define (spec-conflict-candidates spec chez-set) ;; Names this user import spec brings in that ALSO exist in (chezscheme), ;; i.e. would clash when (chezscheme) is also imported. Honours import - ;; sub-forms; (prefix ...) never clashes. Unknown/unfound libs contribute - ;; nothing (guarded) — compile-program will surface a real missing-lib error. + ;; sub-forms; (prefix ...) never clashes. Avoid loading project libraries + ;; here: doing so installs them in Chez's library table before WPO compile, + ;; making compile-whole-program unable to find the .wpo it expected to emit. (define (intersect names) (filter (lambda (s) (memq s chez-set)) names)) (cond [(and (pair? spec) (eq? (car spec) 'only)) (intersect (cddr spec))] [(and (pair? spec) (eq? (car spec) 'prefix)) '()] [(and (pair? spec) (eq? (car spec) 'rename)) (intersect (map cadr (cddr spec)))] - [else - (guard (e [#t '()]) - (intersect (environment-symbols (environment (unwrap-import-lib spec)))))])) + [else (intersect (known-conflicts-for-lib (unwrap-import-lib spec)))])) (define (maybe-wrap-jerboa-entry entry obj-dir) ;; Returns the path to feed to compile-program: a generated #!chezscheme @@ -797,7 +847,8 @@ (let ([forms (read-source-file entry)]) (let-values ([(exports imports body) (classify-forms forms)]) (cond - [(or (null? imports) (entry-imports-chez? imports)) entry] + [(or (null? imports) (entry-imports-chez? imports)) + (maybe-copy-shebangless-entry entry obj-dir)] [else (let* ([chez-set (environment-symbols (environment '(chezscheme)))] [conflicts (delete-duplicates @@ -1481,6 +1532,58 @@ [(string-ends-with? s "le") "-lm -ldl -lpthread -lncurses"] [else "-lm -lpthread -lncurses"]))) +(define (machine-type->os-name mt) + (let ([s (symbol->string mt)]) + (cond + [(string-ends-with? s "osx") "Darwin"] + [(string-ends-with? s "fb") "FreeBSD"] + [(string-ends-with? s "le") "Linux"] + [(string-ends-with? s "nt") "Windows"] + [else "Unknown"]))) + +(define (selector->string selector) + (cond + [(symbol? selector) (symbol->string selector)] + [(string? selector) selector] + [else (error 'jerbuild + (format "config: OS selector must be symbol or string, got ~a" + selector))])) + +(define (os-selector-matches? selector os-name) + (let ([s (selector->string selector)]) + (or (string-ci=? s os-name) + (string-ci=? s "else") + (string-ci=? s "default") + (string=? s "*")))) + +(define (select-os-string key clauses) + ;; Accept (key "flags") or (key (Darwin "flags") (Linux "flags") ...). + (cond + [(and (= (length clauses) 1) (string? (car clauses))) + (car clauses)] + [else + (let ([os-name (machine-type->os-name (machine-type))]) + (let loop ([xs clauses] [fallback #f]) + (cond + [(null? xs) + (or fallback + (error 'jerbuild + (format "config: ~a has no clause for ~a" key os-name)))] + [else + (let ([clause (car xs)]) + (unless (and (pair? clause) + (pair? (cdr clause)) + (null? (cddr clause)) + (string? (cadr clause))) + (error 'jerbuild + (format "config: bad ~a clause: ~a" key clause))) + (if (os-selector-matches? (car clause) os-name) + (cadr clause) + (loop (cdr xs) + (if (os-selector-matches? (car clause) "default") + (cadr clause) + fallback))))])))])) + (define (parse-cc-flag args) ;; Scan for --cc <prog> (or --cc=<prog>). Returns (values cc remaining). (let loop ([args args] [cc #f] [acc '()]) @@ -2235,6 +2338,10 @@ int main(int argc, const char *argv[]) { ;; ("ssh.c" cflags: "-DNO_OPENSSL")) ; per-source CFLAGS ;; (extra-archives "vendor/lib.a") ; optional ;; (extra-ldflags "-framework" "Security") ; optional, raw strings +;; (os-libs "-lm -lpthread ...") ; optional full OS link flag override +;; (os-libs ; or host OS selection +;; (Darwin "-lm -lpthread -lncurses -liconv") +;; (Linux "-lm -ldl -lpthread -lncurses")) ;; (main-c "support/main.c") ; optional; replaces stock main.c. ;; ; May still use (ffi-symbols ...) — ;; ; user main.c should #include @@ -2301,7 +2408,16 @@ int main(int argc, const char *argv[]) { (char=? (string-ref p 0) #\/))) (define (resolve-config-path p base) - (if (absolute-path? p) p (format "~a/~a" base p))) + (cond + [(string-starts-with? p "@bundle/") + (let ([bundle (getenv "JERBUILD_BUNDLE_DIR")]) + (unless (and bundle (> (string-length bundle) 0)) + (error 'jerbuild + (format "config: ~a needs JERBUILD_BUNDLE_DIR (run via jerbuild binary)" + p))) + (format "~a/~a" bundle (substring p 8 (string-length p))))] + [(absolute-path? p) p] + [else (format "~a/~a" base p)])) (define (find-keyword key plist) ;; Property-list lookup: (k1: v1 k2: v2) -> v1 for k1:. @@ -2410,9 +2526,7 @@ int main(int argc, const char *argv[]) { (error 'jerbuild "config: (xpatch PATH) takes one value")) (set! xpatch (resolve-config-path (cadr form) base))] [(os-libs) - (unless (= (length form) 2) - (error 'jerbuild "config: (os-libs STR) takes one string value")) - (set! os-libs (cadr form))] + (set! os-libs (select-os-string 'os-libs (cdr form)))] [(requires notes) ;; Documentation-only forms for standalone .jerbuild manifests. (void)] @@ -2537,6 +2651,8 @@ int main(int argc, const char *argv[]) { (let ([args (command-line-arguments)]) (cond + [(null? args) + (run-build '())] [(and (pair? args) (string=? (car args) "exec")) (run-exec (cdr args))] [(and (pair? args) (string=? (car args) "compile")) --- a/lib/std/csp/fiber-chan.ss +++ b/lib/std/csp/fiber-chan.ss @@ -70,6 +70,7 @@ ;; ========================================================================= (defstruct fiber-csp-chan (inner kind)) + (def fiber-csp-chan make-fiber-csp-chan) ;; ========================================================================= ;; Constructors --- a/support/build-jerboa-multicall.ss +++ b/support/build-jerboa-multicall.ss @@ -376,6 +376,8 @@ (define stage (format "~a/stage" build-dir)) (run (format "cd ~a && find lib/jerboa lib/std \\( -name '*.ss' -o -name '*.sls' \\) -type f | sort | tar -cf ~a -T -" (shell-quote repo) (shell-quote bundle-tar))) +(run (format "cd ~a && find jerboa-native-rs -path jerboa-native-rs/target -prune -o -path jerboa-native-rs/.git -prune -o -type f -print | sort | tar -rf ~a -T -" + (shell-quote repo) (shell-quote bundle-tar))) (run (format "rm -rf ~a && mkdir -p ~a/lib" (shell-quote stage) (shell-quote stage))) (run (format "cd ~a && find . \\( -name '*.so' -o -name '*.wpo' \\) -type f ! -name 'program.so' ! -name 'program.wpo' ! -name 'program.wp.so' | tar -cf - -T - | (cd ~a/lib && tar -xf -)" (shell-quote obj-dir) (shell-quote stage))) --- a/support/build-jerbuild.sh +++ b/support/build-jerbuild.sh @@ -133,7 +133,7 @@ JERBOA_XPATCH="$JERBOA_XPATCH" "$SCHEME" --libdirs "$JERBOA_HOME/lib" \ jerbuild.ss "$WPO_SO" "$OBJ_DIR" echo "" -echo "==> [2/5] Tarball lib/jerboa + lib/std (source files only) + csv kernel files" +echo "==> [2/5] Tarball stdlib + bundled native crate + csv kernel files" # Only .ss and .sls — strip cached .so/.wpo build artifacts. # Use find + cpio piping so we don't depend on GNU tar features. (cd "$JERBOA_HOME" && find lib/jerboa lib/std \ @@ -141,6 +141,15 @@ echo "==> [2/5] Tarball lib/jerboa + lib/std (source files only) + csv kernel fi | sort \ | tar -cf "$BUNDLE_TAR" -T -) +# Include the Rust native crate source so package manifests can refer to +# @bundle/jerboa-native-rs/Cargo.toml without requiring a Jerboa checkout. +(cd "$JERBOA_HOME" && find jerboa-native-rs \ + -path jerboa-native-rs/target -prune -o \ + -path jerboa-native-rs/.git -prune -o \ + -type f -print \ + | sort \ + | tar -rf "$BUNDLE_TAR" -T -) + # Bundle the .so/.wpo files compiled into OBJ_DIR during step 1. These # correspond to libraries that jerbuild's WPO image internalized (e.g. # (jerboa core), (std misc string)). When user code in `jerbuild binary` @@ -344,6 +353,7 @@ int main(int argc, const char *argv[]) { strcmp(argv[1], "--help") == 0)) { fputs( "Usage:\n" + " jerbuild # read .jerbuild, build\n" " jerbuild <src> <lib> # transpile .ss -> .sls\n" " jerbuild transpile <src> <lib> [--force]\n" " jerbuild compile --libdirs <p> [--wpo] FILE...\n" @@ -369,8 +379,10 @@ int main(int argc, const char *argv[]) { * libkernel.a/scheme.h on disk so the Scheme handler can embed + link * them. Pre-extract the bundle and expose the path via env so the * Scheme side can find them. */ - if (argc >= 2 && (strcmp(argv[1], "binary") == 0 || - strcmp(argv[1], "build") == 0)) { + if (argc == 1 || + (argc >= 2 && (strcmp(argv[1], "binary") == 0 || + strcmp(argv[1], "build") == 0 || + strcmp(argv[1], "check") == 0))) { setenv("JERBUILD_BUNDLE_DIR", ensure_extracted(), 1); } --- a/support/multicall-main.c +++ b/support/multicall-main.c @@ -177,6 +177,7 @@ static int self_exe_path(char *buf, size_t n) { static const char JERBUILD_USAGE[] = "Usage:\n" + " jerbuild # read .jerbuild, build\n" " jerbuild <src> <lib> # transpile .ss -> .sls\n" " jerbuild transpile <src> <lib> [--force]\n" " jerbuild compile --libdirs <p> [--wpo] FILE...\n" @@ -233,7 +234,7 @@ int main(int argc, const char *argv[]) { fputs(JERBUILD_USAGE, stdout); return 0; } - if (a1 && (!strcmp(a1, "binary") || !strcmp(a1, "build"))) + if (!a1 || !strcmp(a1, "binary") || !strcmp(a1, "build") || !strcmp(a1, "check")) setenv("JERBUILD_BUNDLE_DIR", ensure_extracted(), 1); }