Render source prefixes more fully to avoid a libpurple SIGSEGV (!); generally work around libpurple oddness
This commit is contained in:
parent
5f621b098e
commit
194c8013b1
|
@ -13,11 +13,12 @@
|
||||||
(assert (ircd-channel-topic Ch (topic)))
|
(assert (ircd-channel-topic Ch (topic)))
|
||||||
|
|
||||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
|
(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"))))
|
"End of Channel Ban List"))))
|
||||||
|
|
||||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
|
(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)))
|
(on (message (ircd-action _ (irc-message _ "TOPIC" _ $new-topic)))
|
||||||
(topic new-topic))))
|
(topic new-topic))))
|
||||||
|
|
|
@ -3,8 +3,16 @@
|
||||||
(provide (struct-out irc-message)
|
(provide (struct-out irc-message)
|
||||||
(struct-out irc-user)
|
(struct-out irc-user)
|
||||||
(struct-out irc-privmsg)
|
(struct-out irc-privmsg)
|
||||||
|
|
||||||
|
(struct-out irc-source-servername)
|
||||||
|
(struct-out irc-source-nick)
|
||||||
|
|
||||||
parse-irc-message
|
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/string)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -42,9 +50,12 @@
|
||||||
;; (0xd), and LF (0xa)>
|
;; (0xd), and LF (0xa)>
|
||||||
|
|
||||||
(struct irc-message (prefix command params trailing) #:prefab)
|
(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-privmsg (source target text) #:prefab)
|
||||||
|
|
||||||
|
(struct irc-source-servername (servername) #:prefab)
|
||||||
|
(struct irc-source-nick (nick user) #:prefab)
|
||||||
|
|
||||||
(define (parse-irc-message line0)
|
(define (parse-irc-message line0)
|
||||||
(match (string-trim #:left? #f line0 #px"[\r\n]")
|
(match (string-trim #:left? #f line0 #px"[\r\n]")
|
||||||
[(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
|
[(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
|
||||||
|
@ -57,9 +68,26 @@
|
||||||
(string-split (or params ""))
|
(string-split (or params ""))
|
||||||
rest))
|
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)
|
(define (render-irc-message m)
|
||||||
(match-define (irc-message prefix command params trailing) m)
|
(match-define (irc-message prefix command params trailing) m)
|
||||||
(string-append (if prefix (string-append ":" prefix " ") "")
|
(string-append (render-prefix prefix)
|
||||||
(~a command)
|
(~a command)
|
||||||
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
|
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
|
||||||
(if trailing (string-append " :" trailing) "")))
|
(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"))
|
||||||
|
|
|
@ -20,7 +20,7 @@
|
||||||
(define (send-irc-message m)
|
(define (send-irc-message m)
|
||||||
(send-to-remote "~a" (render-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)))
|
(send-irc-message (irc-message prefix command params trailing)))
|
||||||
|
|
||||||
(on-start (log-info "Connecting ~a" this-conn))
|
(on-start (log-info "Connecting ~a" this-conn))
|
||||||
|
@ -36,7 +36,6 @@
|
||||||
(begin/dataflow
|
(begin/dataflow
|
||||||
(unless (motd-sent?)
|
(unless (motd-sent?)
|
||||||
(when (and (nick) (user))
|
(when (and (nick) (user))
|
||||||
(define server-name "syndicate-ircd")
|
|
||||||
(motd-sent? #t)
|
(motd-sent? #t)
|
||||||
(send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
|
(send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
|
||||||
(for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
|
(for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
|
||||||
|
@ -46,18 +45,30 @@
|
||||||
(field [initial-names-sent? #f]
|
(field [initial-names-sent? #f]
|
||||||
[initial-member-nicks (set)])
|
[initial-member-nicks (set)])
|
||||||
(during (ircd-channel-member Ch $other-conn)
|
(during (ircd-channel-member Ch $other-conn)
|
||||||
(field [previous-nick #f])
|
(field [current-other-source #f])
|
||||||
(define/query-value other-nick #f (ircd-connection-info other-conn $N _) N)
|
(define/query-value next-other-source #f
|
||||||
(on-stop (when (other-nick) (send* #:prefix (other-nick) "PART" Ch)))
|
(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
|
(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 (initial-names-sent?)
|
||||||
(if (previous-nick)
|
(if (current-other-source)
|
||||||
(when (not (equal? this-conn other-conn))
|
(when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
|
||||||
(send* #:prefix (previous-nick) "NICK" (other-nick)))
|
(send* #:source (current-other-source) "NICK"
|
||||||
(send* #:prefix (other-nick) "JOIN" Ch))
|
(irc-source-nick-nick (next-other-source))))
|
||||||
(initial-member-nicks (set-add (initial-member-nicks) (other-nick))))
|
(send* #:source (next-other-source) "JOIN" Ch))
|
||||||
(previous-nick (other-nick)))))
|
(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))
|
(on (asserted (ircd-channel-topic Ch $topic))
|
||||||
(if topic
|
(if topic
|
||||||
(send* 332 (nick) Ch #:trailing topic)
|
(send* 332 (nick) Ch #:trailing topic)
|
||||||
|
@ -67,18 +78,19 @@
|
||||||
(flush!) ;; Wait for responses to come in. GROSS and not in
|
(flush!) ;; Wait for responses to come in. GROSS and not in
|
||||||
;; general correct (e.g. in the presence of
|
;; general correct (e.g. in the presence of
|
||||||
;; pipelining)
|
;; 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) _)))
|
(on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
|
||||||
(match-define (irc-user U H S R) (user))
|
(match-define (irc-user U H R) (user))
|
||||||
(send! (ircd-event who (irc-message #f 352
|
(send! (ircd-event who (irc-message server-prefix 352
|
||||||
(list (nick) Ch U H S (nick) "H")
|
(list (nick) Ch U H server-name (nick) "H")
|
||||||
(format "0 ~a" R)))))
|
(format "0 ~a" R)))))
|
||||||
|
|
||||||
(on (message (ircd-action $other-conn (irc-privmsg $source Ch $text)))
|
(on (message (ircd-action $other-conn (irc-privmsg $source Ch $text)))
|
||||||
(when (not (equal? other-conn this-conn))
|
(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!)
|
||||||
(flush!)
|
(flush!)
|
||||||
(define nicks (initial-member-nicks))
|
(define nicks (initial-member-nicks))
|
||||||
|
@ -92,20 +104,25 @@
|
||||||
|
|
||||||
(on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text)))
|
(on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text)))
|
||||||
(when (not (equal? other-conn this-conn))
|
(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))
|
(on (message (tcp-channel-line this-conn server-handle $bs))
|
||||||
(define m (parse-irc-message (bytes->string/utf-8 bs)))
|
(define m (parse-irc-message (bytes->string/utf-8 bs)))
|
||||||
(log-info "~a -> ~v" this-conn m)
|
(log-info "~a -> ~v" this-conn m)
|
||||||
(send! (ircd-action this-conn m))
|
(send! (ircd-action this-conn m))
|
||||||
(match m
|
(match m
|
||||||
[(irc-message _ "PING" _ _) (send* "PONG")]
|
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
||||||
[(irc-message _ "NICK" (list N) _)
|
[(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])
|
(if (immediate-query [query-value #f (ircd-connection-info _ N _) #t])
|
||||||
(send* 433 N #:trailing "Nickname is already in use")
|
(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)))]
|
(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)]
|
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
||||||
[_
|
[_
|
||||||
(when (and (nick) (user))
|
(when (and (nick) (user))
|
||||||
|
@ -120,7 +137,8 @@
|
||||||
(send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
|
(send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
|
||||||
[(irc-message _ "PRIVMSG" (list Targets) Text)
|
[(irc-message _ "PRIVMSG" (list Targets) Text)
|
||||||
(for [(T (string-split Targets #px",+"))]
|
(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)]))])))
|
[_ (void)]))])))
|
||||||
|
|
||||||
(spawn #:name 'session-listener-factory
|
(spawn #:name 'session-listener-factory
|
||||||
|
|
Loading…
Reference in New Issue