diff --git a/syndicate/examples/ircd/Makefile b/syndicate/examples/ircd/Makefile new file mode 100644 index 0000000..61d09de --- /dev/null +++ b/syndicate/examples/ircd/Makefile @@ -0,0 +1,7 @@ +all: + +run: + raco make main.rkt && racket main.rkt + +clean: + rm -rf compiled diff --git a/syndicate/examples/ircd/channel.rkt b/syndicate/examples/ircd/channel.rkt new file mode 100644 index 0000000..54c05d6 --- /dev/null +++ b/syndicate/examples/ircd/channel.rkt @@ -0,0 +1,24 @@ +#lang imperative-syndicate + +(require "protocol.rkt") +(require "message.rkt") + +(require/activate imperative-syndicate/reload) + +(spawn #:name 'channel-factory + (stop-when-reloaded) + (during/spawn (ircd-channel-member $Ch _) + #:name `(ircd-channel ,Ch) + (field [topic #f]) + (assert (ircd-channel-topic Ch (topic))) + + (on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _))) + (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 server-prefix 324 + (list (lookup-nick who) Ch "+") #f)))) + + (on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic))) + (topic new-topic)))) diff --git a/syndicate/examples/ircd/config.rkt b/syndicate/examples/ircd/config.rkt new file mode 100644 index 0000000..fe8ef19 --- /dev/null +++ b/syndicate/examples/ircd/config.rkt @@ -0,0 +1,24 @@ +#lang imperative-syndicate + +(require/activate imperative-syndicate/reload) +(require/activate imperative-syndicate/supervise) +(require/activate imperative-syndicate/drivers/config) + +(require "protocol.rkt") + +(require racket/set) +(require (only-in racket/list append* flatten)) +(require (only-in racket/string string-split)) + +(spawn-configuration 'ircd "ircd-config.rktd" #:hook (lambda () (stop-when-reloaded))) + +(spawn #:name 'config + (stop-when-reloaded) + + (during (config 'ircd `(port ,$port)) + (assert (ircd-listener port))) + + (define/query-set motds (config 'ircd `(motd ,$text)) text) + (assert (ircd-motd (append* + (map (lambda (t) (string-split t "\n")) + (flatten (set->list (motds)))))))) diff --git a/syndicate/examples/ircd/ircd-config.rktd b/syndicate/examples/ircd/ircd-config.rktd new file mode 100644 index 0000000..c506483 --- /dev/null +++ b/syndicate/examples/ircd/ircd-config.rktd @@ -0,0 +1,2 @@ +(port 6667) +(motd "Hello, world!") diff --git a/syndicate/examples/ircd/irssi-config b/syndicate/examples/ircd/irssi-config new file mode 100644 index 0000000..5af65cd --- /dev/null +++ b/syndicate/examples/ircd/irssi-config @@ -0,0 +1,23 @@ +servers = ( + { + address = "localhost"; + chatnet = "Syndicate"; + port = "6667"; + autoconnect = "yes"; + } +); + +chatnets = { Syndicate = { type = "IRC"; }; }; + +channels = ( + { name = "#test"; chatnet = "Syndicate"; autojoin = "yes"; }, + { name = "#test2"; chatnet = "Syndicate"; autojoin = "yes"; } +); +settings = { + core = { + real_name = "Tony Garnock-Jones"; + user_name = "tonyg"; + nick = "two"; + }; + "fe-text" = { actlist_sort = "refnum"; }; +}; diff --git a/syndicate/examples/ircd/main.rkt b/syndicate/examples/ircd/main.rkt new file mode 100644 index 0000000..69d1554 --- /dev/null +++ b/syndicate/examples/ircd/main.rkt @@ -0,0 +1,7 @@ +#lang imperative-syndicate + +(require/activate imperative-syndicate/reload) + +(spawn-reloader "config.rkt") +(spawn-reloader "session.rkt") +(spawn-reloader "channel.rkt") diff --git a/syndicate/examples/ircd/message.rkt b/syndicate/examples/ircd/message.rkt new file mode 100644 index 0000000..50d1b46 --- /dev/null +++ b/syndicate/examples/ircd/message.rkt @@ -0,0 +1,93 @@ +#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) + +;; ::= [':' ] +;; ::= | [ '!' ] [ '@' ] +;; ::= { } | +;; ::= ' ' { ' ' } +;; ::= [ ':' | ] +;; +;; ::= +;; ::= +;; +;; ::= CR LF + +;; ::= [ "," ] +;; ::= | '@' | | +;; ::= ('#' | '&') +;; ::= +;; ::= see RFC 952 [DNS:4] for details on allowed hostnames +;; ::= { | | } +;; ::= ('#' | '$') +;; ::= + +;; ::= { } +;; ::= 'a' ... 'z' | 'A' ... 'Z' +;; ::= '0' ... '9' +;; ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}' + +;; ::= + +(struct irc-message (prefix command params trailing) #: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)] + [line (parse-command #f line)])) + +(define (parse-command prefix line) + (match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line) + (irc-message prefix + 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")) diff --git a/syndicate/examples/ircd/protocol.rkt b/syndicate/examples/ircd/protocol.rkt new file mode 100644 index 0000000..81498d7 --- /dev/null +++ b/syndicate/examples/ircd/protocol.rkt @@ -0,0 +1,30 @@ +#lang imperative-syndicate + +(provide (struct-out ircd-listener) + (struct-out ircd-motd) + + (struct-out ircd-connection-info) + (struct-out ircd-channel-member) + (struct-out ircd-channel-topic) + + (struct-out ircd-action) + (struct-out ircd-event) + + lookup-nick) + +;; A Connection is a TcpAddress + +(struct ircd-listener (port) #:prefab) ;; assertion +(struct ircd-motd (lines) #:prefab) ;; assertion + +(struct ircd-connection-info (conn nick user) #:prefab) ;;assertion +(struct ircd-channel-member (channel conn) #:prefab) ;; assertion +(struct ircd-channel-topic (channel topic) #:prefab) ;; assertion + +(struct ircd-action (conn message) #:prefab) ;; message +(struct ircd-event (conn message) #:prefab) ;; message + +;;--------------------------------------------------------------------------- + +(define (lookup-nick conn) + (immediate-query [query-value #f (ircd-connection-info conn $N _) N])) diff --git a/syndicate/examples/ircd/session.rkt b/syndicate/examples/ircd/session.rkt new file mode 100644 index 0000000..552411f --- /dev/null +++ b/syndicate/examples/ircd/session.rkt @@ -0,0 +1,165 @@ +#lang imperative-syndicate + +(require racket/set) +(require racket/string) + +(require "protocol.rkt") +(require "message.rkt") + +(require/activate imperative-syndicate/reload) +(require/activate imperative-syndicate/drivers/tcp) +(require syndicate/support/hash) + +(define (ircd-connection-facet this-conn peer-host) + (define (send-to-remote #:newline [with-newline #t] fmt . vs) + (define bs (string->bytes/utf-8 (apply format fmt vs))) + (log-info "~a <- ~v" this-conn bs) + (send! (tcp-out this-conn (if with-newline (bytes-append bs #"\r\n") bs)))) + + (define (send-irc-message m) + (send-to-remote "~a" (render-irc-message m))) + + (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)) + (on-stop (log-info "Disconnecting ~a" this-conn)) + + (field [nick #f] + [user #f]) + (define/dataflow conn-info (ircd-connection-info this-conn (nick) (user))) + (assert (conn-info)) + + (on-start + (react + (stop-when (asserted (ircd-motd $motd-lines)) + (react + (begin/dataflow + (when (and (nick) (user)) + (send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name)) + (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line))) + (send* 376 (nick) #:trailing (format "End of /MOTD command")) + (stop-current-facet))))))) + + (field [peer-common-channels (hash)] + [peer-names (hash)]) + + (during (ircd-channel-member $Ch this-conn) + (field [initial-names-sent? #f] + [initial-member-nicks (set)]) + + (on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch) + (flush!) + (flush!) + (define nicks (initial-member-nicks)) + (initial-names-sent? #t) + (initial-member-nicks 'no-longer-valid) + (send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks))) + (send* 366 (nick) Ch #:trailing "End of /NAMES list")) + + (during (ircd-channel-member Ch $other-conn) + (on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch))) + (on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn 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 (retracted (ircd-channel-member Ch other-conn)) + (when (current-other-source) (send* #:source (current-other-source) "PART" Ch))) + (on-stop (when (not (hash-has-key? (peer-common-channels) other-conn)) + (peer-names (hash-remove (peer-names) other-conn)))) + (begin/dataflow + (when (not (equal? (current-other-source) (next-other-source))) + (if (not (next-other-source)) ;; other-conn is disconnecting + (when (hash-ref (peer-names) other-conn #f) + (send* #:source (current-other-source) "QUIT") + (peer-names (hash-remove (peer-names) other-conn))) + (begin + (cond + [(not (initial-names-sent?)) ;; still gathering data for 353/366 below + (initial-member-nicks (set-add (initial-member-nicks) + (irc-source-nick-nick (next-other-source))))] + [(not (current-other-source)) ;; other-conn is joining + (send* #:source (next-other-source) "JOIN" Ch)] + [else ;; it's a nick change + (when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection + (when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f))) + (send* #:source (current-other-source) "NICK" + (irc-source-nick-nick (next-other-source)))))]) + (peer-names (hash-set (peer-names) other-conn (next-other-source))))) + (current-other-source (next-other-source))))) + + (on (asserted (ircd-channel-topic Ch $topic)) + (if topic + (send* 332 (nick) Ch #:trailing topic) + (send* 331 (nick) Ch #:trailing "No topic is set"))) + + (on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _))) + (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 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 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* #:source source "PRIVMSG" Ch #:trailing text)))) + + (on (message (ircd-event this-conn $m)) + (send-irc-message m)) + + (on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text))) + (when (not (equal? other-conn this-conn)) + (send* #:source source "PRIVMSG" (nick) #:trailing text))) + + (on (message (tcp-in-line this-conn $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" _ _) (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* #:source (irc-source-nick (nick) (user)) "NICK" N)) + (nick N)))] + [(irc-message _ "USER" (list U _Hostname _Servername) R) + ;; TODO: enforce syntactic restrictions on parameters to USER + (user (irc-user U peer-host R))] + [(irc-message _ "QUIT" _ _) (stop-current-facet)] + [_ + (when (and (nick) (user)) + (match m + [(irc-message _ "JOIN" (cons Channels _MaybeKeys) _) + (for [(Ch (string-split Channels #px",+"))] + (assert! (ircd-channel-member Ch this-conn)))] + [(irc-message _ "PART" (list Channels) _) + (for [(Ch (string-split Channels #px",+"))] + (retract! (ircd-channel-member Ch this-conn)))] + [(irc-message _ "WHOIS" _ _) + (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 (irc-source-nick (nick) (user)) T Text))))] + [_ (void)]))]))) + +(spawn #:name 'session-listener-factory + (stop-when-reloaded) + (during/spawn (ircd-listener $port) + #:name (ircd-listener port) + (on-start (log-info "Listening on port ~a." port)) + (on-stop (log-info "No longer listening on port ~a." port)) + (define server-handle (tcp-listener port)) + (during/spawn (tcp-connection $this-conn server-handle) + #:name `(ircd-connection ,this-conn) + (during (tcp-connection-peer this-conn (tcp-address $peer-host _)) + (assert (tcp-accepted this-conn)) + (ircd-connection-facet this-conn peer-host)))))