AtlatestRepositoryapiary

apiary / tree / src / apiaryenclave.sgl

1;;; (apiary enclave) - Enclave (IRC) substrate for the apiary bot.
2;;;
3;;; Connects apiary to a running Enclave server via a SASL-PLAIN
4;;; authenticated bot identity. The same module powers leader and
5;;; worker modes — the only difference is which token is supplied
6;;; via the env var `APIARY_TOKEN` (a leader's persistent token vs
7;;; a one-time worker token issued by `bot register`).
8;;;
9;;; Module surface
10;;; --------------
11;;; enclave-config configuration struct
12;;; load-enclave-config reads APIARY_* env
13;;; enclave-config-ready? true when host + user + token present
14;;;
15;;; enclave-conn active connection (wraps irc-connection)
16;;; enclave-connect SASL-PLAIN connect; blocks until 001
17;;; enclave-disconnect
18;;; enclave-conn-ready?
19;;; enclave-conn-current-nick
20;;;
21;;; enclave-services-call sync request/reply against EnclaveServ
22;;; enclave-register-bot leader-only: spawn a worker bot
23;;; enclave-revoke-bot leader-only: tear down a worker bot
24;;; enclave-rotate-token rotate own (or admin: any) token
25;;;
26;;; enclave-post PRIVMSG to a channel
27;;; enclave-watch-channel invoke handler on incoming channel msgs
28;;; enclave-watch-dms invoke handler on direct PRIVMSG to us
29;;;
30;;; The result alist returned by enclave-services-call decodes the
31;;; +enclave/result.* IRCv3 tag namespace per
32;;; topics/enclave-services-bot-result-tags.
34(define-library (apiary enclave)
35 (import (sigil core)
36 (sigil string)
37 (sigil struct)
38 (sigil process)
39 (sigil async)
40 (sigil math)
41 (sigil random)
42 (sigil time)
43 (sigil log)
44 (sigil socket)
45 (sigil irc connection)
46 (sigil irc message)
47 (sigil tls))
48 (export
49 enclave-config
50 enclave-config?
51 enclave-config-host
52 enclave-config-port
53 enclave-config-tls?
54 enclave-config-user
55 enclave-config-token
56 enclave-config-channel
57 enclave-config-services-timeout
58 enclave-config-connect-timeout
59 enclave-config-tls-handshake-timeout
60 load-enclave-config
61 enclave-config-ready?
63 connect-outcome
64 connect-outcome?
65 connect-outcome-kind
66 connect-outcome-detail
67 connect-outcome-socket
68 connect-outcome-ok?
69 connect-outcome-message
70 classify-connect-status
71 open-enclave-transport
72 irc-connection-on-socket
73 enclave-connect/detail
74 reconnect-delay-for
76 enclave-conn
77 enclave-conn?
78 enclave-conn-irc
79 set-enclave-conn-irc!
80 enclave-conn-config
81 enclave-conn-caps-acked
82 set-enclave-conn-caps-acked!
83 enclave-conn-last-batch-fail
84 set-enclave-conn-last-batch-fail!
85 enclave-conn-last-inbound-ts
86 set-enclave-conn-last-inbound-ts!
87 enclave-conn-pending-pings
88 set-enclave-conn-pending-pings!
89 enclave-conn-ping-add!
90 enclave-conn-ping-ack!
91 enclave-conn-ping-waiting?
92 enclave-conn-ping-acked?
93 enclave-conn-acked-pings
94 confirm-verdict
95 enclave-conn-pings-clear!
96 enclave-conn-ping-outstanding?
97 enclave-conn-oldest-ping-ts
98 enclave-conn-reconnecting?
99 set-enclave-conn-reconnecting?!
100 enclave-conn-reconnect-attempt
101 set-enclave-conn-reconnect-attempt!
102 enclave-conn-shutdown?
103 set-enclave-conn-shutdown?!
104 enclave-conn-note-inbound!
105 enclave-conn-keepalive-tick!
106 enclave-confirm-delivery!
107 +post-confirm-timeout+
108 await-registration!
109 enclave-connect
110 enclave-disconnect
111 enclave-conn-ready?
112 enclave-conn-current-nick
114 enclave-services-call
115 enclave-register-bot
116 enclave-revoke-bot
117 enclave-rotate-token
119 enclave-post
120 enclave-post-multiline
121 enclave-post-react
122 enclave-conn-cap-acked?
123 enclave-watch-channel
124 enclave-watch-dms
126 enclave-conn-status-hook
127 set-enclave-conn-status-hook!
128 report-link-status!
129 report-link-connected!
131 safe-token-prefix)
132 (begin
134 ;; ============================================================
135 ;; Type / struct definitions
136 ;; ============================================================
138 (define-struct enclave-config
139 (host default: #f)
140 (port default: 6667)
141 (tls? default: #f)
142 ;; The bot identity apiary connects as. Same env name in both
143 ;; leader and worker modes — they're symmetric, just different
144 ;; tokens.
145 (user default: #f)
146 (token default: #f)
147 ;; The single coordination channel apiary joins on connect.
148 (channel default: "#hive")
149 ;; Timeout (seconds) for a single EnclaveServ request/reply.
150 (services-timeout default: 5.0)
151 ;; Upper bound (seconds) on the TCP connect phase. See
152 ;; `+connect-timeout-default+` for why this number matters far
153 ;; more than it looks like it should.
154 ;;
155 ;; KEEP IN SYNC with `+connect-timeout-default+`. This literal
156 ;; cannot reference that constant, because this file defines
157 ;; types before constants — so the same default is written
158 ;; twice, and code building a config directly reads THIS one
159 ;; while `load-enclave-config` reads the other. A test
160 ;; ("the struct default and the loaded default cannot drift")
161 ;; asserts they are equal; it exists because a sabotage run
162 ;; changed one of them and nothing turned red.
163 (connect-timeout default: 5.0)
164 ;; Upper bound (seconds) on the TLS handshake phase. Separate
165 ;; from `connect-timeout` on purpose — they bound different
166 ;; failures. See `+tls-handshake-timeout-default+`, and the
167 ;; keep-in-sync note above, which applies here identically.
168 (tls-handshake-timeout default: 10.0))
170 ;; The result of one attempt to open the transport. Carrying a
171 ;; `kind` symbol rather than only a message is what lets callers
172 ;; ACT on the difference between "refused" and "timed out" — and
173 ;; lets an operator read a diagnosis instead of an echo of the
174 ;; host:port they already configured.
175 ;;
176 ;; kind is one of:
177 ;; 'ok transport open; `socket` holds it
178 ;; 'dns the hostname did not resolve
179 ;; 'refused the port answered with RST — something is
180 ;; listening on the host but not on that port
181 ;; 'timeout no answer within the connect bound — the
182 ;; blackhole case (route gone, tunnel down)
183 ;; 'unreachable the kernel had no route / ICMP unreachable
184 ;; 'tls TCP connected, TLS handshake failed or timed out
185 ;; 'registration transport open, but no 001 within the bound
186 ;; (also where a SASL rejection surfaces)
187 ;; 'config incomplete configuration — will NOT self-heal
188 ;; 'other a connect error outside the classified set
189 (define-struct connect-outcome
190 (kind)
191 (detail default: "")
192 (socket default: #f))
194 ;; Wraps the underlying irc-connection plus services-call
195 ;; coordination state. The mailbox is a single-slot rendezvous:
196 ;; the PRIVMSG-from-EnclaveServ handler writes one entry; the
197 ;; caller's goroutine polls + drains.
198 ;;
199 ;; `caps-acked` accumulates the post-registration CAP REQ
200 ;; replies — the bot uses it to decide whether to wrap
201 ;; multi-line content in a BATCH (`draft/multiline` ACKed) or
202 ;; fall back to per-line PRIVMSG.
203 ;;
204 ;; `inbound-batches` collects in-flight server→bot BATCHes by
205 ;; reftag. Each entry is a list `(reftag type target acc-rev)`
206 ;; where `acc-rev` is a reverse-cons list of inbound bodies so
207 ;; the bot can deliver one channel-notify per logical message
208 ;; on BATCH close.
209 (define-struct enclave-conn
210 ;; The underlying IRC connection. Mutable so the keepalive
211 ;; reconnect path can swap in a fresh `make-irc-connection`
212 ;; after a PING-timeout disconnect — the surrounding bridge
213 ;; state (channel-watchers, MCP server, trusted set) keeps
214 ;; pointing at this enclave-conn through the swap.
215 (irc mutable: #t) ;; irc-connection
216 (config) ;; enclave-config
217 (services-pending default: '() mutable: #t) ;; list of replies (most recent first)
218 (services-busy? default: #f mutable: #t) ;; mutex for concurrent calls
219 (caps-acked default: '() mutable: #t) ;; list of cap-name strings
220 (caps-pending? default: #f mutable: #t) ;; #t while CAP REQ is in flight
221 (inbound-batches default: '() mutable: #t) ;; alist reftag -> (type target acc-rev)
222 ;; Most recent server `FAIL BATCH <code>` reply we observed
223 ;; while emitting a multiline batch. Set by the FAIL handler
224 ;; (matched on command="BATCH"), read + cleared by
225 ;; `enclave-post-multiline` to decide whether to fall back to
226 ;; per-line PRIVMSG. Stored as `(code . reason)` or `#f`.
227 (last-batch-fail default: #f mutable: #t)
228 ;; Client-side PING/PONG keepalive bookkeeping, paired with
229 ;; the enclave-server side in [[topics/enclave-deployment]].
230 ;;
231 ;; `last-inbound-ts` is the epoch second of the most recent
232 ;; INBOUND IRC traffic. INBOUND ONLY — this is load-bearing
233 ;; and it used to be wrong.
234 ;;
235 ;; An outbound write succeeds into the local kernel send
236 ;; buffer and proves NOTHING about the peer: on a blackholed
237 ;; route every send still "succeeds" while nothing arrives.
238 ;; When outbound traffic refreshed this clock, a bot that
239 ;; posted more often than `+keepalive-idle-threshold+` kept
240 ;; resetting its own idle timer with writes that went nowhere
241 ;; and so never PINGed and never detected the dead link. The
242 ;; busier the bot, the blinder it was. Measured 2026-08-04 as
243 ;; a matched pair: a silent bot hit its PONG timeout at t+96s
244 ;; and recovered; a bot posting every 20s never fired at all.
245 ;;
246 ;; Only inbound bytes are evidence that the peer is alive.
247 (last-inbound-ts default: #f mutable: #t)
248 ;; Outstanding client→server PINGs as a list of
249 ;; `(token . sent-ts)`, most recent first. The PONG handler
250 ;; drops the entry whose token matches; the keepalive tick
251 ;; measures its timeout from the OLDEST outstanding entry.
252 ;;
253 ;; A LIST rather than a single slot, deliberately: post-time
254 ;; delivery confirmation (`enclave-confirm-delivery!`) also
255 ;; emits PINGs, and if it could re-stamp an already-pending
256 ;; one, a bot posting faster than `+keepalive-pong-timeout+`
257 ;; would keep pushing its own deadline out — reintroducing
258 ;; exactly the defect above in a new place. Entries can only
259 ;; be ADDED, each keeps its own sent-ts, and the deadline is
260 ;; always measured from the oldest, so that is structurally
261 ;; impossible rather than merely avoided by care.
262 (pending-pings default: '() mutable: #t)
263 ;; Tokens the peer has ANSWERED, most recent first, capped at
264 ;; `+max-acked-pings+`. Separate from the list above because
265 ;; leaving that list is ambiguous — an entry goes away either
266 ;; because the peer answered it or because we abandoned the
267 ;; socket — and delivery confirmation must only ever act on the
268 ;; first of those. See `enclave-conn-ping-acked?`.
269 (acked-pings default: '() mutable: #t)
270 ;; Throttle the keepalive sweep — the event loop ticks every
271 ;; 50ms but the keepalive logic only needs to run every few
272 ;; seconds, so we record when we last ran the sweep and skip
273 ;; until enough time has passed.
274 (last-keepalive-check default: #f mutable: #t)
275 ;; Reconnect coordination. While `reconnecting?` is #t the
276 ;; event loop idles (no irc-tick) and the keepalive sweep
277 ;; pauses; the reconnect goroutine sets it back to #f after
278 ;; the new irc-connection finishes registration + cap
279 ;; negotiation + channel rejoin. `reconnect-attempt` drives
280 ;; the exponential backoff; reset to 0 on a successful
281 ;; reconnect handshake.
282 (reconnecting? default: #f mutable: #t)
283 (reconnect-attempt default: 0 mutable: #t)
284 ;; Set to #t when the caller wants the connection torn down
285 ;; permanently — both the event loop and the reconnect
286 ;; goroutine bail out instead of looping. `enclave-disconnect`
287 ;; flips this so a graceful shutdown doesn't trigger the
288 ;; reconnect path on the way out.
289 (shutdown? default: #f mutable: #t)
290 ;; Optional callback the reconnect path uses to report link
291 ;; status upward, so a layer that owns a user-facing surface
292 ;; (tool results, a status line) can say "retrying, attempt 4,
293 ;; last failure X" instead of a flat "not connected".
294 ;;
295 ;; Called as (hook state-symbol detail attempt next-delay) where
296 ;; state-symbol is 'connecting / 'connected / 'failed, detail is
297 ;; a human string, attempt an integer, and next-delay seconds or
298 ;; #f. A #f hook means nobody is listening; this module never
299 ;; depends on it having been set.
300 (status-hook default: #f mutable: #t))
302 ;; ============================================================
303 ;; Constants
304 ;; ============================================================
306 (define +result-prefix+ "+enclave/result.")
307 (define +result-prefix-len+ 16) ;; (string-length +result-prefix+)
309 ;; The post-registration cap set apiary asks for. `sasl` is
310 ;; already negotiated by sigil-irc during connect; everything
311 ;; else (message-tags, batch, draft/multiline, server-time,
312 ;; echo-message) is layered on with a separate CAP REQ once
313 ;; we're past 001 RPL_WELCOME.
314 (define +apiary-extra-caps+
315 (string-append
316 "message-tags batch draft/multiline server-time echo-message "
317 "draft/react draft/reaction draft/reply"))
319 (define +cap-multiline+ "draft/multiline")
320 (define +cap-batch+ "batch")
322 ;; Client-side keepalive knobs. Sized for the diagnosis in
323 ;; [[investigations/apiary-enclave-silent-disconnect-no-keepalive-2026-04-30]]:
324 ;; relayd's idle timeout is 600 s, NAT conntrack often ages
325 ;; out around 900 s. We want both PING bursts AND timeout
326 ;; detection well under those windows so a half-dead
327 ;; connection is reaped + reconnected before the next send-
328 ;; channel call sails into the bit-bucket.
329 (define +keepalive-poll-interval+ 5.0) ;; sweep cadence (seconds)
330 (define +keepalive-idle-threshold+ 60.0) ;; ping if no INBOUND traffic in last N seconds
331 (define +keepalive-pong-timeout+ 30.0) ;; reconnect if PONG hasn't arrived after N seconds
333 ;; How long `enclave-confirm-delivery!` waits for the PONG that
334 ;; proves the peer consumed the bytes we just wrote.
335 ;;
336 ;; MEASURED, not chosen. `test/harness/exp_confirm_latency.py`,
337 ;; 40 posts against a local enclave-server, two independent
338 ;; signals that agree:
339 ;;
340 ;; apiary's own log p50 40 ms p95 60 ms max 60 ms
341 ;; tool-call wall p50 42 ms p95 62 ms max 62 ms
342 ;;
343 ;; Note what dominates that: the values quantise to 20 ms, which
344 ;; is `+post-confirm-poll+`, and the floor is the 50 ms event-
345 ;; loop tick. The wire round trip on localhost is smaller than
346 ;; either. So on a real link the latency is roughly one event-
347 ;; loop tick plus one RTT, and 3 s tolerates an RTT of nearly
348 ;; three seconds — far past the point where a link is usable at
349 ;; all. Against the measured local worst case it is ~50x.
350 ;;
351 ;; That margin is deliberate. A false UNCONFIRMED on a merely
352 ;; slow link is worse than a slow post: the first person to see
353 ;; a spurious one starts ignoring the warning, and then the
354 ;; signal this whole change exists to create is gone.
355 ;;
356 ;; The cost is real and worth stating: a post used to return in
357 ;; well under a millisecond and now takes ~40 ms, because it
358 ;; waits for a round trip it did not previously make. For agent
359 ;; milestones that is not a rate anyone will notice; for a
360 ;; high-throughput producer it would be.
361 ;;
362 ;; It also stays well under `+keepalive-pong-timeout+` (30 s),
363 ;; so a confirmation wait can never outlive the window in which
364 ;; the keepalive would declare the same link dead.
365 (define +post-confirm-timeout+ 3.0)
366 ;; Poll step while waiting. Sleeping yields to the cooperative
367 ;; scheduler so the event-loop goroutine can read the socket and
368 ;; clear our token — VERIFIED by running it, not assumed. If
369 ;; nothing else ran during this sleep, every post would cost the
370 ;; full budget and confirm nothing.
371 (define +post-confirm-poll+ 0.02)
372 ;; Hard cap on outstanding PINGs so a burst of posts inside one
373 ;; confirmation budget cannot grow the list without bound.
374 (define +max-outstanding-pings+ 4)
375 ;; How many answered tokens to remember. They only need to
376 ;; outlive the confirmation wait that is watching for them.
377 (define +max-acked-pings+ 8)
378 (define +reconnect-backoff-min+ 1.0)
379 (define +reconnect-backoff-max+ 60.0)
380 ;; sigil-irc completes its handshake (TCP connect → CAP LS →
381 ;; SASL → 001) under 5 s on a healthy network. After a
382 ;; production enclave restart the server is back up within a
383 ;; few seconds; if our reconnect TCP-connects mid-restart the
384 ;; SASL handshake hangs until the server's listener is fully
385 ;; ready. Tight timeout cycles those failed attempts through
386 ;; the backoff schedule fast — the alternative (waiting 30 s)
387 ;; left apiary spinning on a single dead handshake while the
388 ;; enclave was already up and accepting registrations.
389 (define +reconnect-handshake-timeout+ 10.0)
391 ;; ---- Bounded transport knobs -------------------------------
392 ;;
393 ;; Apiary runs the MCP stdin fiber and the Enclave link on ONE
394 ;; cooperative scheduler. A blocking syscall does not merely delay
395 ;; the thing making it — for its whole duration NO MCP request can
396 ;; be answered. So every phase of opening the transport has to be
397 ;; bounded, and the bounds are chosen against measured numbers
398 ;; rather than picked for tidiness.
399 ;;
400 ;; CONNECT bound. The kernel's own SYN-retransmit budget is ~135 s,
401 ;; and an unreachable endpoint therefore wedged dispatch essentially
402 ;; continuously: each attempt blocked ~135 s while the backoff
403 ;; between attempts was seconds.
404 ;;
405 ;; 5 s, because:
406 ;; * a healthy connect over a working link is single-digit
407 ;; milliseconds, so this leaves ~3 orders of magnitude of
408 ;; headroom for a slow or lossy path;
409 ;; * it is ~27x below the kernel's ~135 s; and
410 ;; * — the interaction that is easy to miss — it sits deliberately
411 ;; BELOW `+keepalive-pong-timeout+` (30 s), so a connect attempt
412 ;; cannot outlive the window in which the keepalive sweep would
413 ;; declare the link dead.
414 ;;
415 ;; BE PRECISE ABOUT WHAT THAT ORDERING DOES AND DOES NOT BUY, because
416 ;; an earlier version of this comment credited the wrong mechanism.
417 ;; What actually prevents two overlapping reconnects is the
418 ;; `reconnecting?` flag: `enclave-conn-keepalive-tick!` bails while
419 ;; it is set, and `trigger-reconnect!` is idempotent. The timeout
420 ;; ordering is DEFENCE IN DEPTH on top of that, not the guarantee.
421 ;;
422 ;; The ordering only holds per CALL, not per address, so
423 ;; `open-enclave-transport` shares one budget across every address a
424 ;; hostname resolves to. Without that, six blackholed addresses at
425 ;; 5 s each would put a single call at 30 s and break the property.
426 (define +connect-timeout-default+ 5.0)
428 ;; HANDSHAKE bound, deliberately a SEPARATE number rather than one
429 ;; tidy timeout, because it bounds a different failure. Once a peer
430 ;; has ACCEPTED the TCP connection the connect phase is over, so the
431 ;; connect bound cannot reach a peer that then goes silent — that
432 ;; read had no bound at all.
433 ;;
434 ;; 10 s costs nothing in either real case: a healthy handshake is
435 ;; ~100 ms, and an expired-certificate failure completes the connect
436 ;; and fails the handshake in ~5 s on its own. It exists only for
437 ;; the pathological "accepted, then silence" case. Matching
438 ;; `+reconnect-handshake-timeout+` keeps connect + handshake +
439 ;; registration under ~25 s for a single attempt.
440 (define +tls-handshake-timeout-default+ 10.0)
442 ;; Bounded TCP connect, reaching past sigil-socket's Scheme surface
443 ;; to the native the VM already registers in the `(sigil socket)`
444 ;; module. `tcp-connect` is unbounded and sigil-irc's `irc-connect`
445 ;; offers no way to pass a deadline, so apiary opens the transport
446 ;; itself. Declaring the native this way is how sigil-socket reaches
447 ;; its own natives; sigil-socket simply does not re-export this one.
448 ;;
449 ;; Returns `(status . socket-or-#f)`. Statuses observed in practice:
450 ;; "connected", "connection refused", "connection timed out",
451 ;; "host unreachable", "network unreachable", or strerror(errno).
452 ;; That status string is the whole reason for using this native over
453 ;; a plain bounded connect: symptom 3 of the defect this fixes is
454 ;; that every failure shape produced one indistinguishable message.
455 (define-native (%tcp-connect-ip-timeout-status ip port timeout-ms)
456 (: string? integer? integer? -> pair?))
458 ;; ============================================================
459 ;; Pure helpers (no upward references)
460 ;; ============================================================
462 (define (env-or-false name)
463 (let ((v (getenv name)))
464 (if (and (string? v) (> (string-length v) 0))
465 v
466 #f)))
468 (define (env-flag name)
469 (let ((v (env-or-false name)))
470 (and v
471 (let ((lower (string-downcase v)))
472 (or (string=? lower "1")
473 (string=? lower "true")
474 (string=? lower "yes")
475 (string=? lower "on"))))))
477 (define (string-trim s)
478 (if (string? s)
479 (let* ((len (string-length s))
480 (start (let ws ((i 0))
481 (cond
482 ((= i len) len)
483 ((char-whitespace? (string-ref s i))
484 (ws (+ i 1)))
485 (else i))))
486 (end (let ws ((i len))
487 (cond
488 ((<= i start) start)
489 ((char-whitespace? (string-ref s (- i 1)))
490 (ws (- i 1)))
491 (else i)))))
492 (if (and (= start 0) (= end len))
493 s
494 (substring s start end)))
495 s))
497 (define (split-channels csv)
498 (if (or (not csv) (string=? csv ""))
499 '()
500 (filter (lambda (s) (> (string-length s) 0))
501 (map string-trim (string-split csv ",")))))
503 (define (channel-target? target)
504 (and (string? target)
505 (> (string-length target) 0)
506 (let ((c (string-ref target 0)))
507 (or (char=? c #\#) (char=? c #\&)))))
509 (define (services-sender? msg)
510 (let ((nick (irc-message-nick msg)))
511 (and (string? nick)
512 (string-ci=? nick "EnclaveServ"))))
514 (define (member-string? needle xs)
515 (cond
516 ((null? xs) #f)
517 ((and (string? needle) (string? (car xs))
518 (string=? needle (car xs)))
519 #t)
520 (else (member-string? needle (cdr xs)))))
522 ;;; True when the named cap was ACKed during apiary's
523 ;;; post-registration CAP REQ handshake. Use this to decide
524 ;;; whether to emit BATCH wrappers vs per-line PRIVMSG fallback.
525 (define (enclave-conn-cap-acked? conn cap-name)
526 (: enclave-conn? string? -> boolean?)
527 (member-string? cap-name (enclave-conn-caps-acked conn)))
529 ;;; Generate a fresh keepalive PING token. The token is
530 ;;; pseudo-secret — defense-in-depth against a misbehaved
531 ;;; channel peer crafting a PONG that prematurely clears our
532 ;;; pending-ping bookkeeping. Combine current-jiffy (nanosecond-
533 ;;; granular monotonic counter) with a random integer for
534 ;;; ~64 bits of session-local entropy. Wire format is opaque
535 ;;; to the server — it just echoes whatever we send back.
536 (define (generate-keepalive-token)
537 (: -> string?)
538 (string-append "apk-"
539 (number->string (current-jiffy))
540 "-"
541 (number->string (random-integer 1000000000))))
543 ;;; Truncated token marker that's safe to log: 4-char prefix +
544 ;;; length. Never logs full tokens — privacy contract from
545 ;;; topics/enclave-server-logging-privacy-contract applies to
546 ;;; apiary just as much as enclave-server.
547 (define (safe-token-prefix token)
548 (: any? -> string?)
549 (cond
550 ((not (string? token)) "<no-token>")
551 ((< (string-length token) 4)
552 (string-append "<short:" (number->string (string-length token)) ">"))
553 (else
554 (string-append (substring token 0 4) "…("
555 (number->string (string-length token)) ")"))))
557 ;;; True when the transport opened.
558 (define (connect-outcome-ok? outcome)
559 (: connect-outcome? -> boolean?)
560 (eq? (connect-outcome-kind outcome) 'ok))
562 ;;; Map a `%tcp-connect-ip-timeout-status` status string onto a
563 ;;; `connect-outcome` kind.
564 ;;;
565 ;;; Note what this deliberately does NOT do: it never folds an
566 ;;; unrecognised status into 'timeout or 'refused. An unknown
567 ;;; failure is 'other and says so. Guessing here would recreate
568 ;;; exactly the defect being fixed — a message that reports a
569 ;;; diagnosis it does not actually have.
570 (define (classify-connect-status status)
571 (: any? -> symbol?)
572 (cond
573 ((not (string? status)) 'other)
574 ((string=? status "connected") 'ok)
575 ((string=? status "connection refused") 'refused)
576 ((string=? status "connection timed out") 'timeout)
577 ((string=? status "host unreachable") 'unreachable)
578 ((string=? status "network unreachable") 'unreachable)
579 (else 'other)))
581 ;; Short, operator-facing label per kind. The kind names the
582 ;; DIAGNOSIS; `detail` carries the specifics.
583 (define (connect-kind-label kind)
584 (case kind
585 ((ok) "connected")
586 ((dns) "DNS failure")
587 ((refused) "connection refused")
588 ((timeout) "connect timed out")
589 ((unreachable) "network unreachable")
590 ((tls) "TLS failure")
591 ((registration) "registration failed")
592 ((config) "configuration incomplete")
593 (else "connect failed")))
595 ;;; One-line message for logs and tool results. Leads with the
596 ;;; diagnosis, not with the host:port the caller already knows.
597 (define (connect-outcome-message outcome)
598 (: connect-outcome? -> string?)
599 (let ((label (connect-kind-label (connect-outcome-kind outcome)))
600 (detail (connect-outcome-detail outcome)))
601 (if (and (string? detail) (> (string-length detail) 0))
602 (string-append label ": " detail)
603 label)))
605 (define (seconds->ms secs)
606 (: number? -> integer?)
607 (let ((ms (exact (round (* 1000 (max 0 secs))))))
608 (if (< ms 1) 1 ms)))
610 (define (endpoint-label host port)
611 (string-append host ":" (number->string port)))
613 ;;; Parse a positive-number env override, falling back to `fallback`
614 ;;; when the value is absent, unparseable, or NOT POSITIVE.
615 ;;;
616 ;;; That last clause is load-bearing rather than defensive tidiness.
617 ;;; The underlying native treats a NEGATIVE timeout as "no bound"
618 ;;; and reverts to a plain blocking connect, so a stray
619 ;;; `APIARY_CONNECT_TIMEOUT=-1` would silently restore the exact
620 ;;; ~135 s wedge this module exists to prevent, while looking like
621 ;;; a deliberate configuration choice.
622 ;;;
623 ;;; Precisely: only `< 0` disables the bound; `0` polls with a zero
624 ;;; timeout and fails instantly, which is useless rather than
625 ;;; dangerous. `seconds->ms` also clamps to at least 1 ms, so a
626 ;;; zero can never reach the native anyway. Both are refused here
627 ;;; regardless — a bound of "instantly fail every connect" is not a
628 ;;; configuration anyone means — but the DANGEROUS case is the
629 ;;; negative one, and the earlier version of this comment was wrong
630 ;;; about which.
631 (define (positive-or raw fallback)
632 (: any? number? -> number?)
633 (let ((n (and (string? raw) (string->number raw))))
634 (cond
635 ((not raw) fallback)
636 ((and (number? n) (> n 0)) n)
637 (else
638 (log-warn "Apiary ignoring non-positive timeout override — a zero or negative bound would disable it entirely"
639 value: raw
640 using: (number->string fallback))
641 fallback))))
643 ;; Pull result.* tags off a message into an alist of
644 ;; (key-string . value-string-or-flag-symbol). Stripping the
645 ;; "+enclave/result." prefix so callers see "status", "code",
646 ;; "token", etc.
647 (define (extract-result-tags msg)
648 (let loop ((tags (irc-message-tags msg)) (acc '()))
649 (if (null? tags)
650 (reverse acc)
651 (let* ((entry (car tags))
652 (key (car entry))
653 (val (cdr entry)))
654 (if (and (string? key)
655 (>= (string-length key) +result-prefix-len+)
656 (string=? (substring key 0 +result-prefix-len+)
657 +result-prefix+))
658 (let ((short-key (substring key +result-prefix-len+
659 (string-length key))))
660 (loop (cdr tags)
661 (cons (cons short-key (or val 'flag)) acc)))
662 (loop (cdr tags) acc))))))
664 (define (result-status alist)
665 (let ((v (assoc "status" alist)))
666 (and v (cdr v))))
668 (define (result-tag alist key)
669 (let ((v (assoc key alist)))
670 (and v (cdr v))))
672 ;; Take the list of services-reply records and build the public
673 ;; alist. The first reply's tags are authoritative; body-lines is
674 ;; the list of body strings across all replies.
675 (define (build-result-alist replies)
676 (cond
677 ((null? replies) '())
678 (else
679 (let* ((first (car replies))
680 (text (cadr first))
681 (tags (caddr first))
682 (body-lines (filter
683 (lambda (s) (and (string? s)
684 (> (string-length s) 0)))
685 (map cadr replies))))
686 (append tags
687 (list (cons "body" (or text ""))
688 (cons "body-lines" body-lines)))))))
690 ;; ============================================================
691 ;; Configuration loading + readiness
692 ;; ============================================================
694 ;;; Load enclave configuration from environment variables.
695 ;;;
696 ;;; APIARY_ENCLAVE_HOST hostname / IP
697 ;;; APIARY_ENCLAVE_PORT integer (default 6667)
698 ;;; APIARY_ENCLAVE_TLS "1" / "true" / "yes" → on
699 ;;; APIARY_USER bot nick to SASL as
700 ;;; APIARY_TOKEN SASL PLAIN password
701 ;;; APIARY_CHANNEL coordination channel (default #hive)
702 ;;; APIARY_CONNECT_TIMEOUT seconds; bound on the TCP connect
703 ;;; APIARY_TLS_HANDSHAKE_TIMEOUT
704 ;;; seconds; bound on the TLS handshake
705 ;;;
706 ;;; The two timeout knobs exist so a deployment on a slow or lossy
707 ;;; link can raise them. Raising them trades MCP responsiveness for
708 ;;; connect tolerance, which is the right trade only when a healthy
709 ;;; connect genuinely takes longer than the default allows.
710 (define (load-enclave-config)
711 (: -> enclave-config?)
712 (let* ((host (env-or-false "APIARY_ENCLAVE_HOST"))
713 (port-str (env-or-false "APIARY_ENCLAVE_PORT"))
714 (port (or (and port-str (string->number port-str)) 6667))
715 (tls? (env-flag "APIARY_ENCLAVE_TLS"))
716 (user (env-or-false "APIARY_USER"))
717 (token (env-or-false "APIARY_TOKEN"))
718 (channel (or (env-or-false "APIARY_CHANNEL") "#hive"))
719 (timeout-str (env-or-false "APIARY_SERVICES_TIMEOUT"))
720 (timeout (or (and timeout-str (string->number timeout-str))
721 5.0))
722 (connect-str (env-or-false "APIARY_CONNECT_TIMEOUT"))
723 (connect-timeout (positive-or connect-str
724 +connect-timeout-default+))
725 (handshake-str (env-or-false "APIARY_TLS_HANDSHAKE_TIMEOUT"))
726 (handshake-timeout
727 (positive-or handshake-str
728 +tls-handshake-timeout-default+)))
729 (enclave-config
730 host: host
731 port: port
732 tls?: tls?
733 user: user
734 token: token
735 channel: channel
736 services-timeout: timeout
737 connect-timeout: connect-timeout
738 tls-handshake-timeout: handshake-timeout)))
740 ;;; True when the config has the minimum needed to attempt a connect.
741 (define (enclave-config-ready? config)
742 (: enclave-config? -> boolean?)
743 (and (enclave-config-host config)
744 (enclave-config-user config)
745 (enclave-config-token config)
746 #t))
748 ;; ============================================================
749 ;; Internal: bounded transport
750 ;; ============================================================
751 ;;
752 ;; Why apiary opens the socket itself instead of calling
753 ;; sigil-irc's `irc-connect`:
754 ;;
755 ;; `irc-connect` performs the TCP connect (and, for TLS, the
756 ;; handshake) internally with no way to pass a deadline. An
757 ;; unbounded connect on this process's single cooperative
758 ;; scheduler is the entire defect — one blackholed endpoint
759 ;; starved MCP dispatch for ~132 s at a stretch.
760 ;;
761 ;; So apiary opens a BOUNDED, CLASSIFIED transport here and hands
762 ;; the ready socket to sigil-irc. The alternative considered and
763 ;; rejected was a pre-flight probe followed by `irc-connect`: that
764 ;; leaves a window between the probe and the real connect in which
765 ;; the route can disappear, which would reintroduce the ~135 s
766 ;; hang at low probability. A low-probability recurrence of the
767 ;; exact bug is not a fix.
769 ;;; Resolve `host` to a list of numeric addresses.
770 ;;;
771 ;;; sigil-socket's `resolve-hostname` is already scheduler-aware —
772 ;;; under a scheduler it starts an async resolve and yields — so
773 ;;; DNS is NOT part of the blocking problem and needs no bound of
774 ;;; its own here. That was verified rather than assumed: a
775 ;;; non-existent host produced its verdict promptly while a
776 ;;; blackholed IP hung, which is only possible if the two phases
777 ;;; are separate.
778 (define (resolve-enclave-host host)
779 (guard (e (else
780 (log-debug "Apiary host resolve raised"
781 host: host error: (format "~a" e))
782 #f))
783 (resolve-hostname host)))
785 ;;; Bounded TLS handshake over an already-connected socket.
786 ;;;
787 ;;; `tls-upgrade/status` is used rather than `tls-connect/status`
788 ;;; for two reasons. First, it lets the CONNECT phase run through
789 ;;; the classified bounded connect above; `tls-connect/status`
790 ;;; collapses every connect-phase failure into one
791 ;;; "tcp-connect-failed" status, which cannot tell refused from
792 ;;; blackholed and so defeats the point. Second, it bounds the
793 ;;; handshake separately from the connect.
794 ;;;
795 ;;; Certificate verification posture is IDENTICAL between the two
796 ;;; entry points — both configure VERIFY_REQUIRED against the
797 ;;; system CA chain and set the SNI hostname; this was checked in
798 ;;; sigil-tls's native source, not assumed, because a silent
799 ;;; downgrade here would trade an outage for an MITM window.
800 (define (upgrade-to-tls config sock host)
801 (let* ((hs-ms (seconds->ms
802 (enclave-config-tls-handshake-timeout config)))
803 ;; `tls-upgrade/status` RAISES rather than returning a
804 ;; pair when handed a socket it considers already closed.
805 ;; Without this guard that escapes `open-enclave-transport`
806 ;; entirely and is caught several frames up as an
807 ;; unclassified 'other, losing the diagnosis.
808 (result (guard (e (else (cons (format "~a" e) #f)))
809 (tls-upgrade/status sock host hs-ms)))
810 (status (car result))
811 (tls-conn (cdr result)))
812 (cond
813 (tls-conn (connect-outcome kind: 'ok socket: tls-conn))
814 (else
815 ;; Do NOT close `sock` here. `tls-upgrade` marks the
816 ;; original socket object closed BEFORE handshaking and
817 ;; from that point owns the descriptor, closing it itself
818 ;; on its failure paths. Closing again would be a
819 ;; double-close on a number the process may have reused.
820 ;;
821 ;; Read the source before strengthening this: ownership is
822 ;; taken partway INTO `tls_upgrade_core`, so its earliest
823 ;; returns (a TLS-init failure, and the already-closed
824 ;; raise handled above) happen while apiary still nominally
825 ;; owns the fd. Those paths drop the last Scheme reference
826 ;; instead, so the descriptor lives until GC finalises the
827 ;; socket rather than leaking permanently. Measured across
828 ;; 300 s and 10 handshake failures on the ownership-transfer
829 ;; path: fd count 4 -> 4, no per-attempt leak. The earlier
830 ;; comment here claimed closure on "every failure path",
831 ;; which is stronger than the source supports.
832 (connect-outcome
833 kind: 'tls
834 detail: (string-append (if (string? status) status "unknown")
835 " with "
836 (endpoint-label
837 host
838 (enclave-config-port config))))))))
840 ;;; Open the transport to the configured endpoint with a bounded
841 ;;; connect, returning a `connect-outcome` rather than a bare #f.
842 ;;;
843 ;;; Every address the hostname resolves to is tried, and a TLS
844 ;;; handshake failure falls through to the next address exactly as
845 ;;; a connect failure does. That matters for a dual-stack endpoint
846 ;;; whose v6 path has a PMTU black hole: the TCP connect succeeds
847 ;;; and the handshake stalls, and stopping there would mean never
848 ;;; reaching a working A record while reporting a TLS fault that
849 ;;; sends an operator after a certificate problem that does not
850 ;;; exist.
851 ;;;
852 ;;; The LAST failure's classification is what surfaces — what an
853 ;;; operator wants is why the final attempt failed, not the first.
854 ;;;
855 ;;; THE WHOLE CALL SHARES ONE BUDGET. Per-address bounds alone are
856 ;;; not a bound on this procedure: six blackholed addresses at 5 s
857 ;;; each is 30 s of dead scheduler in a single call, which would
858 ;;; break the "stay under the PONG window" property the connect
859 ;;; timeout is chosen for. So addresses are tried against a shared
860 ;;; deadline and the remainder is abandoned once it is spent.
861 (define (open-enclave-transport config)
862 (: enclave-config? -> connect-outcome?)
863 (let* ((host (enclave-config-host config))
864 (port (enclave-config-port config))
865 (budget (enclave-config-connect-timeout config))
866 (deadline (+ (current-second) budget))
867 (ips (resolve-enclave-host host)))
868 (cond
869 ((or (not ips) (null? ips))
870 (connect-outcome
871 kind: 'dns
872 detail: (string-append "no address for host " host)))
873 (else
874 (let try ((remaining ips)
875 (last-kind 'other)
876 (last-detail (string-append "no address tried for "
877 host)))
878 (let ((left (- deadline (current-second))))
879 (cond
880 ((null? remaining)
881 (connect-outcome kind: last-kind detail: last-detail))
882 ;; Budget spent with addresses still untried. Report
883 ;; the last real classification rather than inventing
884 ;; one for the addresses never attempted.
885 ((<= left 0)
886 (log-debug "Apiary connect budget exhausted"
887 host: host
888 untried: (number->string (length remaining)))
889 (connect-outcome kind: last-kind detail: last-detail))
890 (else
891 (let* ((ip (car remaining))
892 (result (%tcp-connect-ip-timeout-status
893 ip port (seconds->ms left)))
894 (status (car result))
895 (sock (cdr result)))
896 (cond
897 ((not sock)
898 (log-debug "Apiary bounded connect failed"
899 address: (endpoint-label ip port)
900 status: (if (string? status) status "?"))
901 (try (cdr remaining)
902 (classify-connect-status status)
903 ;; The KIND already carries the diagnosis, so
904 ;; the detail is just the endpoint — repeating
905 ;; the status would render as "connection
906 ;; refused: connection refused at host:port".
907 ;; An UNCLASSIFIED status is the exception:
908 ;; there the raw text is the only diagnosis
909 ;; available and must not be dropped.
910 (if (eq? (classify-connect-status status) 'other)
911 (string-append
912 (if (string? status) status "unknown")
913 " at " (endpoint-label ip port))
914 (endpoint-label ip port))))
915 ((not (enclave-config-tls? config))
916 (connect-outcome kind: 'ok socket: sock))
917 (else
918 (let ((upgraded (upgrade-to-tls config sock host)))
919 (if (connect-outcome-ok? upgraded)
920 upgraded
921 (try (cdr remaining)
922 (connect-outcome-kind upgraded)
923 (connect-outcome-detail upgraded)))))))))))))))
925 ;;; Build an `irc-connection` around an ALREADY-CONNECTED socket
926 ;;; and start registration.
927 ;;;
928 ;;; The three steps below are precisely what sigil-irc's
929 ;;; `irc-connect` does once its own connect returns: attach the
930 ;;; socket, mark the state `registering`, and emit the first
931 ;;; registration line. Apiary always supplies SASL credentials, so
932 ;;; that line is the `CAP LS 302` of sigil-irc's `begin-sasl-auth`.
933 ;;;
934 ;;; This is the one place apiary leans on sigil-irc's internals.
935 ;;; It cannot be pinned by a unit test — nothing at that scope
936 ;;; reaches a real server — so what guards it is the END-TO-END
937 ;;; smoke harness (`test/smoke.sh`), which drives a genuine SASL
938 ;;; registration, cap negotiation and channel join through this
939 ;;; exact path against a live enclave-server.
940 ;;;
941 ;;; That guard was VERIFIED rather than asserted: deleting the
942 ;;; `irc-send-raw` below turns the smoke RED (the live-bridge
943 ;;; case fails, exit 1). Measured 2026-08-04.
944 ;;;
945 ;;; What the smoke does NOT guard, also measured: the `302`
946 ;;; version token. Changing it to a nonsense value leaves the
947 ;;; smoke green, because a server answers `CAP LS <anything>`.
948 ;;; So the load-bearing part is THAT registration is kicked off
949 ;;; here at all, not the exact bytes.
950 ;;;
951 ;;; Stated plainly because the distinction matters to whoever
952 ;;; changes this next: `sigil test` passing tells you NOTHING
953 ;;; about this coupling. Run the smoke.
954 (define (irc-connection-on-socket config sock)
955 (: enclave-config? any? -> any?)
956 (let* ((nick (enclave-config-user config))
957 (irc (irc-connection
958 server: (enclave-config-host config)
959 port: (enclave-config-port config)
960 nick: nick
961 user: nick
962 realname: (string-append "apiary-" nick)
963 tls?: (enclave-config-tls? config)
964 sasl-username: nick
965 sasl-password: (enclave-config-token config)
966 current-nick: nick
967 socket: sock
968 state: 'registering)))
969 (irc-send-raw irc "CAP LS 302\r\n")
970 irc))
972 ;; ============================================================
973 ;; Connection state accessors
974 ;; ============================================================
976 ;;; The current nick the IRC server has assigned. #f if disconnected.
977 (define (enclave-conn-current-nick conn)
978 (: enclave-conn? -> any?)
979 (irc-connection-current-nick (enclave-conn-irc conn)))
981 ;;; True when the IRC connection has completed registration (saw 001).
982 (define (enclave-conn-ready? conn)
983 (: enclave-conn? -> boolean?)
984 (irc-connected? (enclave-conn-irc conn)))
986 ;;; Record that INBOUND traffic just arrived, resetting the
987 ;;; keepalive idle clock.
988 ;;;
989 ;;; Call this ONLY from inbound handlers, and only when bytes
990 ;;; genuinely arrived from the peer. It must never be called
991 ;;; from an outbound path: a successful write proves the local
992 ;;; kernel accepted the bytes, not that anybody received them,
993 ;;; and treating it as liveness evidence is what let a busy bot
994 ;;; suppress its own dead-connection detection. The one other
995 ;;; legitimate caller is a freshly established connection,
996 ;;; where completing registration IS inbound evidence.
997 ;;;
998 ;;; Named for what it means rather than for what it touches, so
999 ;;; that a future outbound caller reads as obviously wrong. The
1000 ;;; previous name (`touch-activity!`) described the mechanism
1001 ;;; and its docstring described the bug as though it were the
1002 ;;; design.
1003 (define (enclave-conn-note-inbound! conn)
1004 (: enclave-conn? -> any?)
1005 (set-enclave-conn-last-inbound-ts! conn (current-second)))
1007 ;; ---- outstanding PING bookkeeping ---------------------------
1008 ;;
1009 ;; Entries are `(token . sent-ts)`, most recent first. See the
1010 ;; `pending-pings` field comment for why this is a list.
1012 ;;; Record a PING we just put on the wire. ADD-only by design —
1013 ;;; there is deliberately no "update the pending ping" operation,
1014 ;;; because that is precisely how a frequent caller would push
1015 ;;; its own dead-link deadline out indefinitely.
1016 (define (enclave-conn-ping-add! conn token sent-ts)
1017 (: enclave-conn? string? number? -> any?)
1018 (set-enclave-conn-pending-pings!
1019 conn (cons (cons token sent-ts)
1020 (enclave-conn-pending-pings conn))))
1022 ;;; #t when at least one PING is still unanswered.
1023 (define (enclave-conn-ping-outstanding? conn)
1024 (: enclave-conn? -> boolean?)
1025 (pair? (enclave-conn-pending-pings conn)))
1027 ;;; #t when THIS token specifically is still unanswered.
1028 (define (enclave-conn-ping-waiting? conn token)
1029 (: enclave-conn? string? -> boolean?)
1030 (and (assoc token (enclave-conn-pending-pings conn)) #t))
1032 ;;; #t when THIS token was actually ANSWERED by the peer.
1033 ;;;
1034 ;;; This is not the negation of `ping-waiting?`, and the
1035 ;;; difference is the whole reason it exists. An entry leaves the
1036 ;;; outstanding list for two very different reasons: the peer
1037 ;;; answered it, or we gave up on the socket
1038 ;;; (`enclave-conn-pings-clear!`, called from `trigger-reconnect!`
1039 ;;; and `enclave-disconnect`). Absence conflates them.
1040 ;;;
1041 ;;; An earlier version of `enclave-confirm-delivery!` waited for
1042 ;;; absence, which meant a reconnect triggered DURING the wait
1043 ;;; cleared the token and the waiter read that as proof of
1044 ;;; delivery — reporting `Broadcast to <channel>` for a message
1045 ;;; written to a socket that was at that moment being abandoned.
1046 ;;; That is the exact false positive this whole change exists to
1047 ;;; remove, reintroduced inside the fix. Found by adversarial
1048 ;;; review, not by its author.
1049 ;;;
1050 ;;; So confirmation waits for POSITIVE evidence. Only `ping-ack!`
1051 ;;; — which runs solely from the PONG handler, on an exact token
1052 ;;; match — records here.
1053 (define (enclave-conn-ping-acked? conn token)
1054 (: enclave-conn? string? -> boolean?)
1055 (and (member-string? token (enclave-conn-acked-pings conn)) #t))
1057 ;;; Record an answered token, keeping the list short. It only
1058 ;;; needs to outlive the confirmation wait watching for it.
1059 (define (enclave-conn-note-acked! conn token)
1060 (: enclave-conn? string? -> any?)
1061 (set-enclave-conn-acked-pings!
1062 conn (let loop ((xs (cons token (enclave-conn-acked-pings conn)))
1063 (n +max-acked-pings+)
1064 (acc '()))
1065 (cond
1066 ((or (null? xs) (= n 0)) (reverse acc))
1067 (else (loop (cdr xs) (- n 1) (cons (car xs) acc)))))))
1069 ;;; Epoch second of the OLDEST unanswered PING, or #f if none.
1070 ;;; The keepalive measures its PONG timeout from this, so a
1071 ;;; newer PING can never postpone an older one's deadline.
1072 (define (enclave-conn-oldest-ping-ts conn)
1073 (: enclave-conn? -> any?)
1074 (let loop ((entries (enclave-conn-pending-pings conn))
1075 (oldest #f))
1076 (cond
1077 ((null? entries) oldest)
1078 ((or (not oldest) (< (cdar entries) oldest))
1079 (loop (cdr entries) (cdar entries)))
1080 (else (loop (cdr entries) oldest)))))
1082 ;;; Drop the entry matching `token`. Returns #t if one was
1083 ;;; removed, #f if the token was unknown (a stale or forged
1084 ;;; PONG, which must not clear anybody else's entry).
1085 (define (enclave-conn-ping-ack! conn token)
1086 (: enclave-conn? string? -> boolean?)
1087 (let ((entries (enclave-conn-pending-pings conn)))
1088 (cond
1089 ((not (assoc token entries)) #f)
1090 (else
1091 (enclave-conn-note-acked! conn token)
1092 (set-enclave-conn-pending-pings!
1093 conn (filter (lambda (e) (not (equal? (car e) token)))
1094 entries))
1095 #t))))
1097 ;;; Forget every outstanding PING — used when the socket the
1098 ;;; PINGs were written to is being abandoned.
1099 (define (enclave-conn-pings-clear! conn)
1100 (: enclave-conn? -> any?)
1101 (set-enclave-conn-pending-pings! conn '()))
1103 ;; ============================================================
1104 ;; Internal: PRIVMSG dispatcher + watch tables
1105 ;; ============================================================
1107 ;; Mutable per-conn watch handlers stored as module-level globals.
1108 ;; Apiary runs one Enclave conn per process (leader OR worker);
1109 ;; if multi-conn is needed in the future, push onto enclave-conn.
1110 (define *channel-watchers* '()) ;; alist (channel-lc . (handler ...))
1111 (define *dm-watchers* '()) ;; list of handlers
1113 (define (dispatch-channel-handlers conn msg)
1114 (let* ((target (irc-message-target msg))
1115 (target-lc (string-downcase target))
1116 (entry (assoc target-lc *channel-watchers*)))
1117 (log-debug "Enclave channel-dispatch"
1118 target: target
1119 watchers: (number->string
1120 (if entry (length (cdr entry)) 0)))
1121 (when entry
1122 (let ((sender (or (irc-message-nick msg) "?"))
1123 (text (or (irc-message-text msg) "")))
1124 (for-each (lambda (h)
1125 (guard (e (else
1126 (log-error "Channel handler crashed"
1127 channel: target
1128 error: (format "~a" e))))
1129 (h sender text msg)))
1130 (cdr entry))))))
1132 (define (dispatch-dm-handlers conn msg)
1133 (let ((sender (or (irc-message-nick msg) "?"))
1134 (text (or (irc-message-text msg) "")))
1135 (for-each (lambda (h)
1136 (guard (e (else
1137 (log-error "DM handler crashed"
1138 sender: sender
1139 error: (format "~a" e))))
1140 (h sender text msg)))
1141 *dm-watchers*)))
1143 ;; ============================================================
1144 ;; Internal: inbound BATCH coalescing
1145 ;; ============================================================
1146 ;;
1147 ;; The server forwards a multi-line message as a BATCH start +
1148 ;; N batch-tagged PRIVMSGs + a BATCH end. To keep the agent's
1149 ;; channel-notify stream clean we buffer each open batch and
1150 ;; emit one logical message on close — joined by newlines so
1151 ;; the agent sees the briefing as it was authored.
1153 (define (inbound-batch-of conn reftag)
1154 (assoc reftag (enclave-conn-inbound-batches conn)))
1156 (define (inbound-batch-open! conn reftag type target)
1157 (set-enclave-conn-inbound-batches!
1158 conn
1159 (cons (list reftag type target '())
1160 (enclave-conn-inbound-batches conn))))
1162 (define (inbound-batch-append! conn reftag body)
1163 (let* ((batches (enclave-conn-inbound-batches conn))
1164 (entry (assoc reftag batches)))
1165 (when entry
1166 (set-cdr! (cdddr entry)
1167 '()) ;; placeholder so the let-bind below is valid
1168 ;; Append the body in reverse order so emit can simply
1169 ;; (reverse acc) at close.
1170 (let* ((acc-rev (cadddr entry))
1171 (new-acc (cons body acc-rev)))
1172 (set-car! (cdddr entry) new-acc)))))
1174 (define (inbound-batch-close! conn reftag)
1175 (let* ((batches (enclave-conn-inbound-batches conn))
1176 (entry (assoc reftag batches)))
1177 (cond
1178 ((not entry) #f)
1179 (else
1180 (set-enclave-conn-inbound-batches!
1181 conn
1182 (filter (lambda (e) (not (equal? (car e) reftag)))
1183 batches))
1184 entry))))
1186 (define (handle-incoming-batch conn msg)
1187 (enclave-conn-note-inbound! conn)
1188 (let* ((params (irc-message-params msg))
1189 (first (and (pair? params) (car params)))
1190 (rest (if (pair? params) (cdr params) '())))
1191 (cond
1192 ((or (not first) (= (string-length first) 0)) #f)
1193 ((char=? (string-ref first 0) #\+)
1194 (let ((reftag (substring first 1 (string-length first)))
1195 (type (and (pair? rest) (car rest)))
1196 (target (and (pair? rest) (pair? (cdr rest))
1197 (cadr rest))))
1198 (cond
1199 ((or (not type) (not target)) #f)
1200 (else
1201 (log-debug "Enclave BATCH start"
1202 reftag: reftag type: type target: target)
1203 (inbound-batch-open! conn reftag type target)))))
1204 ((char=? (string-ref first 0) #\-)
1205 (let ((reftag (substring first 1 (string-length first))))
1206 (let ((entry (inbound-batch-close! conn reftag)))
1207 (when entry
1208 (let* ((type (cadr entry))
1209 (target (caddr entry))
1210 (acc-rev (cadddr entry))
1211 (lines (reverse acc-rev))
1212 (joined (string-join lines "\n")))
1213 (log-debug "Enclave BATCH close"
1214 reftag: reftag type: type target: target
1215 lines: (length lines))
1216 (deliver-coalesced-batch! conn type target lines joined msg))))))
1217 (else #f))))
1219 ;; Build a synthetic "merged" PRIVMSG to feed the regular
1220 ;; channel- / dm- handler dispatch on batch close. Reusing the
1221 ;; same dispatch keeps the trusted-set filter and
1222 ;; mention-routing logic in (apiary tools) authoritative —
1223 ;; multiline coalescing is a transport concern, not a
1224 ;; semantic one.
1225 (define (deliver-coalesced-batch! conn type target lines joined inbound-msg)
1226 ;; Only `draft/multiline` carries a single logical message.
1227 ;; Other batch types (chathistory etc.) leave their lines as
1228 ;; separate PRIVMSGs.
1229 (cond
1230 ((not (equal? type "draft/multiline")) #f)
1231 (else
1232 (let* ((tags (irc-message-tags inbound-msg))
1233 (synthetic
1234 (irc-message
1235 raw: ""
1236 tags: tags
1237 prefix: (irc-message-prefix inbound-msg)
1238 nick: (irc-message-nick inbound-msg)
1239 user: (irc-message-user inbound-msg)
1240 host: (irc-message-host inbound-msg)
1241 command: 'PRIVMSG
1242 params: (list target)
1243 trailing: joined)))
1244 (cond
1245 ((channel-target? target)
1246 (dispatch-channel-handlers conn synthetic))
1247 (else
1248 (dispatch-dm-handlers conn synthetic)))))))
1250 (define (handle-incoming-privmsg conn msg)
1251 ;; Any inbound PRIVMSG (chat, services reply, react) means
1252 ;; the connection is alive — refresh the keepalive idle
1253 ;; clock before dispatch.
1254 (enclave-conn-note-inbound! conn)
1255 (let ((sender (or (irc-message-nick msg) "?"))
1256 (target (or (irc-message-target msg) "?"))
1257 (text (or (irc-message-text msg) ""))
1258 (batch-ref (irc-message-tag msg "batch"))
1259 (msgid (or (irc-message-tag msg "msgid") "<none>")))
1260 (log-debug "Enclave PRIVMSG in"
1261 sender: sender
1262 target: target
1263 msgid: msgid
1264 text-len: (number->string (string-length text)))
1265 (cond
1266 ;; Reply from EnclaveServ — stash for the in-flight services
1267 ;; call to pick up. EnclaveServ never batches.
1268 ((services-sender? msg)
1269 (let ((tags (extract-result-tags msg)))
1270 (set-enclave-conn-services-pending!
1271 conn
1272 (cons (list 'services-reply
1273 (irc-message-text msg)
1274 tags
1275 msg)
1276 (enclave-conn-services-pending conn)))))
1277 ;; Part of an open inbound BATCH — buffer; the BATCH end
1278 ;; line will deliver the coalesced line to handlers.
1279 ((and (string? batch-ref)
1280 (inbound-batch-of conn batch-ref))
1281 (inbound-batch-append! conn batch-ref text))
1282 ;; Channel message — fan out to channel-watch handlers.
1283 ((channel-target? target)
1284 (dispatch-channel-handlers conn msg))
1285 ;; Direct message to us — dispatch to dm-watch handler.
1286 (else
1287 (dispatch-dm-handlers conn msg)))))
1289 ;; ============================================================
1290 ;; Internal: post-registration CAP REQ handler
1291 ;; ============================================================
1293 (define (handle-cap-message conn msg)
1294 (enclave-conn-note-inbound! conn)
1295 (let* ((params (irc-message-params msg))
1296 ;; `:server CAP <client> <subcmd> :<caps>`
1297 (subcmd (and (pair? params) (pair? (cdr params))
1298 (cadr params))))
1299 (cond
1300 ((or (equal? subcmd "ACK") (equal? subcmd "NAK"))
1301 (let* ((trailing (or (irc-message-trailing msg) ""))
1302 (caps (filter (lambda (s) (> (string-length s) 0))
1303 (string-split trailing " ")))
1304 (ack? (equal? subcmd "ACK")))
1305 (when ack?
1306 (set-enclave-conn-caps-acked!
1307 conn (append caps (enclave-conn-caps-acked conn))))
1308 (set-enclave-conn-caps-pending?! conn #f)
1309 (log-debug "Enclave CAP reply"
1310 subcmd: subcmd
1311 caps: trailing)))
1312 (else #f))))
1314 ;; IRCv3 standard-replies: `:server FAIL <command> <code>
1315 ;; [<context>...] :<text>`. We only consume FAIL BATCH here —
1316 ;; the reply lets `enclave-post-multiline` know the server
1317 ;; rejected our open / mid-batch / close, so we can abort and
1318 ;; fall back to per-line PRIVMSG. Other FAIL kinds (PRIVMSG,
1319 ;; etc.) just log; the handler is intentionally narrow.
1320 (define (handle-fail-message conn msg)
1321 (enclave-conn-note-inbound! conn)
1322 (let* ((params (irc-message-params msg))
1323 (command (and (pair? params) (car params)))
1324 (code (and (pair? params) (pair? (cdr params))
1325 (cadr params)))
1326 (text (or (irc-message-trailing msg) "")))
1327 (cond
1328 ((and (string? command) (string=? command "BATCH"))
1329 (log-warn "Enclave BATCH rejected by server"
1330 code: (or code "?")
1331 reason: text)
1332 (set-enclave-conn-last-batch-fail!
1333 conn (cons (or code "UNKNOWN") text)))
1334 (else
1335 (log-debug "Enclave FAIL ignored"
1336 command: (or command "?")
1337 code: (or code "?")
1338 reason: text)))))
1340 (define (install-handlers! conn)
1341 (let ((irc (enclave-conn-irc conn)))
1342 (irc-on irc 'PRIVMSG
1343 (lambda (msg)
1344 (handle-incoming-privmsg conn msg)))
1345 (irc-on irc 'BATCH
1346 (lambda (msg)
1347 (handle-incoming-batch conn msg)))
1348 (irc-on irc 'CAP
1349 (lambda (msg)
1350 (handle-cap-message conn msg)))
1351 (irc-on irc 'FAIL
1352 (lambda (msg)
1353 (handle-fail-message conn msg)))
1354 ;; Server-initiated PING — respond with a matching PONG
1355 ;; so the enclave-side keepalive treats us as alive. The
1356 ;; server's PING wire format is `PING :<server-name>`;
1357 ;; we echo whatever trailing param arrived. (sigil-irc
1358 ;; does not auto-respond to PING; this handler is the
1359 ;; server-PING regression guard the brief calls out.)
1360 (irc-on irc 'PING
1361 (lambda (msg)
1362 (handle-server-ping conn msg)))
1363 ;; Server's PONG to our client-initiated PING — clears
1364 ;; the pending-ping bookkeeping when the trailing param
1365 ;; matches.
1366 (irc-on irc 'PONG
1367 (lambda (msg)
1368 (handle-server-pong conn msg)))))
1371 ;;; Inbound `PING :<token>` from the server — echo the same
1372 ;;; trailing param back as `PONG :<token>`. The enclave-side
1373 ;;; keepalive treats this as proof the client is alive.
1374 (define (handle-server-ping conn msg)
1375 (enclave-conn-note-inbound! conn)
1376 (let* ((params (irc-message-params msg))
1377 (token (or (irc-message-trailing msg)
1378 (and (pair? params) (car params))
1379 ""))
1380 (irc (enclave-conn-irc conn)))
1381 (guard (e (else
1382 (log-warn "Apiary PONG send failed"
1383 error: (format "~a" e))))
1384 (irc-send-raw irc
1385 (string-append "PONG :" token "\r\n")))
1386 (log-debug "Apiary responded to server PING")))
1389 ;;; Inbound `PONG :<token>` clearing the matching outstanding
1390 ;;; PING. Token mismatch is logged and ignored — the inbound
1391 ;;; note above still happens (any inbound line counts as "still
1392 ;;; alive"), so a mismatch isn't fatal — it just means that PING
1393 ;;; stays outstanding until the next sweep.
1394 ;;;
1395 ;;; The match must stay EXACT: `enclave-confirm-delivery!` reads
1396 ;;; "my specific token was acked" as proof that the peer consumed
1397 ;;; the bytes written before it. A PONG that cleared some other
1398 ;;; token would turn that into a claim about a different write.
1399 (define (handle-server-pong conn msg)
1400 (enclave-conn-note-inbound! conn)
1401 (let* ((params (irc-message-params msg))
1402 (token (or (irc-message-trailing msg)
1403 ;; Some servers reply `PONG <server> :<token>`
1404 ;; (token in the trailing param, server
1405 ;; address in the middle); RFC 2812 § 3.7.3
1406 ;; allows either layout. The trailing fallback
1407 ;; below picks the param after the server
1408 ;; address when there are 2+ params.
1409 (and (pair? params)
1410 (cond
1411 ((null? (cdr params)) (car params))
1412 (else (cadr params))))
1413 "")))
1414 (cond
1415 ((and (string? token) (enclave-conn-ping-ack! conn token))
1416 (log-debug "Apiary keepalive PONG ack"))
1417 (else
1418 (log-debug "Apiary keepalive PONG stale-or-mismatched")))))
1420 ;; Polling event loop. On TLS, sigil-irc's `irc-tick` misses
1421 ;; bytes that mbedtls has buffered internally (kernel poll
1422 ;; doesn't see them), so we call `irc-process-input` directly —
1423 ;; relies on `tls-set-non-blocking!` set during connect. On raw
1424 ;; sockets `irc-tick` is fine.
1425 ;;
1426 ;; The loop re-reads `enclave-conn-irc` on every iteration so
1427 ;; the keepalive-driven reconnect path can swap in a fresh
1428 ;; irc-connection without spinning up a second loop. While
1429 ;; `reconnecting?` is set the loop sleeps idly; once the
1430 ;; reconnect goroutine clears the flag (and replaces `irc`),
1431 ;; the loop resumes against the new connection.
1432 (define (run-event-loop! conn)
1433 (guard (e (else
1434 (log-error "Enclave event loop crashed"
1435 error: (format "~a" e))))
1436 (let loop ()
1437 (cond
1438 ((enclave-conn-shutdown? conn) #f)
1439 ((enclave-conn-reconnecting? conn)
1440 ;; Yield while the reconnect goroutine rebuilds irc.
1441 (sleep 0.1)
1442 (loop))
1443 (else
1444 (let* ((irc (enclave-conn-irc conn))
1445 (sock (and irc (irc-connection-socket irc)))
1446 (tls? (and irc (irc-connection-tls? irc)))
1447 (state (and irc (irc-connection-state irc))))
1448 (cond
1449 ((or (not irc) (not sock) (null? sock))
1450 ;; Socket gone but no shutdown / reconnect flag —
1451 ;; the connection died unexpectedly. Treat as a
1452 ;; reconnect signal so the keepalive path can
1453 ;; recover; if shutdown? was meant to be set,
1454 ;; the next iteration will see it and bail.
1455 (cond
1456 ((enclave-conn-shutdown? conn) #f)
1457 (else
1458 (log-warn "Apiary event loop saw torn-down socket — triggering reconnect")
1459 (trigger-reconnect! conn)
1460 (sleep 0.1)
1461 (loop))))
1462 ((eq? state 'disconnected)
1463 ;; sigil-irc flipped state to 'disconnected on
1464 ;; EOF / read error but didn't null the socket.
1465 ;; This is the "server died but apiary's kernel
1466 ;; still holds an ESTABLISHED" path AND the
1467 ;; "server cleanly closed" path. Either way, we
1468 ;; want a reconnect.
1469 (cond
1470 ((enclave-conn-shutdown? conn) #f)
1471 (else
1472 (log-warn "Apiary event loop saw irc-state=disconnected — triggering reconnect")
1473 (trigger-reconnect! conn)
1474 (sleep 0.1)
1475 (loop))))
1476 (else
1477 (if tls?
1478 (irc-process-input irc)
1479 (irc-tick irc))
1480 (maybe-keepalive-tick! conn)
1481 (sleep 0.05)
1482 (loop)))))))
1483 (log-info "Enclave event loop ended")))
1486 ;;; Run the keepalive sweep at most every
1487 ;;; `+keepalive-poll-interval+` seconds. Cheap to call from
1488 ;;; the 50ms event-loop tick — we just compare timestamps.
1489 (define (maybe-keepalive-tick! conn)
1490 (let* ((now (current-second))
1491 (last-check (enclave-conn-last-keepalive-check conn)))
1492 (when (or (not last-check)
1493 (>= (- now last-check) +keepalive-poll-interval+))
1494 (set-enclave-conn-last-keepalive-check! conn now)
1495 (enclave-conn-keepalive-tick! conn now))))
1498 ;;; Single keepalive sweep over a single connection. Pulled
1499 ;;; out of the throttle wrapper so tests can drive it
1500 ;;; synchronously by setting `last-inbound-ts` / adding a
1501 ;;; pending PING and calling this directly.
1502 (define (enclave-conn-keepalive-tick! conn now)
1503 (: enclave-conn? number? -> any?)
1504 (cond
1505 ((enclave-conn-shutdown? conn) #f)
1506 ((enclave-conn-reconnecting? conn) #f)
1507 (else
1508 (let ((oldest-ping (enclave-conn-oldest-ping-ts conn))
1509 (last-in (enclave-conn-last-inbound-ts conn)))
1510 (cond
1511 ;; A PING has been outstanding past the PONG window.
1512 ;; Measured from the OLDEST outstanding entry, so a
1513 ;; later PING (from a post-time delivery confirmation,
1514 ;; say) can never push this deadline out.
1515 ;;
1516 ;; Loud log + reconnect — the brief insists on INFO-
1517 ;; visible failure so an operator reading apiary's
1518 ;; log can correlate "send-channel didn't arrive" to
1519 ;; "the keepalive timed out N seconds before."
1520 ((and oldest-ping
1521 (> (- now oldest-ping) +keepalive-pong-timeout+))
1522 (log-warn "Apiary keepalive PONG timeout — connection appears dead, reconnecting"
1523 sent-sec-ago: (number->string (- now oldest-ping)))
1524 (trigger-reconnect! conn))
1525 ;; Nothing in flight and no INBOUND traffic for longer
1526 ;; than the idle threshold — emit a fresh PING.
1527 ;;
1528 ;; Deliberately blind to how much WE have sent: our own
1529 ;; writes say nothing about the peer.
1530 ;;
1531 ;; A conn whose clock has never been set counts as idle
1532 ;; rather than as "not yet due". Every conn built in this
1533 ;; module seeds it at connect, but the constructor is
1534 ;; exported and its default is #f, so a second
1535 ;; construction site that forgot to seed it would
1536 ;; otherwise disable the keepalive silently and for ever
1537 ;; — a worse version of the defect this file just
1538 ;; removed.
1539 ((and (not oldest-ping)
1540 (or (not last-in)
1541 (> (- now last-in) +keepalive-idle-threshold+)))
1542 (emit-keepalive-ping! conn now))
1543 (else #f))))))
1546 ;;; Put a client→server PING on the wire and record it as
1547 ;;; outstanding. Returns the token on success, #f if the write
1548 ;;; itself failed (in which case a reconnect has been triggered).
1549 ;;;
1550 ;;; Deliberately does NOT refresh the inbound clock: we just
1551 ;;; WROTE, which is not evidence of anything. The reason the
1552 ;;; keepalive does not immediately re-PING is that the entry is
1553 ;;; now outstanding, and the idle branch requires an empty list.
1554 (define (send-ping! conn now)
1555 (: enclave-conn? number? -> any?)
1556 (let ((token (generate-keepalive-token))
1557 (irc (enclave-conn-irc conn))
1558 (sent? #f))
1559 ;; Record BEFORE the write. If the write half-succeeds and
1560 ;; then raises, the peer may still answer, and an entry we
1561 ;; never recorded could not be acked — leaving a PONG that
1562 ;; matches nothing and, worse, no deadline on the link.
1563 (enclave-conn-ping-add! conn token now)
1564 (guard (e (else
1565 (log-warn "Apiary keepalive PING send failed — triggering reconnect"
1566 error: (format "~a" e))
1567 (enclave-conn-ping-ack! conn token)
1568 (trigger-reconnect! conn)))
1569 (irc-send-raw irc
1570 (string-append "PING :" token "\r\n"))
1571 (set! sent? #t))
1572 ;; Only claim a PING went out when the write returned. The
1573 ;; guard above falls through to here, so an unconditional log
1574 ;; line would report "PING out" for a send that raised — in
1575 ;; exactly the DEBUG log the harness experiments parse.
1576 ;;
1577 ;; Token never logged at INFO — defence in depth so a
1578 ;; misbehaved peer reading a log tail can't forge a PONG.
1579 (when sent?
1580 (log-debug "Apiary keepalive PING out"
1581 token-prefix: (safe-token-prefix token)
1582 outstanding: (number->string
1583 (length (enclave-conn-pending-pings conn)))))
1584 (and sent? token)))
1586 ;;; Keepalive's own PING. Thin wrapper so the sweep reads as
1587 ;;; intent rather than mechanism.
1588 (define (emit-keepalive-ping! conn now)
1589 (send-ping! conn now))
1592 ;;; Trigger the reconnect path. Idempotent on consecutive
1593 ;;; calls — only the first one starts the goroutine; further
1594 ;;; calls during the same reconnect window are no-ops.
1595 (define (trigger-reconnect! conn)
1596 (cond
1597 ((enclave-conn-shutdown? conn) #f)
1598 ((enclave-conn-reconnecting? conn) #f)
1599 (else
1600 (set-enclave-conn-reconnecting?! conn #t)
1601 ;; Drop the pending-ping bookkeeping — anything we sent
1602 ;; on the old socket is moot. Reset reconnect-attempt
1603 ;; ONLY on success; preserve it across multiple kicks of
1604 ;; this function within a single outage so the backoff
1605 ;; correctly compounds.
1606 (enclave-conn-pings-clear! conn)
1607 ;; Best-effort close of the dead irc. If sigil-irc's
1608 ;; disconnect path raises (the socket is already half-
1609 ;; gone), swallow the exception — we don't want it to
1610 ;; abort the reconnect goroutine spawn below.
1611 (guard (e (else
1612 (log-debug "Apiary close-during-reconnect ignored"
1613 error: (format "~a" e))))
1614 (let ((old-irc (enclave-conn-irc conn)))
1615 (when old-irc
1616 (irc-disconnect old-irc "Apiary keepalive timeout"))))
1617 (go (reconnect-loop! conn)))))
1620 ;;; Delay before attempt N of a reconnect/connect sequence.
1621 ;;; Exponential from `+reconnect-backoff-min+`, capped at
1622 ;;; `+reconnect-backoff-max+`.
1623 ;;;
1624 ;;; This schedule was previously wrong for a reason worth
1625 ;;; recording: 1s/2s/4s was sized against a FAST failure, and each
1626 ;;; attempt actually cost ~135 s, so the "backoff" between attempts
1627 ;;; was noise next to the attempts themselves and the process was
1628 ;;; wedged essentially continuously. Bounding the connect is what
1629 ;;; makes this schedule mean what it says. It is kept aggressive at
1630 ;;; the start deliberately — with a 5 s bound the early retries are
1631 ;;; cheap, and fast recovery from a brief blip is worth more than
1632 ;;; the small cost of a couple of extra attempts.
1633 (define (reconnect-delay-for attempt)
1634 (: number? -> number?)
1635 (let ((raw (* +reconnect-backoff-min+ (expt 2 (- attempt 1)))))
1636 (min +reconnect-backoff-max+
1637 (max +reconnect-backoff-min+ raw))))
1639 ;;; Report link status through the conn's optional status hook.
1640 ;;; Never lets a badly-behaved hook break the reconnect loop.
1641 ;;;
1642 ;;; `detail` of #f means "I have no NEW diagnosis — keep whatever
1643 ;;; the last real failure was". That distinction is load-bearing.
1644 ;;; An earlier version passed the literal string "reconnecting"
1645 ;;; here before each backoff sleep, which OVERWROTE the classified
1646 ;;; failure for the whole sleep. Since the sleep grows to 60s while
1647 ;;; an attempt costs ~5s, roughly 92% of tool calls during a
1648 ;;; sustained outage rendered "last failure: reconnecting" — the
1649 ;;; exact undifferentiated non-answer this module exists to
1650 ;;; replace, reintroduced by the plumbing that reports it.
1651 (define (report-link-status! conn state detail attempt next-delay)
1652 (let ((hook (enclave-conn-status-hook conn)))
1653 (when hook
1654 (guard (e (else
1655 (log-debug "Apiary status hook raised"
1656 error: (format "~a" e))))
1657 (hook state detail attempt next-delay)))))
1659 ;;; Report a successful (re)connect.
1660 ;;;
1661 ;;; A named procedure rather than an inline `report-link-status!`
1662 ;;; call so the VALUES it reports can be pinned by a test. They are
1663 ;;; easy to get wrong in a way that only shows up later: `detail`
1664 ;;; is rendered exclusively as "last failure: <detail>", so writing
1665 ;;; anything success-flavoured here — the obvious "connected" —
1666 ;;; produces "last failure: connected" the next time the session
1667 ;;; drops. And the attempt counter resets to 0 because a stale
1668 ;;; count attached to a healthy link is worse than no count.
1669 (define (report-link-connected! conn)
1670 (: enclave-conn? -> any?)
1671 (report-link-status! conn 'connected "" 0 #f))
1673 ;;; Backoff-driven reconnect loop. Tries do-reconnect! once
1674 ;;; per attempt; on success resets the attempt counter and
1675 ;;; clears the reconnecting? flag. On failure, doubles the
1676 ;;; delay (capped at +reconnect-backoff-max+) and tries
1677 ;;; again, until shutdown? is set.
1678 ;;;
1679 ;;; `do-reconnect!` RETURNS a `connect-outcome` rather than
1680 ;;; raising, so the classified failure kind survives all the way
1681 ;;; to the status hook and from there to the tool surface — a
1682 ;;; caller gets "connect timed out at host:port, attempt 4, next
1683 ;;; retry in 8s" instead of a flat "not connected". The `guard`
1684 ;;; remains for genuinely unexpected exceptions out of the
1685 ;;; handshake path, which are classified 'other rather than
1686 ;;; guessed at.
1687 (define (reconnect-loop! conn)
1688 (cond
1689 ((enclave-conn-shutdown? conn)
1690 (set-enclave-conn-reconnecting?! conn #f)
1691 #f)
1692 (else
1693 (let* ((attempt (+ 1 (enclave-conn-reconnect-attempt conn)))
1694 (delay (reconnect-delay-for attempt)))
1695 (set-enclave-conn-reconnect-attempt! conn attempt)
1696 (log-info "Apiary reconnecting"
1697 attempt: (number->string attempt)
1698 delay-sec: (number->string delay))
1699 ;; #f detail: announce that an attempt is scheduled without
1700 ;; destroying the classified reason the last one failed.
1701 (report-link-status! conn 'connecting #f attempt delay)
1702 (sleep delay)
1703 (cond
1704 ((enclave-conn-shutdown? conn)
1705 (set-enclave-conn-reconnecting?! conn #f)
1706 #f)
1707 (else
1708 (let ((outcome
1709 (guard (e (else
1710 (connect-outcome
1711 kind: 'other
1712 detail: (format "~a" e))))
1713 (do-reconnect! conn))))
1714 (cond
1715 ((connect-outcome-ok? outcome)
1716 (set-enclave-conn-reconnect-attempt! conn 0)
1717 (set-enclave-conn-reconnecting?! conn #f)
1718 (log-info "Apiary reconnected"
1719 after-attempts: (number->string attempt))
1720 (report-link-connected! conn))
1721 (else
1722 (log-warn "Apiary reconnect attempt failed"
1723 attempt: (number->string attempt)
1724 error: (connect-outcome-message outcome))
1725 (report-link-status!
1726 conn 'failed (connect-outcome-message outcome)
1727 attempt (reconnect-delay-for (+ attempt 1)))
1728 ;; Tail-call into the next attempt — the
1729 ;; backoff counter is bumped at the top of
1730 ;; this function and the sleep window grows.
1731 (reconnect-loop! conn))))))))))
1734 ;;; Best-effort close of a partial irc-connection from a
1735 ;;; failed reconnect attempt. Swallows exceptions from the
1736 ;;; close path (the socket is often half-gone already; sigil-
1737 ;;; irc's disconnect can raise on a torn-down socket and we
1738 ;;; don't want that to abort the retry).
1739 (define (cleanup-partial-irc! irc reason)
1740 (guard (e (else
1741 (log-debug "Apiary partial-irc cleanup ignored"
1742 reason: reason
1743 error: (format "~a" e))))
1744 (when irc
1745 (irc-disconnect irc reason))))
1748 ;;; Build a fresh irc-connection and do the full
1749 ;;; CAP/SASL/registration + post-registration cap negotiation
1750 ;;; + channel rejoin sequence. RETURNS a `connect-outcome`; a
1751 ;;; non-'ok kind is a retryable failure the caller
1752 ;;; (`reconnect-loop!`) turns into a backoff retry, and the kind
1753 ;;; is what reaches the operator-facing surface.
1754 ;;;
1755 ;;; Note: We DO NOT reinstall the bridge handlers (in
1756 ;;; (apiary tools)) — those mutate module-global watcher
1757 ;;; lists and re-installing would duplicate. We only re-
1758 ;;; install the sigil-irc handlers (which live on the
1759 ;;; irc-connection itself, so they DO need to be re-attached
1760 ;;; to the new irc-connection record).
1761 (define (do-reconnect! conn)
1762 (: enclave-conn? -> connect-outcome?)
1763 (let* ((config (enclave-conn-config conn))
1764 (transport (open-enclave-transport config)))
1765 (cond
1766 ((not (connect-outcome-ok? transport)) transport)
1767 (else
1768 (let ((new-irc (irc-connection-on-socket
1769 config (connect-outcome-socket transport))))
1770 (log-debug "Apiary reconnect: transport open, registering")
1771 (set-enclave-conn-irc! conn new-irc)
1772 ;; Reset post-registration cap state — caps must be
1773 ;; renegotiated against the new socket.
1774 (set-enclave-conn-caps-acked! conn '())
1775 (set-enclave-conn-caps-pending?! conn #f)
1776 (install-handlers! conn)
1777 (when (enclave-config-tls? config)
1778 (let ((sock (irc-connection-socket new-irc)))
1779 (when sock (tls-set-non-blocking! sock))))
1780 ;; Wait for 001 RPL_WELCOME. This phase is already
1781 ;; non-blocking: it drives ticks and sleeps, so the
1782 ;; scheduler keeps running other fibers throughout.
1783 (cond
1784 ((not (await-registration! new-irc
1785 (enclave-config-tls? config)
1786 +reconnect-handshake-timeout+))
1787 (cleanup-partial-irc! new-irc "Apiary registration timed out")
1788 (connect-outcome
1789 kind: 'registration
1790 detail: (string-append
1791 "no 001 within "
1792 (number->string +reconnect-handshake-timeout+)
1793 "s from "
1794 (endpoint-label (enclave-config-host config)
1795 (enclave-config-port config)))))
1796 (else
1797 ;; Caps + JOINs use the same wait pattern — drive ticks
1798 ;; locally until the negotiation finishes / channels are
1799 ;; sent, then return to let the main event loop resume.
1800 (negotiate-extra-caps! conn)
1801 (let ((channels (split-channels
1802 (enclave-config-channel config))))
1803 (for-each (lambda (ch)
1804 (when (and (string? ch)
1805 (> (string-length ch) 0))
1806 (log-debug "Apiary reconnect: rejoining channel"
1807 channel: ch)
1808 (irc-join new-irc ch)))
1809 channels))
1810 ;; Seed the inbound clock. This is NOT an outbound
1811 ;; touch in disguise: completing registration means
1812 ;; the server sent us 001, so inbound evidence
1813 ;; genuinely just arrived. Seeding it also stops the
1814 ;; keepalive re-PINGing a socket that is one second
1815 ;; old.
1816 (enclave-conn-note-inbound! conn)
1817 (connect-outcome kind: 'ok))))))))
1820 ;;; Drive `irc-tick` / `irc-process-input` against `new-irc`
1821 ;;; until either the connection finishes registration (saw
1822 ;;; 001 RPL_WELCOME) or the deadline expires. Returns #t on
1823 ;;; success, #f on timeout. Pulled out of `do-reconnect!` so
1824 ;;; tests can drive it without spinning a real reconnect.
1825 (define (await-registration! new-irc tls? timeout-sec)
1826 (: any? any? number? -> boolean?)
1827 (let ((deadline (+ (current-second) timeout-sec)))
1828 (let wait ()
1829 (cond
1830 ((irc-connected? new-irc) #t)
1831 ((> (current-second) deadline) #f)
1832 (else
1833 (if tls?
1834 (irc-process-input new-irc)
1835 (irc-tick new-irc))
1836 (sleep 0.05)
1837 (wait))))))
1839 ;; ============================================================
1840 ;; Public: connect / disconnect
1841 ;; ============================================================
1843 ;;; Open an Enclave (IRC) connection using the configured user +
1844 ;;; token as SASL credentials, returning
1845 ;;; `(connect-outcome . enclave-conn-or-#f)`.
1846 ;;;
1847 ;;; Every phase is bounded: the connect and TLS handshake by the
1848 ;;; config's timeouts, registration by `services-timeout`. The
1849 ;;; caller therefore learns the outcome within a known window
1850 ;;; instead of the process losing its scheduler to a syscall for
1851 ;;; minutes at a time.
1852 ;;;
1853 ;;; This is the form callers should use when they intend to RETRY,
1854 ;;; because the `connect-outcome` says what actually went wrong.
1855 ;;; `enclave-connect` wraps it for callers that just want a
1856 ;;; connection or an exception.
1857 (define (enclave-connect/detail config)
1858 (: enclave-config? -> pair?)
1859 (cond
1860 ((not (enclave-config-ready? config))
1861 (cons (connect-outcome
1862 kind: 'config
1863 detail: "need APIARY_ENCLAVE_HOST, APIARY_USER and APIARY_TOKEN")
1864 #f))
1865 (else
1866 (log-info "Enclave connecting"
1867 host: (enclave-config-host config)
1868 port: (enclave-config-port config)
1869 tls: (if (enclave-config-tls? config) "yes" "no")
1870 nick: (enclave-config-user config)
1871 connect-timeout-sec: (number->string
1872 (enclave-config-connect-timeout config))
1873 token: (safe-token-prefix
1874 (enclave-config-token config)))
1875 (let ((transport (open-enclave-transport config)))
1876 (cond
1877 ((not (connect-outcome-ok? transport))
1878 (log-warn "Enclave connect failed"
1879 reason: (connect-outcome-message transport))
1880 (cons transport #f))
1881 (else
1882 (let* ((irc (irc-connection-on-socket
1883 config (connect-outcome-socket transport)))
1884 ;; Seed the keepalive activity clock at connect
1885 ;; time so a freshly-connected idle bot doesn't
1886 ;; immediately PING (the 60s idle threshold runs
1887 ;; from "now" not from "1970").
1888 (conn (enclave-conn irc: irc config: config
1889 last-inbound-ts: (current-second))))
1890 (install-handlers! conn)
1891 ;; Switch TLS to non-blocking so `tls-read` returns ""
1892 ;; immediately when no data is available — the polling
1893 ;; event loop expects that.
1894 (when (enclave-config-tls? config)
1895 (let ((sock (irc-connection-socket irc)))
1896 (when sock (tls-set-non-blocking! sock))))
1897 (cond
1898 ;; Drive registration here rather than from the
1899 ;; event loop, so a registration failure is a
1900 ;; classified outcome the caller can retry on
1901 ;; instead of a goroutine that quietly never
1902 ;; finishes.
1903 ;; `+reconnect-handshake-timeout+`, NOT
1904 ;; `services-timeout`. This used to use the services
1905 ;; timeout (default 5 s), which is the budget for an
1906 ;; EnclaveServ request/reply and has nothing to do
1907 ;; with registration. The reconnect path already uses
1908 ;; 10 s here, and the comment on that constant records
1909 ;; why 5 s proved too tight against a server that is
1910 ;; still coming up. With a boot RETRY loop in front of
1911 ;; it, too tight is worse than it was: a server whose
1912 ;; SASL→001 takes 6 s would produce an endless cycle
1913 ;; of half-registrations that never completes, while
1914 ;; the reconnect path against the same server would
1915 ;; succeed. One bound, both paths.
1916 ((not (await-registration!
1917 irc
1918 (enclave-config-tls? config)
1919 +reconnect-handshake-timeout+))
1920 (cleanup-partial-irc! irc "Apiary registration timed out")
1921 (cons (connect-outcome
1922 kind: 'registration
1923 detail: (string-append
1924 "no 001 within "
1925 (number->string
1926 +reconnect-handshake-timeout+)
1927 "s from "
1928 (endpoint-label
1929 (enclave-config-host config)
1930 (enclave-config-port config))))
1931 #f))
1932 (else
1933 (go (run-event-loop! conn))
1934 (log-info "Enclave connected"
1935 nick: (irc-connection-current-nick irc))
1936 ;; Layer the IRCv3 caps that sigil-irc doesn't
1937 ;; request for us on top of `sasl`. The negotiation
1938 ;; is best-effort — caps the server NAKs (or the
1939 ;; spec hasn't settled on yet) just fall back to
1940 ;; per-line PRIVMSG / no-tag emit.
1941 (negotiate-extra-caps! conn)
1942 ;; Auto-join the coordination channel (and any
1943 ;; extras encoded in CSV form for multi-channel
1944 ;; setups).
1945 (let ((channels (split-channels
1946 (enclave-config-channel config))))
1947 (for-each (lambda (ch)
1948 (when (and (string? ch)
1949 (> (string-length ch) 0))
1950 (log-debug "Joining channel" channel: ch)
1951 (irc-join irc ch)))
1952 channels))
1953 (cons (connect-outcome kind: 'ok) conn))))))))))
1955 ;;; Open an Enclave connection, or raise. The message carries the
1956 ;;; classified diagnosis rather than an echo of the configured
1957 ;;; host:port.
1958 (define (enclave-connect config)
1959 (: enclave-config? -> enclave-conn?)
1960 (let* ((result (enclave-connect/detail config))
1961 (outcome (car result))
1962 (conn (cdr result)))
1963 (or conn
1964 (error (string-append "enclave-connect: "
1965 (connect-outcome-message outcome))))))
1967 ;;; Send `CAP REQ :<extra-caps>` for the layered set
1968 ;;; `+apiary-extra-caps+` and wait briefly for ACK / NAK so
1969 ;;; downstream `enclave-post-multiline` calls know whether to
1970 ;;; emit BATCH wrappers. Best-effort: a missing ACK falls
1971 ;;; through silently and per-line PRIVMSG fallback kicks in.
1972 (define (negotiate-extra-caps! conn)
1973 (let* ((irc (enclave-conn-irc conn))
1974 (config (enclave-conn-config conn))
1975 (timeout (enclave-config-services-timeout config))
1976 (deadline (+ (current-second) timeout)))
1977 (set-enclave-conn-caps-pending?! conn #t)
1978 (irc-send-raw irc
1979 (string-append "CAP REQ :" +apiary-extra-caps+ "\r\n"))
1980 (let wait ()
1981 (cond
1982 ((not (enclave-conn-caps-pending? conn)) #t)
1983 ((> (current-second) deadline)
1984 ;; Treat a silent server as "caps not ACKed" — the
1985 ;; multiline emit path falls back to per-line PRIVMSG.
1986 (set-enclave-conn-caps-pending?! conn #f)
1987 (log-warn "Enclave CAP REQ timed out — falling back"
1988 requested: +apiary-extra-caps+))
1989 (else
1990 (sleep 0.05)
1991 (wait))))
1992 (log-info "Enclave caps acked"
1993 acked: (string-join (enclave-conn-caps-acked conn) ","))))
1995 ;;; Generate a short opaque reftag for client→server BATCH
1996 ;;; wrappers. We don't need cryptographic strength — the tag
1997 ;;; just needs to be unique among open batches on this
1998 ;;; connection. 8 hex chars from `current-second` + a counter
1999 ;;; would suffice; we use 6 random-ish bytes via the IRCv3
2000 ;;; conventional shape (alphanumeric, ≤16 chars).
2001 (define +reftag-counter+ (list 0))
2003 (define (make-client-batch-reftag)
2004 ;; Only needs uniqueness among open batches on this conn (v1
2005 ;; allows one at a time). A monotonic counter is sufficient;
2006 ;; reftags never need to round-trip through DNS, can stay
2007 ;; short.
2008 (let* ((c (+ 1 (car +reftag-counter+))))
2009 (set-car! +reftag-counter+ c)
2010 (string-append "ap" (number->string c))))
2012 ;;; Disconnect cleanly with an optional QUIT message. Marks
2013 ;;; the conn as `shutdown?` so the keepalive sweep + reconnect
2014 ;;; goroutine bail out instead of fighting the teardown.
2015 (define (enclave-disconnect conn . quit-message)
2016 (: enclave-conn? string? ... -> void?)
2017 (set-enclave-conn-shutdown?! conn #t)
2018 (enclave-conn-pings-clear! conn)
2019 (let ((irc (enclave-conn-irc conn)))
2020 (when (and irc (irc-connection-socket irc))
2021 (apply irc-disconnect irc quit-message))))
2023 ;; ============================================================
2024 ;; Public: channel posting + watchers
2025 ;; ============================================================
2027 ;;; One step of the confirmation wait: has this token been
2028 ;;; settled, and how? Returns 'wait while the answer is still
2029 ;;; genuinely unknown.
2030 ;;;
2031 ;;; Extracted from the wait loop so it can be tested WITHOUT a
2032 ;;; live connection. That is not tidiness: the loop is only
2033 ;;; reachable past `send-ping!`, which needs a real socket, so
2034 ;;; while this decision lived inline NOTHING could exercise it —
2035 ;;; and a sabotage reverting it to key on absence (the HIGH this
2036 ;;; file already carries a comment about) left the entire unit
2037 ;;; suite green. A decision this load-bearing has to be reachable
2038 ;;; by a test.
2039 ;;;
2040 ;;; Order matters. POSITIVE evidence is checked FIRST, so a PONG
2041 ;;; that genuinely arrived is honoured even if the link dropped
2042 ;;; immediately afterwards.
2043 (define (confirm-verdict conn token irc-at-write deadline)
2044 (: enclave-conn? string? any? number? -> symbol?)
2045 (cond
2046 ;; The peer answered THIS token. Not "the token left the
2047 ;; outstanding list" — see `enclave-conn-ping-acked?`.
2048 ((enclave-conn-ping-acked? conn token) 'confirmed)
2049 ;; The link is known bad, so no answer is coming — and the
2050 ;; token may well have been cleared without one.
2051 ((or (enclave-conn-shutdown? conn)
2052 (enclave-conn-reconnecting? conn))
2053 'link-down)
2054 ;; The socket we wrote to has been replaced.
2055 ((and irc-at-write
2056 (not (eq? irc-at-write (enclave-conn-irc conn))))
2057 'link-changed)
2058 ((> (current-second) deadline) 'unconfirmed)
2059 (else 'wait)))
2061 ;;; Ask the peer to prove it consumed what we just wrote.
2062 ;;;
2063 ;;; Returns `'confirmed`, `'unconfirmed`, or `'not-ready`.
2064 ;;;
2065 ;;; WHY THIS WORKS, and what it does and does not prove.
2066 ;;;
2067 ;;; A successful `irc-send-raw` means the local kernel accepted
2068 ;;; the bytes. On a blackholed route every write "succeeds"
2069 ;;; forever while nothing arrives, which is how `send-channel`
2070 ;;; came to report `Broadcast to <channel> (1 line)` for 14
2071 ;;; consecutive posts that were never delivered (measured
2072 ;;; 2026-08-04, against an independent observer on a healthy
2073 ;;; connection).
2074 ;;;
2075 ;;; So: write the message, THEN send a PING carrying a fresh
2076 ;;; random token, and wait for that exact token to come back.
2077 ;;; TCP is ordered, so a PONG for a token sent AFTER the message
2078 ;;; means the peer's parser has already consumed the message.
2079 ;;; The ordering is what makes this evidence rather than a
2080 ;;; freshness heuristic — a reading of the idle clock taken
2081 ;;; BEFORE the write says nothing whatsoever about the write.
2082 ;;;
2083 ;;; What it does NOT prove: that the server DELIVERED the message
2084 ;;; to the channel or to any member. It proves receipt and
2085 ;;; parsing, not fan-out. That is a large improvement over "we
2086 ;;; wrote to a socket" and it is still short of a delivery
2087 ;;; receipt; callers must not describe it as one.
2088 ;;;
2089 ;;; Two structural guards, both load-bearing:
2090 ;;;
2091 ;;; 1. This only ever ADDS to the outstanding-PING list. If it
2092 ;;; could re-stamp an existing entry, a caller posting more
2093 ;;; often than `+keepalive-pong-timeout+` would postpone its
2094 ;;; own dead-link deadline indefinitely — the exact defect
2095 ;;; this change removes from the idle clock, moved one
2096 ;;; function over.
2097 ;;; 2. If a PING has ALREADY been outstanding longer than the
2098 ;;; budget, the answer is known: there is no liveness
2099 ;;; evidence. Say so immediately rather than sending another
2100 ;;; PING and spending the budget again. That also bounds the
2101 ;;; list during a long outage — only the first post pays the
2102 ;;; wait.
2103 ;;;
2104 ;;; Useful side effect: a PING sent at post time seeds the
2105 ;;; keepalive. A busy bot now reaches its PONG timeout from the
2106 ;;; moment it posted into a dead link, instead of never reaching
2107 ;;; it at all.
2108 (define (enclave-confirm-delivery! conn irc-at-write)
2109 (: enclave-conn? any? -> symbol?)
2110 (let ((overdue-ts (enclave-conn-oldest-ping-ts conn)))
2111 (cond
2112 ((enclave-conn-shutdown? conn) 'not-ready)
2113 ((enclave-conn-reconnecting? conn) 'link-down)
2114 ;; The socket we wrote to is no longer the socket we have.
2115 ;; A PONG on the NEW connection would say nothing about a
2116 ;; message written to the OLD one, so refuse to interpret
2117 ;; it. An `irc-at-write` of #f opts out, for callers that
2118 ;; do not track which socket they wrote to.
2119 ((and irc-at-write
2120 (not (eq? irc-at-write (enclave-conn-irc conn))))
2121 'link-changed)
2122 ;; We already know: a PING has gone unanswered for longer
2123 ;; than the budget. Checked BEFORE `ready?` on purpose — an
2124 ;; overdue PING settles the question whatever the session
2125 ;; state says, and putting it first means the guard is
2126 ;; reachable, and therefore testable, without a live
2127 ;; irc-connection.
2128 ((and overdue-ts
2129 (> (- (current-second) overdue-ts) +post-confirm-timeout+))
2130 (log-debug "Apiary post-confirm skipped — ping already overdue"
2131 overdue-sec: (number->string
2132 (- (current-second) overdue-ts)))
2133 'no-evidence)
2134 ((not (enclave-conn-ready? conn)) 'link-down)
2135 ;; Burst backstop: a flood of posts inside one budget must
2136 ;; not grow the outstanding list without bound.
2137 ((>= (length (enclave-conn-pending-pings conn))
2138 +max-outstanding-pings+)
2139 (log-debug "Apiary post-confirm skipped — too many pings outstanding")
2140 'no-evidence)
2141 (else
2142 (let* ((now (current-second))
2143 (token (send-ping! conn now)))
2144 (cond
2145 ((not token) 'link-down)
2146 (else
2147 (let ((deadline (+ (current-second) +post-confirm-timeout+)))
2148 (let wait ()
2149 (let ((verdict (confirm-verdict conn token irc-at-write
2150 deadline)))
2151 (cond
2152 ((not (eq? verdict 'wait))
2153 (cond
2154 ((eq? verdict 'confirmed)
2155 (log-debug "Apiary post-confirm confirmed"
2156 elapsed-ms:
2157 (number->string
2158 (round (* 1000 (- (current-second)
2159 now))))))
2160 ((eq? verdict 'unconfirmed)
2161 (log-warn "Apiary post-confirm UNCONFIRMED — no PONG within budget"
2162 budget-sec:
2163 (number->string
2164 +post-confirm-timeout+))))
2165 verdict)
2166 (else
2167 ;; Yields to the cooperative scheduler so the
2168 ;; event-loop goroutine can read the socket
2169 ;; and ack our token.
2170 (sleep +post-confirm-poll+)
2171 (wait)))))))))))))
2173 ;;; Send a PRIVMSG to a channel (or any target). Always uses the
2174 ;;; `:trailing` form for the body so single-token messages like
2175 ;;; `connected.` arrive intact — sigil-irc's `irc-privmsg`
2176 ;;; otherwise omits the `:` for spaceless / non-colon-leading
2177 ;;; bodies, and the receiving parser treats them as middle
2178 ;;; parameters with empty trailing.
2179 (define (enclave-post conn target text)
2180 (: enclave-conn? string? string? -> void?)
2181 (let ((irc (enclave-conn-irc conn)))
2182 (irc-send-raw irc
2183 (string-append "PRIVMSG " target " :" text "\r\n"))))
2185 ;;; Send N PRIVMSGs to `target` as a single logical message.
2186 ;;; When the server ACKed `draft/multiline`, the lines are
2187 ;;; wrapped in a `BATCH +<reftag> draft/multiline <target>`
2188 ;;; envelope so receivers (e.g. Goguma on a phone) render the
2189 ;;; group as one collapsed message.
2190 ;;;
2191 ;;; If the server rejects the BATCH OPEN with a `FAIL BATCH …`
2192 ;;; reply (target the server doesn't accept, type unsupported,
2193 ;;; etc.), we abort the in-flight batch and re-send the lines
2194 ;;; as per-line PRIVMSGs so the user actually receives the
2195 ;;; content. Same fallback applies when the cap wasn't ACKed
2196 ;;; in the first place.
2197 ;;;
2198 ;;; Returns:
2199 ;;; `'sent-batch` — BATCH wrapper used, no FAIL observed
2200 ;;; `'sent-per-line` — per-line fallback (cap missing, FAIL,
2201 ;;; or single-line content)
2202 ;;; `'sent-empty` — `lines` was empty
2203 (define (enclave-post-multiline conn target lines)
2204 (: enclave-conn? string? list? -> symbol?)
2205 (let ((irc (enclave-conn-irc conn)))
2206 ;; NOTE: no activity touch here, and none in `enclave-post`
2207 ;; or `enclave-post-react` either. Writing is not evidence
2208 ;; the peer is alive — see the `last-inbound-ts` field
2209 ;; comment. Callers that need to know whether the peer
2210 ;; actually took these bytes call
2211 ;; `enclave-confirm-delivery!` afterwards.
2212 (cond
2213 ((null? lines) 'sent-empty)
2214 ;; Single-line content doesn't benefit from BATCH; route
2215 ;; through the normal post path so the privacy-friendly
2216 ;; trailing form is used uniformly.
2217 ((null? (cdr lines))
2218 (enclave-post conn target (car lines))
2219 'sent-per-line)
2220 ((not (enclave-conn-cap-acked? conn +cap-multiline+))
2221 (for-each (lambda (line) (enclave-post conn target line)) lines)
2222 'sent-per-line)
2223 (else
2224 (let ((reftag (make-client-batch-reftag)))
2225 ;; Reset the FAIL slot and send BATCH OPEN. Wait a
2226 ;; brief window for the server to reject (synchronous
2227 ;; validation: the server emits FAIL within a single
2228 ;; round-trip). 150ms is generous for localhost +
2229 ;; comfortable for typical WAN latency.
2230 (set-enclave-conn-last-batch-fail! conn #f)
2231 (irc-send-raw irc
2232 (string-append "BATCH +" reftag " draft/multiline "
2233 target "\r\n"))
2234 (sleep 0.15)
2235 (cond
2236 ((enclave-conn-last-batch-fail conn)
2237 ;; Server rejected the OPEN. Don't send the inner
2238 ;; PRIVMSGs (would draw cascading FAILs). Don't
2239 ;; send a CLOSE either (the BATCH never opened on
2240 ;; the server's side, so CLOSE would also FAIL).
2241 ;; Fall back to per-line PRIVMSG — that's what the
2242 ;; user actually wants.
2243 (set-enclave-conn-last-batch-fail! conn #f)
2244 (log-info "Enclave BATCH rejected — falling back per-line"
2245 target: target lines: (length lines))
2246 (for-each
2247 (lambda (line) (enclave-post conn target line)) lines)
2248 'sent-per-line)
2249 (else
2250 (for-each
2251 (lambda (line)
2252 (irc-send-raw irc
2253 (string-append "@batch=" reftag " PRIVMSG "
2254 target " :" line "\r\n")))
2255 lines)
2256 (irc-send-raw irc
2257 (string-append "BATCH -" reftag "\r\n"))
2258 ;; A final FAIL pass: rare, but if one of the
2259 ;; inner PRIVMSGs tripped a per-line cap-overflow
2260 ;; the server would have aborted the batch. The
2261 ;; receiving end already accumulated whatever
2262 ;; lines arrived before the abort, so re-emitting
2263 ;; per-line on top would double up. Just surface
2264 ;; the FAIL by clearing the flag and returning
2265 ;; 'sent-batch — caller logs/reports.
2266 (sleep 0.05)
2267 (set-enclave-conn-last-batch-fail! conn #f)
2268 'sent-batch)))))))
2270 ;;; Send a reaction PRIVMSG. The wire carries BOTH client-only
2271 ;;; tags `+draft/react` and `+draft/reaction` (the older +
2272 ;;; newer slug variants — different clients ratchet to
2273 ;;; different ones; emit both so any negotiator picks it up)
2274 ;;; plus `+draft/reply` pointing at the target msgid.
2275 ;;;
2276 ;;; Recipients with `message-tags` negotiated see the tags and
2277 ;;; render the body as a reaction; recipients without them see
2278 ;;; a plain `:emoji:` PRIVMSG (graceful degradation).
2279 (define (enclave-post-react conn target msgid emoji)
2280 (: enclave-conn? string? string? string? -> void?)
2281 (let ((irc (enclave-conn-irc conn)))
2282 (irc-send-raw irc
2283 (string-append
2284 "@+draft/react=" emoji
2285 ";+draft/reaction=" emoji
2286 ";+draft/reply=" msgid
2287 " PRIVMSG " target " :" emoji "\r\n"))))
2289 ;;; Register a handler for incoming PRIVMSGs to a channel. The
2290 ;;; handler is called with (sender-nick text raw-irc-message).
2291 ;;; Multiple handlers per channel are supported.
2292 (define (enclave-watch-channel conn channel handler)
2293 (: enclave-conn? string? procedure? -> void?)
2294 (let* ((key (string-downcase channel))
2295 (existing (assoc key *channel-watchers*)))
2296 (set! *channel-watchers*
2297 (if existing
2298 (map (lambda (e)
2299 (if (equal? (car e) key)
2300 (cons key (cons handler (cdr e)))
2301 e))
2302 *channel-watchers*)
2303 (cons (cons key (list handler))
2304 *channel-watchers*)))))
2306 ;;; Register a handler for direct PRIVMSGs to our current nick.
2307 (define (enclave-watch-dms conn handler)
2308 (: enclave-conn? procedure? -> void?)
2309 (set! *dm-watchers* (cons handler *dm-watchers*)))
2311 ;; ============================================================
2312 ;; Public: EnclaveServ services-call + bot lifecycle
2313 ;; ============================================================
2315 ;;; Send a single command to EnclaveServ and return its tagged
2316 ;;; reply. Blocks the calling goroutine until a reply arrives or
2317 ;;; services-timeout expires.
2318 ;;;
2319 ;;; Returned alist's keys are bare ("status", "code", "token",
2320 ;;; "bot-nick", etc.) — the "+enclave/result." prefix is stripped.
2321 ;;; A "body" entry holds the text of the reply (best-effort: first
2322 ;;; line for multi-line responses); "body-lines" collects all body
2323 ;;; lines that arrived within the line-grace window.
2324 ;;;
2325 ;;; If the timeout expires with no reply, returns
2326 ;;; `((status . "err") (code . "timeout") (detail . <command>))`.
2327 (define (enclave-services-call conn cmd)
2328 (: enclave-conn? string? -> list?)
2329 (let ((irc (enclave-conn-irc conn)))
2330 (unless (irc-connected? irc)
2331 (error "enclave-services-call: not connected"))
2332 ;; Acquire mutex — serialise services calls per-connection.
2333 (let wait ()
2334 (when (enclave-conn-services-busy? conn)
2335 (sleep 0.02)
2336 (wait)))
2337 (set-enclave-conn-services-busy?! conn #t)
2338 (set-enclave-conn-services-pending! conn '())
2339 (log-debug "EnclaveServ call" cmd: cmd)
2340 ;; Send the request.
2341 (irc-privmsg irc "EnclaveServ" cmd)
2342 ;; Wait for reply / aggregate multi-line body lines.
2343 (let* ((timeout (enclave-config-services-timeout
2344 (enclave-conn-config conn)))
2345 (deadline (+ (current-second) timeout))
2346 (line-grace 0.25)) ;; multi-line: wait this long after first
2347 (let collect ((first-arrival #f) (replies '()))
2348 (let ((pending (enclave-conn-services-pending conn))
2349 (now (current-second)))
2350 (cond
2351 ;; New replies arrived since last check — accumulate.
2352 ((not (null? pending))
2353 (set-enclave-conn-services-pending! conn '())
2354 (collect (or first-arrival now)
2355 (append (reverse pending) replies)))
2356 ;; First reply landed and grace window expired.
2357 ((and first-arrival (> now (+ first-arrival line-grace)))
2358 (set-enclave-conn-services-busy?! conn #f)
2359 (build-result-alist (reverse replies)))
2360 ;; Hard timeout.
2361 ((and (not first-arrival) (> now deadline))
2362 (set-enclave-conn-services-busy?! conn #f)
2363 (log-warn "EnclaveServ call timeout" cmd: cmd)
2364 (list (cons "status" "err")
2365 (cons "code" "timeout")
2366 (cons "detail" cmd)))
2367 (else
2368 (sleep 0.02)
2369 (collect first-arrival replies))))))))
2371 ;;; Register a worker bot via EnclaveServ. Returns an alist with at
2372 ;;; minimum a "status" entry; on success ("ok") includes "bot-nick",
2373 ;;; "token", "expires-at", "auto-join", "owner-name". On error
2374 ;;; ("err") includes "code" and usually "detail".
2375 ;;;
2376 ;;; Keys:
2377 ;;; auto-join: CSV channel list (default: leader's coord channel)
2378 ;;; expires-in: duration like "4h", "30m", "2d" (default: "12h")
2379 ;;; groups: CSV group list (default: nil — server-side default)
2380 ;;; reports-to: nick of the leader this bot reports up to
2381 (define (enclave-register-bot conn name (keys: (auto-join #f)
2382 (expires-in "12h")
2383 (groups #f)
2384 (reports-to #f)))
2385 (: enclave-conn? string?
2386 (auto-join: any?) (expires-in: any?)
2387 (groups: any?) (reports-to: any?) -> list?)
2388 (let* ((channels (or auto-join
2389 (enclave-config-channel
2390 (enclave-conn-config conn))))
2391 (cmd (string-append
2392 "bot register " name
2393 (if (and channels (> (string-length channels) 0))
2394 (string-append " auto-join: " channels)
2395 "")
2396 (if expires-in
2397 (string-append " expires-in: " expires-in)
2398 "")
2399 (if (and groups (> (string-length groups) 0))
2400 (string-append " groups: " groups)
2401 "")
2402 (if (and reports-to (> (string-length reports-to) 0))
2403 (string-append " reports-to: " reports-to)
2404 ""))))
2405 (let ((result (enclave-services-call conn cmd)))
2406 (when (string=? (or (result-status result) "") "ok")
2407 (log-info "Worker bot registered"
2408 bot-nick: (result-tag result "bot-nick")
2409 expires-at: (result-tag result "expires-at")
2410 token: (safe-token-prefix
2411 (result-tag result "token"))))
2412 result)))
2414 ;;; Revoke a bot via EnclaveServ. Returns the result alist.
2415 (define (enclave-revoke-bot conn name)
2416 (: enclave-conn? string? -> list?)
2417 (let ((result (enclave-services-call conn
2418 (string-append "bot revoke " name))))
2419 (when (string=? (or (result-status result) "") "ok")
2420 (log-info "Worker bot revoked" bot-nick: name))
2421 result))
2423 ;;; Rotate a bot's SASL token. Self-rotation is allowed for any bot;
2424 ;;; rotating someone else's bot requires admin.
2425 (define (enclave-rotate-token conn name)
2426 (: enclave-conn? string? -> list?)
2427 (let ((result (enclave-services-call conn
2428 (string-append "bot rotate-token " name))))
2429 (when (string=? (or (result-status result) "") "ok")
2430 (log-info "Bot token rotated"
2431 bot-nick: name
2432 token: (safe-token-prefix
2433 (result-tag result "token"))))
2434 result))
2436 ))