1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
(ns frq.irc
"A small IRC client for freeq servers, over plain TCP.
Two transports, behind one `read-chunk!`/`write!` pair. TLS is the default —
jolt.mvn-http carries OpenSSL bindings for its own HTTPS fetching, and they
are just as good for an IRC socket, so `:6697` works. Plain TCP is the raw
BSD calls: socket, connect, send, recv.
The raw calls rather than the java.net.Socket surface jolt.socket registers,
because that surface does not work on Android — nor does mvn-http's
getaddrinfo path, which is why TLS is desktop-only there. `socket()` and
`connect()` themselves are fine on both, so this is what the phone gets.
One future reads, the UI thread writes; nothing here knows about the UI.
`connect!` takes an `on-msg` fn and returns a connection map that
`send-line!` and `close!` accept."
(:require [clojure.string :as str]
[frq.atproto :as atproto]
[frq.msgsig :as msgsig]
[frq.wire :as wire]
[jolt.ffi :as ffi]
[jolt.host :as host]
[jolt.mvn-http :as tls]
[jolt.socket :as socket]))
(def ^:private af-inet 2)
(def ^:private sock-stream 1)
(def ^:private buffer-size 8192)
;; jolt's TLS sockets carry a 30-second receive timeout, so a quiet connection
;; reads nothing without being closed. These decide how long that is allowed to
;; go on: past `idle-ping-secs` we ask the server whether it is still there,
;; and past `idle-dead-secs` with no answer we conclude it is not.
(def ^:private idle-ping-secs 45)
(def ^:private idle-dead-secs 90)
;; How long a TLS read waits before giving the thread back. It is also how long
;; an outgoing line can sit in the outbox, so it wants to be short: the reader
;; owns the connection, and this is how often it looks at what there is to send.
(def ^:private tls-poll-ms 200)
(defn- secs-since [t] (quot (- (host/mono-nanos) t) 1000000000))
;; ---------------------------------------------------------------- parsing
(defn parse-line
"An IRC line into {:tags :prefix :command :params}. The trailing parameter
(after \" :\") keeps its spaces; everything before it splits on whitespace.
IRCv3 tags come first when there are any. A connection that negotiates CAP
gets them where a bare one does not — which is why a client that ignores them
looks fine as a guest and goes silent once it authenticates."
[line]
(let [line (str/trimr line)
[tags line] (if (str/starts-with? line "@")
(let [i (str/index-of line " ")]
[(subs line 1 i) (str/triml (subs line i))])
[nil line])
[prefix rest-line] (if (str/starts-with? line ":")
(let [i (str/index-of line " ")]
[(subs line 1 i) (subs line (inc i))])
[nil line])
i (str/index-of rest-line " :")
head (if i (subs rest-line 0 i) rest-line)
trailing (when i (subs rest-line (+ i 2)))
parts (remove str/blank? (str/split head #" "))]
{:tags tags
:account (when tags
(second (re-find #"(?:^|;)account=([^;]*)" tags)))
:prefix prefix
:command (str/upper-case (or (first parts) ""))
:params (cond-> (vec (rest parts)) trailing (conj trailing))}))
(defn unescape-tag
"An IRCv3 tag value with its escapes undone.
`\\:` is a semicolon, `\\s` a space, and `\\\\`, `\\r` and `\\n` themselves —
the escaping exists because `;` separates tags and a space ends them. It
matters for any value that can contain either: a reaction tally is
`emoji:nick;emoji:nick` on the wire and arrives with every one of those
semicolons written `\\:`, so a reader that skips this step sees one tally
where there were three, and counts to match."
[v]
(when v
(loop [in (seq v) out []]
(if-let [c (first in)]
(if (and (= \\ c) (second in))
(recur (drop 2 in)
(conj out (case (second in)
\: \;
\s \space
\r \return
\n \newline
(second in))))
(recur (rest in) (conj out c)))
(apply str out)))))
(defn escape-tag-value
"The inverse, for a tag this client sends. An emoji needs none of it; a
message id could, and the cost of being right is a pass over a short string."
[v]
(-> (str v)
(str/replace "\\" "\\\\")
(str/replace ";" "\\:")
(str/replace " " "\\s")
(str/replace "\r" "\\r")
(str/replace "\n" "\\n")))
(defn tag-value
"One IRCv3 tag's value, unescaped, or nil."
[tags key]
(when tags
(some (fn [pair]
(let [[k v] (str/split pair #"=" 2)]
(when (= k key) (unescape-tag v))))
(str/split tags #";"))))
(defn nick-of
"The nick half of a `nick!user@host` prefix."
[prefix]
(when prefix
(let [i (str/index-of prefix "!")]
(if i (subs prefix 0 i) prefix))))
;; ---------------------------------------------------------------- transport
(defn- write!
"Bytes out, whichever transport this is. TLS callers go through the outbox
instead — see `send-line!`."
[conn text]
(if (= :tls (:kind conn))
(tls/tls-write (:tls conn) (.getBytes text))
(wire/send-all! (:fd conn) text)))
(defn- read-chunk!
"Block for the next chunk as a string, or nil at end of stream."
[conn]
(if (= :tls (:kind conn))
(let [b (try (tls/tls-read (:tls conn)) (catch Exception _ nil))]
(when (and b (pos? (count b))) (String. b)))
(let [buf (:buf conn)
n (try (socket/c-recv (:fd conn) buf buffer-size 0) (catch Exception _ -1))]
(when (and n (pos? n)) (String. (ffi/read-bytes buf n))))))
(defn send-line!
"Send a raw IRC line. Safe from any thread.
On TLS the line is queued rather than written: OpenSSL is driven here through
a pair of memory BIOs, and a write issued while the reader thread is parked
inside SSL_read is simply lost — the call reports success and the server
never sees the line. So the reader thread owns the connection in both
directions and drains this queue between reads. A raw socket has no such
problem, and writes straight through."
[conn line]
(let [text (str line "\r\n")]
(if (= :tls (:kind conn))
(locking (:lock conn) (swap! (:outbox conn) conj text))
(locking (:lock conn) (write! conn text)))))
(declare flush-outbox-tls!)
(defn- flush-outbox!
"Write whatever has been queued. Only ever called on the reader thread.
Only a TLS connection has a queue: a raw socket is written straight from
whichever thread is sending, so there is nothing here to drain."
[conn]
(when (:outbox conn)
(flush-outbox-tls! conn)))
(defn- flush-outbox-tls! [conn]
(let [pending (locking (:lock conn)
(let [q @(:outbox conn)]
(reset! (:outbox conn) [])
q))]
(doseq [text pending]
(when (System/getenv "FRQ_TRACE")
(binding [*out* *err*] (println "frq/irc: >>" (str/trimr text))))
(try (write! conn text)
(catch Exception e
(binding [*out* *err*] (println "frq/irc: write failed:" (or (ex-message e) (str e))))
;; Put it back: a write that failed for a transient reason is
;; worth another turn of the loop.
(locking (:lock conn) (swap! (:outbox conn) conj text)))))))
(defn- reader-loop!
"Read until the connection ends, splitting on CRLF and dispatching each
complete line. PING is answered here so a busy UI never times the link out;
everything else goes to `on-msg`.
Nothing to read is not the end of the connection. On TLS it usually means the
30-second receive timeout elapsed on a quiet channel — reading that as EOF is
what used to leave the app connected in appearance only: sends went nowhere
while the buffer still filled in with what the user typed. So a quiet stretch
gets a PING, and only silence after that counts as gone."
[conn on-msg]
(loop [acc "" last-data (host/mono-nanos) pinged? false]
(flush-outbox! conn)
(let [chunk (read-chunk! conn)]
(cond
;; A plain socket has no timeout, so nothing to read really is the end.
(and (nil? chunk) (not= :tls (:kind conn)))
(on-msg {:command "*DISCONNECTED*" :params []})
(nil? chunk)
(let [idle (secs-since last-data)]
(cond
(and pinged? (> idle idle-dead-secs))
(on-msg {:command "*DISCONNECTED*" :params []})
(and (not pinged?) (> idle idle-ping-secs))
(do (try (send-line! conn "PING :frq") (catch Exception _ nil))
(recur acc last-data true))
:else (recur acc last-data pinged?)))
:else
(let [acc (str acc chunk)
lines (str/split acc #"\r?\n" -1)
complete (butlast lines)]
(doseq [line complete :when (seq (str/trim line))]
(when (System/getenv "FRQ_TRACE")
(binding [*out* *err*] (println "frq/irc: <<" (subs line 0 (min 100 (count line))))))
(let [msg (parse-line line)]
(when (= "PING" (:command msg))
(send-line! conn (str "PONG :" (first (:params msg)))))
(on-msg (assoc msg :raw line))))
(recur (last lines) (host/mono-nanos) false))))))
(defn- open
"Dial `host`:`port`, over TLS unless `tls?` is false."
[host port tls? nick]
(if tls?
(do (tls/ensure-native!)
(let [t (tls/tls-connect host (int port))]
;; Without a short timeout the reader parks for 30 seconds at a time,
;; which is 30 seconds of nothing being sent.
(try (#'tls/set-timeouts! (:sock t) tls-poll-ms) (catch Exception _ nil))
{:kind :tls :tls t :outbox (atom [])
:lock (Object.) :nick nick :caps (atom #{})}))
(let [ip (#'socket/ip->str (socket/resolve-host host))
fd (socket/c-socket af-inet sock-stream 0)]
(when (neg? fd) (throw (ex-info "socket() failed" {:host host})))
(let [rc (socket/c-connect fd (#'socket/make-sockaddr-in ip (int port)) 16)]
(when (neg? rc)
(socket/c-close fd)
(throw (ex-info "connect() failed" {:host host :ip ip :port port}))))
{:kind :plain :fd fd :buf (ffi/alloc buffer-size)
:lock (Object.) :nick nick :caps (atom #{})})))
(def ^:private sasl-chunk 400)
(defn- authenticate!
"AUTHENTICATE takes at most 400 characters a line; a payload that lands on
the boundary is followed by a bare `+` so the server knows it ended."
[conn payload]
(loop [rest payload]
(if (> (count rest) sasl-chunk)
(do (send-line! conn (str "AUTHENTICATE " (subs rest 0 sasl-chunk)))
(recur (subs rest sasl-chunk)))
(do (send-line! conn (str "AUTHENTICATE " rest))
(when (= sasl-chunk (count rest))
(send-line! conn "AUTHENTICATE +"))))))
(def ^:private wanted-caps
"What this client can use, and why a guest connection negotiates at all.
`server-time`: without it a replayed backlog arrives untimed and every old
line reads as having just been said. `account-tag`: it puts the sender's DID
on the message, which is the only identity a client is given — a nick is
whatever someone chose today, and the hostmask carries eight characters of a
DID, too few to resolve. Both need `message-tags` beside them, since IRCv3
sends tags only to clients that asked for tags at all; either one alone is
ACKed and then nothing arrives.
`echo-message`: the server sends our own lines back to us, which is the only
way this client learns the msgid of something it said. Without it our own
messages sit in the buffer with no id, and a reaction or a reply aimed at one
has nothing to name — the pill appears here and nobody else ever sees it.
`freeq.at/msgsig`: what lets a signed-in account react at all. freeq answers
an unsigned mutation from an account with
`FAIL TAGMSG SIGNATURE_REQUIRED`, and this cap is how a client says it can
register a key and sign one."
["message-tags" "server-time" "account-tag" "echo-message" "freeq.at/msgsig"])
(defn cap-acked?
"Whether the server agreed to `cap` on this connection."
[conn cap]
(boolean (when-let [caps (:caps conn)] (contains? @caps cap))))
(defn- cap-step!
"Drive capability negotiation, and the SASL exchange inside it when there is
a session to authenticate with. Returns the message unchanged, so the caller
can go on handling it."
[conn session msg]
(let [{:keys [command params]} msg]
(case command
"CAP" (let [[_ sub caps] params
offered (set (str/split (or caps "") #"\s+"))
wanted (cond-> (filterv offered wanted-caps)
(and session (offered "sasl")) (conj "sasl"))]
(case sub
"LS" (if (seq wanted)
(send-line! conn (str "CAP REQ :" (str/join " " wanted)))
(send-line! conn "CAP END"))
;; SASL, when acked, ends negotiation itself — CAP END waits
;; for the exchange to finish either way.
"ACK" (do
(when-let [acked (:caps conn)]
(swap! acked into (remove str/blank?
(str/split (or caps "") #"\s+"))))
(if (str/includes? (or caps "") "sasl")
(send-line! conn "AUTHENTICATE ATPROTO-CHALLENGE")
(send-line! conn "CAP END")))
"NAK" (send-line! conn "CAP END")
nil))
;; The challenge arrives as base64url JSON; the nonce inside it is what
;; binds our PDS token to this connection.
"AUTHENTICATE" (let [challenge (first params)]
(when (and challenge (not= "+" challenge))
(let [nonce (atproto/json-str
(atproto/b64-decode challenge) "nonce")]
(authenticate! conn (atproto/sasl-response session nonce)))))
;; 903 logged in, 904/905/906 did not. A login is also the moment this
;; connection can have a signing key: the DID it signs as is only settled
;; here. The key is registered at 001 rather than now — MSGSIG is a
;; registered-client command, and negotiation has not ended yet.
"903" (do (when (and (cap-acked? conn "freeq.at/msgsig") (:did session))
(msgsig/generate! (:did session)))
(send-line! conn "CAP END"))
("904" "905" "906") (send-line! conn "CAP END")
;; Welcomed. Hand the server the public half, and every reaction from
;; here on carries a signature it will take.
"001" (when-let [pub (msgsig/public-key)]
(send-line! conn (str "MSGSIG " pub)))
nil))
msg)
(defn connect!
"Open a connection, register `nick`, and start the reader.
With a `session` from `frq.atproto/create-session` the registration runs the
SASL exchange first and the connection is bound to that DID; without one it
is an ordinary guest. `tls?` defaults to true — freeq's TLS listener is
:6697, plain is :6667."
([host port nick on-msg] (connect! host port nick on-msg true nil))
([host port nick on-msg tls?] (connect! host port nick on-msg tls? nil))
([host port nick on-msg tls? session]
(let [conn (open host port tls? nick)
on-msg (fn [msg] (on-msg (cap-step! conn session msg)))]
(future
(try (reader-loop! conn on-msg)
(catch Exception e
(on-msg {:command "*ERROR*" :params [(str e)]}))))
;; CAP first: registration waits for CAP END, which negotiation sends once
;; it has an answer — after the SASL exchange, when there is one.
(send-line! conn "CAP LS 302")
(send-line! conn (str "NICK " nick))
(send-line! conn (str "USER " nick " 0 * :" nick))
conn)))
(defn join! [conn channel] (send-line! conn (str "JOIN " channel)))
(defn part! [conn channel] (send-line! conn (str "PART " channel)))
(defn privmsg!
"Say something. With `reply-to`, say it as an answer to that message: the
`+draft/reply` tag is what every other freeq client reads to thread it, and
what this one draws its chips from."
([conn target text] (privmsg! conn target text nil))
([conn target text reply-to]
(send-line! conn (str (when (seq reply-to) (str "@+draft/reply=" reply-to " "))
"PRIVMSG " target " :" text))))
(defn edit!
"Rewrite something already said. The `+draft/edit` tag names the message
being replaced, and what follows is its new text — the server checks that
the message was ours, files the revision under the original's id, and sends
the new line on to the channel for every client to fold in.
A PRIVMSG rather than a TAGMSG, because an edit carries a body — and signed,
like every other thing that changes a record already written: from an account
the server answers an unsigned one with
`FAIL EDIT SIGNATURE_REQUIRED` and the message stays as it was. `peer-did` is
who a DM is with, which is half of the name a DM signature is made under."
([conn target msgid text] (edit! conn target msgid text nil))
([conn target msgid text peer-did]
(let [tags (assoc (msgsig/edit-tags target msgid text nil peer-did)
"+draft/edit" msgid)
pairs (for [[k v] tags] (str k "=" (escape-tag-value v)))]
(send-line! conn (str "@" (str/join ";" pairs)
" PRIVMSG " target " :" text)))))
(defn tagmsg!
"A message that is only tags: how freeq carries a reaction, a typing hint or
a delete. `tags` is a map of name to value, sent in no particular order — the
server reads them by name."
[conn target tags]
(let [pairs (for [[k v] tags] (str k "=" (escape-tag-value v)))]
(send-line! conn (str "@" (str/join ";" pairs) " TAGMSG " target))))
(defn react!
"Put `emoji` on the message `msgid`, for everyone in `target` to see.
Signed when this connection has a key. `peer-did` is who the DM is with, and
is what a DM signature names the conversation by; a channel does not need it."
([conn target msgid emoji] (react! conn target msgid emoji nil))
([conn target msgid emoji peer-did]
(tagmsg! conn target (merge {"+react" emoji "+reply" msgid}
(msgsig/mutation-tags "react" target msgid
emoji peer-did)))))
(defn unreact!
"Take it off again. The server keys the removal by DID where there is one, so
it survives a nick change and cannot be done on someone else's behalf.
Signed like the reaction it undoes — taking a pill off is as much a change to
a message as putting one on, and the server asks for the same proof."
([conn target msgid emoji] (unreact! conn target msgid emoji nil))
([conn target msgid emoji peer-did]
(tagmsg! conn target (merge {"+freeq.at/unreact" emoji "+reply" msgid}
(msgsig/mutation-tags "unreact" target msgid
emoji peer-did)))))
(defn close! [conn]
;; Written straight out rather than queued: the reader may already be gone,
;; and there is nothing left to lose if this one is.
(try (locking (:lock conn) (write! conn "QUIT :frq\r\n")) (catch Exception _ nil))
(try (if (= :tls (:kind conn))
(tls/tls-close (:tls conn))
(do (socket/c-close (:fd conn))
(ffi/free (:buf conn))))
(catch Exception _ nil)))
|