From 194c8013b174a43d1358ba0b442deff3dd5c0c4d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 1 Aug 2017 00:22:51 -0400 Subject: [PATCH] Render source prefixes more fully to avoid a libpurple SIGSEGV (!); generally work around libpurple oddness --- examples/ircd/channel.rkt | 5 +-- examples/ircd/message.rkt | 34 ++++++++++++++++++-- examples/ircd/session.rkt | 66 +++++++++++++++++++++++++-------------- 3 files changed, 76 insertions(+), 29 deletions(-) diff --git a/examples/ircd/channel.rkt b/examples/ircd/channel.rkt index 2ccf393..6a226ff 100644 --- a/examples/ircd/channel.rkt +++ b/examples/ircd/channel.rkt @@ -13,11 +13,12 @@ (assert (ircd-channel-topic Ch (topic))) (on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _))) - (send! (ircd-event who (irc-message #f 368 (list (lookup-nick who) Ch) + (send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch) "End of Channel Ban List")))) (on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _))) - (send! (ircd-event who (irc-message #f 324 (list (lookup-nick who) Ch "+") #f)))) + (send! (ircd-event who (irc-message server-prefix 324 + (list (lookup-nick who) Ch "+") #f)))) (on (message (ircd-action _ (irc-message _ "TOPIC" _ $new-topic))) (topic new-topic)))) diff --git a/examples/ircd/message.rkt b/examples/ircd/message.rkt index 61509e0..50d1b46 100644 --- a/examples/ircd/message.rkt +++ b/examples/ircd/message.rkt @@ -3,8 +3,16 @@ (provide (struct-out irc-message) (struct-out irc-user) (struct-out irc-privmsg) + + (struct-out irc-source-servername) + (struct-out irc-source-nick) + parse-irc-message - render-irc-message) + render-irc-message + + ;; TODO make these assertions in the dataspace: + server-name + server-prefix) (require racket/string) (require racket/match) @@ -42,9 +50,12 @@ ;; (0xd), and LF (0xa)> (struct irc-message (prefix command params trailing) #:prefab) -(struct irc-user (username hostname servername realname) #:prefab) +(struct irc-user (username hostname realname) #:prefab) (struct irc-privmsg (source target text) #:prefab) +(struct irc-source-servername (servername) #:prefab) +(struct irc-source-nick (nick user) #:prefab) + (define (parse-irc-message line0) (match (string-trim #:left? #f line0 #px"[\r\n]") [(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)] @@ -57,9 +68,26 @@ (string-split (or params "")) rest)) +;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send +;; a prefix on a JOIN event from the server as just "nick" rather than +;; "nick!user@host" - specifically, it will crash if "!" doesn't +;; appear in the prefix. +;; (define (render-irc-message m) (match-define (irc-message prefix command params trailing) m) - (string-append (if prefix (string-append ":" prefix " ") "") + (string-append (render-prefix prefix) (~a command) (if (pair? params) (string-append " " (string-join (map ~a params))) "") (if trailing (string-append " :" trailing) ""))) + +(define (render-prefix p) + (match p + [#f + ""] + [(irc-source-servername servername) + (format ":~a " servername)] + [(irc-source-nick nick (irc-user username hostname _)) + (format ":~a!~a@~a " nick username hostname)])) + +(define server-name "syndicate-ircd") +(define server-prefix (irc-source-servername "syndicate-ircd.example")) diff --git a/examples/ircd/session.rkt b/examples/ircd/session.rkt index e98e46d..62104f1 100644 --- a/examples/ircd/session.rkt +++ b/examples/ircd/session.rkt @@ -20,7 +20,7 @@ (define (send-irc-message m) (send-to-remote "~a" (render-irc-message m))) - (define (send* #:prefix [prefix #f] #:trailing [trailing #f] command . params) + (define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params) (send-irc-message (irc-message prefix command params trailing))) (on-start (log-info "Connecting ~a" this-conn)) @@ -36,7 +36,6 @@ (begin/dataflow (unless (motd-sent?) (when (and (nick) (user)) - (define server-name "syndicate-ircd") (motd-sent? #t) (send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name)) (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line))) @@ -46,18 +45,30 @@ (field [initial-names-sent? #f] [initial-member-nicks (set)]) (during (ircd-channel-member Ch $other-conn) - (field [previous-nick #f]) - (define/query-value other-nick #f (ircd-connection-info other-conn $N _) N) - (on-stop (when (other-nick) (send* #:prefix (other-nick) "PART" Ch))) + (field [current-other-source #f]) + (define/query-value next-other-source #f + (ircd-connection-info other-conn $N $U) + (irc-source-nick N U)) + (on-stop (when (current-other-source) (send* #:source (current-other-source) "PART" Ch))) (begin/dataflow - (when (not (equal? (previous-nick) (other-nick))) + (when (and (next-other-source) + ;; ^ Becomes #f when other-conn disconnects, + ;; apparently by retraction of ircd-connection-info + ;; but before the retraction of ircd-channel-member + ;; is processed for some reason. TODO investigate + ;; this more closely. Should event-handlers that + ;; stop a facet prevent execution of contained + ;; event-handlers in the same turn? + (not (equal? (current-other-source) (next-other-source)))) (if (initial-names-sent?) - (if (previous-nick) - (when (not (equal? this-conn other-conn)) - (send* #:prefix (previous-nick) "NICK" (other-nick))) - (send* #:prefix (other-nick) "JOIN" Ch)) - (initial-member-nicks (set-add (initial-member-nicks) (other-nick)))) - (previous-nick (other-nick))))) + (if (current-other-source) + (when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection + (send* #:source (current-other-source) "NICK" + (irc-source-nick-nick (next-other-source)))) + (send* #:source (next-other-source) "JOIN" Ch)) + (initial-member-nicks (set-add (initial-member-nicks) + (irc-source-nick-nick (next-other-source))))) + (current-other-source (next-other-source))))) (on (asserted (ircd-channel-topic Ch $topic)) (if topic (send* 332 (nick) Ch #:trailing topic) @@ -67,18 +78,19 @@ (flush!) ;; Wait for responses to come in. GROSS and not in ;; general correct (e.g. in the presence of ;; pipelining) - (send! (ircd-event this-conn (irc-message #f 315 (list (nick) Ch) "End of WHO list.")))) + (send! (ircd-event this-conn + (irc-message server-prefix 315 (list (nick) Ch) "End of WHO list.")))) (on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _))) - (match-define (irc-user U H S R) (user)) - (send! (ircd-event who (irc-message #f 352 - (list (nick) Ch U H S (nick) "H") + (match-define (irc-user U H R) (user)) + (send! (ircd-event who (irc-message server-prefix 352 + (list (nick) Ch U H server-name (nick) "H") (format "0 ~a" R))))) (on (message (ircd-action $other-conn (irc-privmsg $source Ch $text))) (when (not (equal? other-conn this-conn)) - (send* #:prefix source "PRIVMSG" Ch #:trailing text))) + (send* #:source source "PRIVMSG" Ch #:trailing text))) - (on-start (send* #:prefix (nick) "JOIN" Ch) + (on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch) (flush!) (flush!) (define nicks (initial-member-nicks)) @@ -92,20 +104,25 @@ (on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text))) (when (not (equal? other-conn this-conn)) - (send* #:prefix source "PRIVMSG" (nick) #:trailing text))) + (send* #:source source "PRIVMSG" (nick) #:trailing text))) (on (message (tcp-channel-line this-conn server-handle $bs)) (define m (parse-irc-message (bytes->string/utf-8 bs))) (log-info "~a -> ~v" this-conn m) (send! (ircd-action this-conn m)) (match m - [(irc-message _ "PING" _ _) (send* "PONG")] - [(irc-message _ "NICK" (list N) _) + [(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs + [(or (irc-message _ "NICK" (list N) _) + (irc-message _ "NICK" '() N)) ;; libpurple does this (!) + ;; TODO: enforce syntactic restrictions on nick (if (immediate-query [query-value #f (ircd-connection-info _ N _) #t]) (send* 433 N #:trailing "Nickname is already in use") - (begin (when (nick) (send* #:prefix (nick) "NICK" N)) + (begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N)) (nick N)))] - [(irc-message _ "USER" (list U H S) R) (user (irc-user U H S R))] + [(irc-message _ "USER" (list U _Hostname _Servername) R) + ;; TODO: enforce syntactic restrictions on parameters to USER + (define H (tcp-address-host this-conn)) + (user (irc-user U H R))] [(irc-message _ "QUIT" _ _) (stop-current-facet)] [_ (when (and (nick) (user)) @@ -120,7 +137,8 @@ (send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO [(irc-message _ "PRIVMSG" (list Targets) Text) (for [(T (string-split Targets #px",+"))] - (send! (ircd-action this-conn (irc-privmsg (nick) T Text))))] + (send! (ircd-action this-conn + (irc-privmsg (irc-source-nick (nick) (user)) T Text))))] [_ (void)]))]))) (spawn #:name 'session-listener-factory