syndicate-rkt/syndicate-examples/ircd/message.rkt

94 lines
3.4 KiB
Racket

#lang racket/base
(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
;; TODO make these assertions in the dataspace:
server-name
server-prefix)
(require racket/string)
(require racket/match)
(require racket/format)
;; <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
;; <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
;; <command> ::= <letter> { <letter> } | <number> <number> <number>
;; <SPACE> ::= ' ' { ' ' }
;; <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
;;
;; <middle> ::= <Any *non-empty* sequence of octets not including SPACE
;; or NUL or CR or LF, the first of which may not be ':'>
;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
;; NUL or CR or LF>
;;
;; <crlf> ::= CR LF
;; <target> ::= <to> [ "," <target> ]
;; <to> ::= <channel> | <user> '@' <servername> | <nick> | <mask>
;; <channel> ::= ('#' | '&') <chstring>
;; <servername> ::= <host>
;; <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
;; <nick> ::= <letter> { <letter> | <number> | <special> }
;; <mask> ::= ('#' | '$') <chstring>
;; <chstring> ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
;; comma (',')>
;; <user> ::= <nonwhite> { <nonwhite> }
;; <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
;; <number> ::= '0' ... '9'
;; <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
;; <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
;; (0xd), and LF (0xa)>
(struct irc-message (prefix command params trailing) #:prefab)
(struct irc-user (username hostname realname) #:prefab)
(struct irc-privmsg (source target text notice?) #: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)]
[line (parse-command #f line)]))
(define (parse-command prefix line)
(match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
(irc-message prefix
(string-upcase command)
(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 (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"))