diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/papod.clj | 598 |
1 files changed, 528 insertions, 70 deletions
diff --git a/src/papod.clj b/src/papod.clj index 5142542..4be8edd 100644 --- a/src/papod.clj +++ b/src/papod.clj @@ -1069,6 +1069,8 @@ (declare join-one!) (declare notify-monitors!) +(declare ban-matches?) +(declare mute-matches?) (defn- persistent-channels "Channel handles where `nick` has stored membership." @@ -1192,12 +1194,15 @@ " nt" ;; channel modes )) (numeric-reply client "005" - (str "AWAYLEN=200 CASEMAPPING=ascii" + (str "ACCOUNTEXTBAN=a" + " AWAYLEN=200 CASEMAPPING=ascii" " CHANLIMIT=#:100" - " CHANMODES=b,k,l,nt" + " CHANMODES=beI,k,l,Cnt" " CHANNELLEN=64 CHANTYPES=#" - " ELIST= HOSTLEN=64" - " KICKLEN=300 MAXLIST=b:50" + " ELIST= EXCEPTS=e" + " EXTBAN=~,am HOSTLEN=64" + " INVEX=I KICKLEN=300" + " MAXLIST=b:50,e:50,I:50" " MAXTARGETS=4" " :are supported by this server")) (numeric-reply client "005" @@ -1429,6 +1434,9 @@ " draft/event-playback" " draft/relaymsg " reg-cap + " draft/channel-rename" + " draft/extended-isupport" + " draft/metadata-2" " draft/typing") (str "sasl message-tags server-time" " echo-message batch" @@ -1445,6 +1453,9 @@ " draft/event-playback" " draft/relaymsg " reg-cap + " draft/channel-rename" + " draft/extended-isupport" + " draft/metadata-2" " draft/typing")))]) "REQ" @@ -1465,6 +1476,9 @@ "draft/event-playback" "draft/relaymsg" "draft/account-registration" + "draft/channel-rename" + "draft/extended-isupport" + "draft/metadata-2" "draft/typing"}] (if-not (every? supported requested) [(str ":" +server-name+ " CAP " nick @@ -2248,6 +2262,15 @@ msg-id (java.util.UUID/randomUUID) msg-at (java.util.Date.) chan? (and channels (channel-handle? target)) + body (cond-> content + (string/starts-with? content ":") (subs 1)) + ctcp? (and (seq body) + (= \u0001 (first body))) + action? (and ctcp? + (string/starts-with? body "ACTION")) + chmodes (or (when (:chan-modes components) + (get @(:chan-modes components) target)) + "+nt") ;; IRCv3 +reply tag for threads reply-id (when-let [r (get tags "+reply")] (try (java.util.UUID/fromString r) @@ -2264,11 +2287,7 @@ ;; +n: no external messages (and chan? - (string/includes? - (or (get @(:chan-modes components) - target) - "+nt") - "n") + (string/includes? chmodes "n") (not (contains? (get @channels target) nick))) [(numeric-reply client "404" @@ -2277,11 +2296,7 @@ ;; +m: moderated — only ops/voiced may speak (and chan? - (string/includes? - (or (get @(:chan-modes components) - target) - "+nt") - "m") + (string/includes? chmodes "m") (not (and (:ops components) (contains? (get @(:ops components) target) @@ -2294,6 +2309,40 @@ (str target " :Cannot send to channel"))] + ;; +C: no CTCP (except ACTION) + (and chan? ctcp? (not action?) + (string/includes? chmodes "C")) + [(numeric-reply client "404" + (str target + " :Cannot send CTCP to channel (+C)"))] + + ;; ~m: mute extban — sender is muted by a +b mask + ;; (ops/voiced bypass). Excepted by matching +e. + (and chan? + (not (and (:ops components) + (contains? + (get @(:ops components) target) + nick))) + (not (and (:voiced components) + (contains? + (get @(:voiced components) target) + nick))) + (let [bans-atom (:chan-bans components) + excepts-atom (:chan-excepts components) + bans (when bans-atom + (get @bans-atom target #{})) + excepts (when excepts-atom + (get @excepts-atom target #{})) + acct (:account @client)] + (and (seq bans) + (mute-matches? bans nick) + (not (and (seq excepts) + (ban-matches? + excepts nick acct)))))) + [(numeric-reply client "404" + (str target + " :Cannot send to channel (+b)"))] + :else (do ;; PERSIST FIRST @@ -2493,15 +2542,39 @@ [nick] (str nick "!" nick "@localhost")) +(defn- nick-mask-match? + [mask nick] + (boolean + (re-matches (glob-pattern + (string/lower-case mask)) + (string/lower-case (nuh-mask nick))))) + (defn- ban-matches? - [bans nick] - (let [nuh (nuh-mask nick)] - (some (fn [mask] - (boolean - (re-matches (glob-pattern - (string/lower-case mask)) - (string/lower-case nuh)))) - bans))) + "Matches a +b/+e mask set against a join attempt. Recognises + ~a:account extbans (match by account) and ignores ~m:mute + extbans (those filter PRIVMSGs, not joins)." + ([masks nick] (ban-matches? masks nick nil)) + ([masks nick account] + (some (fn [mask] + (cond + (string/starts-with? mask "~a:") + (and account + (= (string/lower-case + (subs mask 3)) + (string/lower-case account))) + (string/starts-with? mask "~m:") + false + :else + (nick-mask-match? mask nick))) + masks))) + +(defn- mute-matches? + "Matches the ~m:<nick-mask> extban subset of a +b list." + [masks nick] + (some (fn [mask] + (and (string/starts-with? mask "~m:") + (nick-mask-match? (subs mask 3) nick))) + masks)) (defn- chan-symbol [components handle] @@ -2547,11 +2620,17 @@ [(numeric-reply client "403" (str handle " :No such channel"))] - ;; +i (invite-only): require invite + ;; +i (invite-only): require invite (bypassed by +I match) (and existing? (not (contains? (get @channels handle) nick)) (string/includes? modes "i") - (not invited?)) + (not invited?) + (let [invex-atom (:chan-invex components) + invex (when invex-atom + (get @invex-atom handle #{}))] + (not (and (seq invex) + (ban-matches? + invex nick (:account @client)))))) [(numeric-reply client "473" (str handle " :Cannot join channel (+i)"))] @@ -2571,14 +2650,22 @@ (str handle " :Cannot join channel (+l)"))] - ;; +b: banned (an active INVITE bypasses the ban) + ;; +b: banned (INVITE or matching +e exception bypasses) (and existing? (not (contains? (get @channels handle) nick)) (not invited?) (let [bans-atom (:chan-bans components) + excepts-atom (:chan-excepts components) bans (when bans-atom - (get @bans-atom handle #{}))] - (and (seq bans) (ban-matches? bans nick)))) + (get @bans-atom handle #{})) + excepts (when excepts-atom + (get @excepts-atom handle #{})) + acct (:account @client)] + (and (seq bans) + (ban-matches? bans nick acct) + (not (and (seq excepts) + (ban-matches? + excepts nick acct)))))) [(numeric-reply client "474" (str handle " :Cannot join channel (+b)"))] @@ -2795,6 +2882,86 @@ (join-one! h (get keys i) client components)) (range) handles))))) +(defn- handle-rename + [params client components] + (let [{:keys [conn clients channels]} components + nick (client-target client) + old (some-> (first params) string/lower-case) + new (some-> (second params) string/lower-case) + reason (when (> (count params) 2) + (let [r (nth params 2)] + (cond-> r + (string/starts-with? r ":") (subs 1))))] + (cond + (or (< (count params) 2) + (string/blank? old) (string/blank? new)) + [(str "FAIL RENAME NEED_MORE_PARAMS" + " :Not enough parameters")] + + (not (channel-handle? old)) + [(numeric-reply client "403" + (str old " :No such channel"))] + + (not (channel-handle? new)) + [(str "FAIL RENAME INVALID_CHAN_NAME " + new " :Invalid channel name")] + + (not (and channels (seq (get @channels old)))) + [(numeric-reply client "403" + (str old " :No such channel"))] + + (and channels (seq (get @channels new))) + [(str "FAIL RENAME CHANNEL_NAME_IN_USE " + new " :Channel name already in use")] + + (not (and (:ops components) + (contains? (get @(:ops components) old) + nick))) + [(numeric-reply client "482" + (str old + " :You're not channel operator"))] + + :else + (let [src (client-prefix client) + members (get @channels old) + rline (str ":" src " RENAME " old " " new + (when reason (str " :" reason))) + part-l (str ":" src " PART " old + (when reason (str " :" reason))) + join-l (fn [member-nick] + (str ":" member-nick " JOIN " new))] + ;; Move channel state across atoms + (doseq [a-key [:channels :ops :voiced + :chan-modes :chan-keys :chan-limits + :chan-bans :chan-excepts :chan-invex + :invites]] + (when-let [a (get components a-key)] + (swap! a (fn [m] + (let [v (get m old)] + (cond-> (dissoc m old) + v (assoc new v))))))) + ;; Persist the rename + (when conn + (try + (let [db (d/db conn) + eid (resolve-channel db old)] + (when eid + @(d/transact conn + [[:db/add eid :papod.channel/name new]]))) + (catch Exception _))) + ;; Deliver to members based on cap support + (when (and clients channels) + (doseq [mn members + :let [m (get @clients mn) + ca (:client-atom m) + caps (or (when ca (:caps @ca)) #{})] + :when m] + (if (caps "draft/channel-rename") + (deliver-to-client! (:w m) rline) + (do (deliver-to-client! (:w m) part-l) + (deliver-to-client! (:w m) (join-l mn)))))) + [])))) + (defn- handle-part [params client components] (let [{:keys [clients channels]} components @@ -3514,6 +3681,233 @@ [tagged] []))))))) +(defn- notify-metadata-subs! + "Deliver a `:source METADATA target key * [:value]` line to every + subscriber that shares a channel with the target." + [components client target-display key value] + (let [{:keys [clients channels metadata-subs]} components + nick (client-target client) + target (string/lower-case target-display) + chan? (channel-handle? target-display) + ;; nicks who could receive: members of relevant channels + relevant-chans + (when channels + (if chan? + (when (contains? @channels target) + [target]) + (filter (fn [[ch members]] + (contains? members target)) + @channels))) + candidate-nicks + (set + (mapcat + (fn [ch] + (let [members (if (string? ch) + (get @channels ch) + (val ch))] + members)) + (or relevant-chans []))) + line (if value + (str ":" nick " METADATA " + target-display " " key " * :" value) + (str ":" nick " METADATA " + target-display " " key " *"))] + (when (and clients metadata-subs) + (doseq [mn candidate-nicks + :when (not= mn nick) + :let [m (get @clients mn) + subs (get @metadata-subs + (string/lower-case mn) #{})] + :when (and m (contains? subs key))] + (deliver-to-client! (:w m) line))))) + +(defn- metadata-target-key + "Validate a METADATA target and return its canonical lower-case key + (or nil for invalid). `*` always resolves to the caller's nick." + [components client target] + (let [nick (client-target client) + lo (when target (string/lower-case target))] + (cond + (or (nil? target) (= "*" target)) + (string/lower-case nick) + + (channel-handle? target) + (when (and (:channels components) + (seq (get @(:channels components) lo))) + lo) + + :else + (when-let [clients (:clients components)] + (let [matches (filter (fn [[k _]] + (= (string/lower-case k) lo)) + @clients)] + (when (seq matches) + lo)))))) + +(defn- metadata-target-display + "Echo the user-supplied target back, resolving `*` to the caller's + own nick (some clients require the canonical name)." + [client requested] + (if (or (nil? requested) (= "*" requested)) + (client-target client) + requested)) + +(defn- handle-metadata + [params client components] + (let [nick (client-target client) + target (first params) + subcmd (when (> (count params) 1) + (string/upper-case (second params))) + rest-args (drop 2 params) + meta-atom (:metadata components) + subs-atom (:metadata-subs components) + tkey (metadata-target-key components client target) + echo-target (metadata-target-display client target) + batch-id (str (java.util.UUID/randomUUID)) + wrap-batch + (fn [body-lines] + (into [(str "BATCH +" batch-id " metadata" + (when echo-target + (str " " echo-target)))] + (concat + (map (fn [l] + (if (string/starts-with? l "@") + (let [sp (.indexOf l " ")] + (str "@batch=" batch-id ";" + (subs l 1 sp) + (subs l sp))) + (str "@batch=" batch-id " " l))) + body-lines) + [(str "BATCH -" batch-id)])))] + (cond + (or (nil? target) (string/blank? target)) + [(numeric-reply client "461" + "METADATA :Not enough parameters")] + + (nil? subcmd) + [(numeric-reply client "461" + "METADATA :Not enough parameters")] + + (and (not= subcmd "SUB") + (not= subcmd "UNSUB") + (not= subcmd "SUBS") + (nil? tkey)) + [(str "FAIL METADATA INVALID_TARGET " + target " :Invalid target")] + + :else + (case subcmd + "GET" + (let [keys-asked (vec rest-args) + cur (get @meta-atom tkey {}) + body + (mapv + (fn [k] + (if-let [v (get cur k)] + (numeric-reply client "761" + (str echo-target " " k " * :" v)) + (numeric-reply client "766" + (str echo-target " " k + " :no matching key")))) + keys-asked)] + (wrap-batch body)) + + "LIST" + (let [cur (get @meta-atom tkey {}) + body + (mapv + (fn [[k v]] + (numeric-reply client "761" + (str echo-target " " k " * :" v))) + (sort-by first cur))] + (wrap-batch body)) + + "SET" + (let [k (first rest-args) + v-parts (rest rest-args) + raw-v (when (seq v-parts) + (string/join " " v-parts)) + v (when raw-v + (cond-> raw-v + (string/starts-with? raw-v ":") (subs 1))) + v-bytes (when v + (alength (.getBytes ^String v "UTF-8")))] + (cond + (nil? k) + [(numeric-reply client "461" + "METADATA :Not enough parameters")] + + ;; Only allow setting on self (or chanop on channel) + (not (or (= tkey (string/lower-case nick)) + (and (channel-handle? target) + (:ops components) + (contains? + (get @(:ops components) tkey) + nick)))) + [(str "FAIL METADATA KEY_NO_PERMISSION " + echo-target " " k + " :You don't have permission to set this key")] + + (and v-bytes (> v-bytes 360)) + [(str "FAIL METADATA VALUE_INVALID :Value of " + k " is too long")] + + (or (nil? v) (string/blank? v)) + (do (when meta-atom + (swap! meta-atom update tkey dissoc k)) + (notify-metadata-subs! components client + echo-target k nil) + [(numeric-reply client "766" + (str echo-target " " k + " :no matching key"))]) + + :else + (do (when meta-atom + (swap! meta-atom assoc-in [tkey k] v)) + (notify-metadata-subs! components client + echo-target k v) + [(numeric-reply client "761" + (str echo-target " " k " * :" v))]))) + + "CLEAR" + (do (when meta-atom (swap! meta-atom dissoc tkey)) + [(numeric-reply client "762" + (str echo-target + " :end of metadata"))]) + + "SUB" + (let [keys-asked (vec rest-args) + k-low (string/lower-case nick)] + (when subs-atom + (swap! subs-atom update k-low + (fnil into #{}) keys-asked)) + (when (seq keys-asked) + [(numeric-reply client "770" + (string/join " " keys-asked))])) + + "UNSUB" + (let [keys-asked (vec rest-args) + k-low (string/lower-case nick)] + (when subs-atom + (swap! subs-atom update k-low + (fnil (fn [s ks] + (apply disj s ks)) #{}) keys-asked)) + (when (seq keys-asked) + [(numeric-reply client "771" + (string/join " " keys-asked))])) + + "SUBS" + (let [k-low (string/lower-case nick) + cur (when subs-atom + (get @subs-atom k-low #{}))] + [(numeric-reply client "772" + (if (seq cur) + (string/join " " cur) + ":none"))]) + + [(str "FAIL METADATA INVALID_SUBCOMMAND " + subcmd " :Unknown subcommand")])))) + (defn- handle-markread [params client components] (let [{:keys [conn]} components @@ -4641,6 +5035,21 @@ (conj (numeric-reply client "330" (str found-nick " " (:account st) " :is logged in as"))) + (seq (when-let [meta-atom (:metadata components)] + (get @meta-atom + (string/lower-case found-nick)))) + ((fn [r] + (let [meta-atom (:metadata components) + kv (when meta-atom + (get @meta-atom + (string/lower-case + found-nick) {}))] + (into r + (map (fn [[k v]] + (numeric-reply client "760" + (str found-nick " " + k " * :" v))) + (sort-by first kv)))))) true (conj (numeric-reply client "317" (str found-nick " 0 " @@ -4881,11 +5290,11 @@ (:w m) line))) []))) - ;; Simple flag modes (n/t/m/i/s/p/c) + ;; Simple flag modes (n/t/m/i/s/p/c/C) ;; Iterate every char in the mode-str so ;; "MODE #c +sp" applies both flags. (every? (fn [c] - (#{\n \t \m \i \s \p \c \+ \-} + (#{\n \t \m \i \s \p \c \C \+ \-} c)) mode-str) (let [chars (rest mode-str) @@ -4961,41 +5370,52 @@ (:w m) line))) []))) - ;; +b/-b with mask: add/remove ban - (and (= \b mode-char) mode-arg) - (let [bans-atom (:chan-bans components) - mask mode-arg - mask-key (string/lower-case mask) - line (str ":" nick " MODE " target - " " mode-str " " mask)] - (when bans-atom - (if adding? - (swap! bans-atom update target - (fnil conj #{}) mask-key) - (swap! bans-atom update target - (fnil disj #{}) mask-key))) - (when (and clients channels) - (doseq [mn (get @channels target) - :let [m (get @clients mn)] - :when m] - (deliver-to-client! (:w m) line))) - []) + ;; +b/+e/+I: list-mask modes + ;; (b=ban, e=ban-exception, I=invite-exception) + (#{\b \e \I} mode-char) + (let [[atom-key list-num end-num end-msg] + (case mode-char + \b [:chan-bans "367" "368" + ":End of channel ban list"] + \e [:chan-excepts "348" "349" + ":End of channel exception list"] + \I [:chan-invex "346" "347" + ":End of channel invite list"]) + list-atom (get components atom-key)] + (cond + mode-arg + (let [mask mode-arg + mask-key (string/lower-case mask) + line (str ":" nick " MODE " target + " " mode-str + " " mask)] + (when list-atom + (if adding? + (swap! list-atom update target + (fnil conj #{}) mask-key) + (swap! list-atom update target + (fnil disj #{}) mask-key))) + (when (and clients channels) + (doseq [mn (get @channels target) + :let [m (get @clients mn)] + :when m] + (deliver-to-client! (:w m) line))) + []) - ;; +b: ban list query - (and (= \b mode-char) (nil? mode-arg)) - (let [bans-atom (:chan-bans components) - cur-bans (when bans-atom - (get @bans-atom target #{}))] - (concat - (mapv (fn [mask] - (numeric-reply client "367" - (str target " " mask " " nick - " " (quot - (System/currentTimeMillis) - 1000)))) - (sort cur-bans)) - [(numeric-reply client "368" - (str target " :End of channel ban list"))])) + :else + (let [cur (when list-atom + (get @list-atom target #{}))] + (concat + (mapv + (fn [mask] + (numeric-reply client list-num + (str target " " mask " " nick + " " (quot + (System/currentTimeMillis) + 1000)))) + (sort cur)) + [(numeric-reply client end-num + (str target " " end-msg))])))) :else [])))) @@ -5495,6 +5915,7 @@ client components))) "RELAYMSG" (handle-relaymsg params client components) "JOIN" (handle-join params client components) + "RENAME" (handle-rename params client components) "PART" (handle-part params client components) "TOPIC" (handle-topic params client components) "KICK" (handle-kick params client components) @@ -5503,6 +5924,7 @@ "EDIT" (handle-edit params client components) "TAGMSG" (handle-tagmsg message client components) "MARKREAD" (handle-markread params client components) + "METADATA" (handle-metadata params client components) "LIST" (let [filter-ch (first params) self (client-target client) chans (when (:channels components) @@ -5722,16 +6144,48 @@ (cond (input-too-long? raw-message) (let [nick (or (:nick @client) "*") - line (str ":" +server-name+ " 417 " nick - " :Input line was too long")] - (deliver-to-client! w line)) + stripped (cond-> raw-message + (string/starts-with? raw-message "@") + (subs (inc (.indexOf raw-message " ")))) + stripped (cond-> stripped + (string/starts-with? stripped ":") + (subs (inc (.indexOf stripped " ")))) + first-word (let [s (.indexOf stripped " ")] + (if (pos? s) + (subs stripped 0 s) + stripped)) + ctx (string/upper-case + (subs first-word 0 + (min (count first-word) 32))) + ctx (if (re-matches #"[A-Z]+" ctx) ctx nil)] + (if ctx + (deliver-to-client! w + (str ":" +server-name+ " FAIL " ctx + " VALUE_INVALID :Input line was too long")) + (deliver-to-client! w + (str ":" +server-name+ " 417 " nick + " :Input line was too long")))) (has-invalid-utf8? raw-message) (let [label (extract-label raw-message) - line (str (when label (str "@label=" label " ")) - ":" +server-name+ - " FAIL * INVALID_UTF8 :Message rejected," - " contains invalid UTF-8")] + ;; Best-effort command extraction so the FAIL context + ;; matches the originating command (e.g. METADATA SET). + stripped (cond-> raw-message + (string/starts-with? raw-message "@") + (subs (inc (.indexOf raw-message " ")))) + stripped (cond-> stripped + (string/starts-with? stripped ":") + (subs (inc (.indexOf stripped " ")))) + first-word (let [s (.indexOf stripped " ")] + (if (pos? s) + (subs stripped 0 s) + stripped)) + ctx (string/upper-case first-word) + ctx (if (re-matches #"[A-Z]+" ctx) ctx "*") + line (str (when label (str "@label=" label " ")) + ":" +server-name+ + " FAIL " ctx " INVALID_UTF8 :Message" + " rejected, contains invalid UTF-8")] (deliver-to-client! w line)) :else @@ -5779,6 +6233,10 @@ :chan-keys (atom {}) :chan-limits (atom {}) :chan-bans (atom {}) + :chan-excepts (atom {}) + :chan-invex (atom {}) + :metadata (atom {}) + :metadata-subs (atom {}) :invites (atom {}) :whowas (atom []) :max-users (atom 0) |