46c9c7b4d9
^C to a running `joltc --nrepl-server` aborted with "thread does not own mutex" because the accept-loop thread absorbed SIGINT in its foreign accept() call, where Chez can't run the keyboard-interrupt handler, and run-main-pump's tight condition-wait loop wasn't interruptible anyway. Block SIGINT in the primordial thread before starting the server so the accept loop inherits a blocked mask, park in a single interruptible condition-wait via the new park-until-interrupt, and run registered shutdown hooks (newest-first, each isolated) from the keyboard-interrupt handler before (exit 0). The stop fn now drops .nrepl-port via the new jolt.host/delete-file seam — clojure.java.io/delete-file doesn't exist in Jolt and silently no-ops, so .nrepl-port was never removed.
260 lines
13 KiB
Clojure
260 lines
13 KiB
Clojure
(ns jolt.nrepl
|
|
"A minimal, extensible nREPL server for jolt, so an editor (CIDER / Calva /
|
|
Cursive) can connect and develop a project live. Speaks bencode over a loopback
|
|
TCP socket bound through jolt.ffi. Built in: clone, describe, eval, load-file,
|
|
close — enough to connect and eval, with the project's deps on the roots and
|
|
native libs loaded (jolt.main applies the project first), so (require '[lib])
|
|
works.
|
|
|
|
EXTENSIBLE: a library can add the heavier nREPL features (sessions,
|
|
interruptible-eval, completion, lookup) as MIDDLEWARE without bloating core. A
|
|
middleware is `(fn [handler] (fn [request] ...))`; list them in deps.edn under
|
|
:nrepl/middleware (symbols resolving to a middleware fn, or to a vector of them)
|
|
and jolt.nrepl composes them over the built-in handler. The request is the
|
|
decoded bencode map (string keys: \"op\" \"code\" \"ns\" \"id\" \"session\" …)
|
|
plus :reply — a thread-safe (fn [response-map]) that adds id/session and sends.
|
|
Public seam for middleware: respond, evaluate, register-ops!, new-session.
|
|
|
|
Writes .nrepl-port in the project dir so editors auto-detect the port."
|
|
(:require [clojure.string :as str]
|
|
[clojure.java.io :as io]
|
|
[jolt.ffi :as ffi]))
|
|
|
|
;; --- sockets (loopback server) ---------------------------------------------
|
|
;; Load libc (the running process's symbols) BEFORE the foreign-fn bindings below
|
|
;; — defcfn resolves the C entry point when the def is evaluated (at ns load), so
|
|
;; the socket symbols must already be available.
|
|
(ffi/load-library)
|
|
(ffi/defcfn c-socket "socket" [:int :int :int] :int)
|
|
(ffi/defcfn c-bind "bind" [:int :pointer :int] :int)
|
|
(ffi/defcfn c-listen "listen" [:int :int] :int)
|
|
(ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int)
|
|
(ffi/defcfn c-accept "accept" [:int :pointer :pointer] :int :blocking)
|
|
(ffi/defcfn c-recv "recv" [:int :pointer :size_t :int] :ssize_t :blocking)
|
|
(ffi/defcfn c-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
|
|
(ffi/defcfn c-close "close" [:int] :int)
|
|
|
|
(def ^:private AF-INET 2)
|
|
(def ^:private SOCK-STREAM 1)
|
|
(def ^:private macos?
|
|
(str/includes? (str/lower-case (or (System/getProperty "os.name") "")) "mac"))
|
|
(def ^:private sol-socket (if macos? 0xffff 1))
|
|
(def ^:private so-reuse (if macos? 4 2))
|
|
|
|
(defn- make-sockaddr [port]
|
|
(let [sa (ffi/alloc 16)]
|
|
(dotimes [i 16] (ffi/write sa :uint8 i 0))
|
|
(if macos?
|
|
(do (ffi/write sa :uint8 0 16) (ffi/write sa :uint8 1 AF-INET))
|
|
(ffi/write sa :uint8 0 AF-INET))
|
|
(ffi/write sa :uint8 2 (bit-and (bit-shift-right port 8) 0xff))
|
|
(ffi/write sa :uint8 3 (bit-and port 0xff))
|
|
(ffi/write sa :uint8 4 127) (ffi/write sa :uint8 7 1) ; 127.0.0.1
|
|
sa))
|
|
|
|
(defn- listen-socket [port]
|
|
(ffi/load-library) ; libc process symbols
|
|
(let [fd (c-socket AF-INET SOCK-STREAM 0)]
|
|
(when (neg? fd) (throw (ex-info "socket() failed" {})))
|
|
(let [opt (ffi/alloc 4)] (ffi/write opt :int 0 1) (c-setsockopt fd sol-socket so-reuse opt 4) (ffi/free opt))
|
|
(let [sa (make-sockaddr port)]
|
|
(when (neg? (c-bind fd sa 16)) (c-close fd) (ffi/free sa) (throw (ex-info (str "bind() failed on port " port) {})))
|
|
(ffi/free sa))
|
|
(when (neg? (c-listen fd 16)) (c-close fd) (throw (ex-info "listen() failed" {})))
|
|
fd))
|
|
|
|
;; bytes flow as latin1 strings on the wire (1 char = 1 byte). Text fields that
|
|
;; may carry unicode (code / value / out) convert at the boundary.
|
|
(defn- ->wire [s] (String. (.getBytes (str s) "UTF-8") "ISO-8859-1"))
|
|
(defn- wire-> [s] (String. (byte-array (map int s)) "UTF-8"))
|
|
|
|
(def ^:private bufsize 65536)
|
|
(defn- recv-str [fd]
|
|
(let [buf (ffi/alloc bufsize)]
|
|
(try (let [n (c-recv fd buf bufsize 0)]
|
|
(when (pos? n) (String. (ffi/read-array buf n) "ISO-8859-1")))
|
|
(finally (ffi/free buf)))))
|
|
|
|
(defn- send-str [fd s]
|
|
(let [data (byte-array (map int s)) n (alength data) buf (ffi/alloc (max 1 n))]
|
|
(try (ffi/write-array buf data)
|
|
(loop [off 0] (when (< off n) (let [sent (c-send fd (+ buf off) (- n off) 0)]
|
|
(when (pos? sent) (recur (+ off sent))))))
|
|
(finally (ffi/free buf)))))
|
|
|
|
;; --- bencode ---------------------------------------------------------------
|
|
(defn- bencode [v]
|
|
(cond
|
|
(integer? v) (str "i" v "e")
|
|
(string? v) (let [w (->wire v)] (str (count w) ":" w))
|
|
(keyword? v) (let [w (->wire (name v))] (str (count w) ":" w))
|
|
(map? v) (str "d" (apply str (mapcat (fn [[k val]] [(bencode (name k)) (bencode val)])
|
|
(sort-by #(name (first %)) v))) "e")
|
|
(or (seq? v) (vector? v)) (str "l" (apply str (map bencode v)) "e")
|
|
(nil? v) "0:"
|
|
:else (let [w (->wire (str v))] (str (count w) ":" w))))
|
|
|
|
;; decode one value from `s` at index `i` -> [value next-index], or nil if the
|
|
;; buffer doesn't yet hold a complete value.
|
|
(defn- bdecode [s i]
|
|
(when (< i (count s))
|
|
(let [c (nth s i)]
|
|
(cond
|
|
(= c \i) (let [e (str/index-of s "e" i)]
|
|
(when e [(parse-long (subs s (inc i) e)) (inc e)]))
|
|
(= c \l) (loop [j (inc i) acc []]
|
|
(cond (>= j (count s)) nil
|
|
(= (nth s j) \e) [acc (inc j)]
|
|
:else (let [r (bdecode s j)] (when r (recur (second r) (conj acc (first r)))))))
|
|
(= c \d) (loop [j (inc i) acc {}]
|
|
(cond (>= j (count s)) nil
|
|
(= (nth s j) \e) [acc (inc j)]
|
|
:else (let [k (bdecode s j)]
|
|
(when k (let [val (bdecode s (second k))]
|
|
(when val (recur (second val) (assoc acc (wire-> (first k)) (first val)))))))))
|
|
(and (char? c) (>= (int c) 48) (<= (int c) 57)) ; string: <len>:<bytes>
|
|
(let [colon (str/index-of s ":" i)]
|
|
(when colon
|
|
(let [n (parse-long (subs s i colon)) start (inc colon) end (+ start n)]
|
|
(when (<= end (count s)) [(subs s start end) end]))))
|
|
:else nil))))
|
|
|
|
;; --- public seam for middleware --------------------------------------------
|
|
(def ^:private session-counter (atom 0))
|
|
(defn new-session
|
|
"A fresh session id (middleware that implements sessions uses this)."
|
|
[] (str "jolt-" (swap! session-counter inc)))
|
|
|
|
(defn respond
|
|
"Send a response map for `request` (id/session added, then bencoded)."
|
|
[request m] ((:reply request) m))
|
|
|
|
(defn err-msg
|
|
"Best-effort message for any thrown value (ex-info, or a raw Chez condition —
|
|
ex-message is nil for those, so fall back to the host condition text)."
|
|
[e]
|
|
(or (ex-message e)
|
|
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
|
|
(pr-str e)))
|
|
|
|
(defn evaluate
|
|
"Evaluate `code` (optionally in loaded ns `ns-str`), capturing *out*. Returns
|
|
{:value .. :out .. :ns .. :err ..}. in-ns — not (binding [*ns* ..]) — sets the
|
|
ns load-string resolves against on jolt. Reusable by eval middleware."
|
|
[code ns-str]
|
|
(let [result (atom nil) err (atom nil)
|
|
out (with-out-str
|
|
(try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
|
|
(in-ns (symbol ns-str)))
|
|
(reset! result (load-string code))
|
|
(catch :default e (reset! err (err-msg e)))))]
|
|
{:value (when (nil? @err) (pr-str @result))
|
|
:out out
|
|
:ns (str (ns-name *ns*))
|
|
:err @err}))
|
|
|
|
;; ops middleware advertise via describe (built-ins + any a library registers).
|
|
(def ^:private extra-ops (atom #{}))
|
|
(defn register-ops!
|
|
"Register op name(s) so `describe` advertises them. Call at middleware load."
|
|
[& ops] (swap! extra-ops into (map name ops)))
|
|
|
|
;; --- built-in handler ------------------------------------------------------
|
|
(defn- built-in-handler [request]
|
|
(let [op (get request "op")]
|
|
(cond
|
|
(= op "clone") (respond request {"new-session" (new-session) "status" ["done"]})
|
|
(= op "close") (respond request {"status" ["session-closed" "done"]})
|
|
(= op "describe") (respond request {"status" ["done"]
|
|
"versions" {"jolt-nrepl" {"major" 0 "minor" 1}}
|
|
"ops" (zipmap (into #{"clone" "close" "describe" "eval" "load-file"}
|
|
@extra-ops)
|
|
(repeat {}))})
|
|
(or (= op "eval") (= op "load-file"))
|
|
(let [code (wire-> (if (= op "load-file") (get request "file") (get request "code")))
|
|
{:keys [value out ns err]} (evaluate code (get request "ns"))]
|
|
(when (seq out) (respond request {"out" out}))
|
|
(if err
|
|
(do (respond request {"err" (str err "\n")})
|
|
(respond request {"ex" (str err) "status" ["eval-error" "done"]}))
|
|
(respond request {"value" value "ns" ns "status" ["done"]})))
|
|
:else (respond request {"status" ["done" "unknown-op"]}))))
|
|
|
|
;; --- middleware composition ------------------------------------------------
|
|
;; resolve deps.edn :nrepl/middleware symbols to middleware fns. An entry may
|
|
;; resolve to a single (fn [handler] handler') or to a vector of them (so a
|
|
;; library can export one `default-middleware` var).
|
|
(defn- resolve-middleware [syms]
|
|
(vec (mapcat
|
|
(fn [sym]
|
|
(require (symbol (namespace sym)))
|
|
(let [v (deref (resolve sym))]
|
|
(if (sequential? v) (map #(if (var? %) (deref %) %) v) [v])))
|
|
syms)))
|
|
|
|
(defn- build-handler [middleware]
|
|
;; first listed middleware is outermost.
|
|
(reduce (fn [h mw] (mw h)) built-in-handler (reverse middleware)))
|
|
|
|
(defn- handle-conn [fd handler]
|
|
;; one send lock per connection: eval/session middleware reply from other
|
|
;; threads, so sends must not interleave.
|
|
(let [lock (Object.)
|
|
reply-for (fn [msg]
|
|
(let [id (get msg "id") session (or (get msg "session") "none")]
|
|
(fn [m]
|
|
(locking lock
|
|
(send-str fd (bencode (cond-> m id (assoc "id" id)
|
|
session (assoc "session" session))))))))]
|
|
(loop [buf ""]
|
|
(let [chunk (recv-str fd)]
|
|
(if (nil? chunk)
|
|
(c-close fd)
|
|
(let [rest-buf (loop [b (str buf chunk)]
|
|
(let [r (bdecode b 0)]
|
|
(if (nil? r) b
|
|
(do (when (map? (first r))
|
|
(let [msg (first r)]
|
|
(try (handler (assoc msg :reply (reply-for msg)))
|
|
(catch :default e (println "nrepl handler error:" (err-msg e))))))
|
|
(recur (subs b (second r)))))))]
|
|
(recur rest-buf)))))))
|
|
|
|
(defn start
|
|
"Start the nREPL server on `port` (a concrete port; loopback only). `middleware`
|
|
is a vector of deps.edn :nrepl/middleware symbols to compose over the built-in
|
|
handler.
|
|
|
|
Binds the socket synchronously, so a startup failure (e.g. the port is already
|
|
in use) is thrown to the caller rather than swallowed by the accept thread, then
|
|
accepts connections on a background thread and returns immediately. Writes
|
|
.nrepl-port. Does NOT block — the caller keeps the process alive (jolt.main
|
|
parks the main thread in jolt.host/run-main-pump).
|
|
|
|
Returns a zero-arg stop fn: it stops the accept loop, closes the listen socket
|
|
(freeing the port), and removes .nrepl-port. Calling it more than once is a
|
|
no-op."
|
|
([port] (start port nil))
|
|
([port middleware]
|
|
(let [handler (build-handler (resolve-middleware (or middleware [])))
|
|
fd (listen-socket port) ; throws on bind/listen failure
|
|
stopped (atom false)]
|
|
(try (spit ".nrepl-port" (str port)) (catch :default _ nil))
|
|
(println (str "nREPL server started on port " port " (127.0.0.1) — .nrepl-port written"))
|
|
(when (seq middleware) (println (str ";; middleware: " (str/join " " middleware))))
|
|
(println ";; connect your editor; ^C to stop")
|
|
(future
|
|
;; A stop closes fd, which makes the blocking accept() return an error; the
|
|
;; @stopped check then breaks the loop instead of spinning on the dead fd.
|
|
(loop []
|
|
(let [conn (c-accept fd ffi/null ffi/null)]
|
|
(when-not @stopped
|
|
(when (>= conn 0)
|
|
(future (try (handle-conn conn handler)
|
|
(catch :default e (println "nrepl conn error:" (err-msg e)) (c-close conn)))))
|
|
(recur)))))
|
|
(fn stop []
|
|
(when (compare-and-set! stopped false true)
|
|
(c-close fd)
|
|
(jolt.host/delete-file ".nrepl-port"))
|
|
nil))))
|