This commit is contained in:
Tony Garnock-Jones 2017-07-30 18:50:45 -04:00
parent 81a0351828
commit 0e28e4c572
8 changed files with 281 additions and 0 deletions

examples/ircd/.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@

examples/ircd/Makefile Normal file
View File

@ -0,0 +1,7 @@
raco make main.rkt && racket main.rkt
rm -rf compiled

examples/ircd/channel.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang syndicate/actor
(require "protocol.rkt")
(require "message.rkt")
(require/activate syndicate/reload)
(define (lookup-nick conn)
(immediate-query [query-value #f (ircd-connection-info conn $N _) N]))
(spawn #:name 'channel-factory
(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 #f 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))))
(on (message (ircd-action _ (irc-message _ "TOPIC" _ $new-topic)))
(topic new-topic))))

examples/ircd/config.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang syndicate/actor
(require/activate syndicate/reload)
(require/activate syndicate/supervise)
(require/activate syndicate/drivers/config)
(require "protocol.rkt")
(spawn #:name 'config
(assert (ircd-motd (list "Hello, world!")))
(assert (ircd-listener 6667)))

examples/ircd/main.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang syndicate/actor
(require/activate syndicate/reload)
(spawn-reloader "config.rkt")
(spawn-reloader "session.rkt")
(spawn-reloader "channel.rkt")

examples/ircd/message.rkt Normal file
View File

@ -0,0 +1,65 @@
#lang racket/base
(provide (struct-out irc-message)
(struct-out irc-user)
(struct-out irc-privmsg)
(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 servername realname) #:prefab)
(struct irc-privmsg (source target text) #: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-split (or params ""))
(define (render-irc-message m)
(match-define (irc-message prefix command params trailing) m)
(string-append (if prefix (string-append ":" prefix " ") "")
(~a command)
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
(if trailing (string-append " :" trailing) "")))

View File

@ -0,0 +1,23 @@
#lang syndicate/actor
(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))
;; 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

examples/ircd/session.rkt Normal file
View File

@ -0,0 +1,137 @@
#lang syndicate/actor
(require racket/set)
(require racket/string)
(require "protocol.rkt")
(require "message.rkt")
(require/activate syndicate/reload)
(require/activate syndicate/drivers/tcp)
(require/activate syndicate/drivers/line-reader)
(require syndicate/protocol/advertise)
(define (ircd-connection-facet this-conn server-handle)
(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-channel server-handle 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* #:prefix [prefix #f] #: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))
(during (ircd-motd $motd-lines)
(field [motd-sent? #f])
(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)))
(send* 376 (nick) #:trailing (format "End of /MOTD command"))))))
(during (ircd-channel-member $Ch this-conn)
(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)))
(when (not (equal? (previous-nick) (other-nick)))
(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)))))
(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 #f 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")
(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)))
(on-start (send* #:prefix (nick) "JOIN" Ch)
(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")))
(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* #:prefix 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) _)
(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))
(nick N)))]
[(irc-message _ "USER" (list U H S) R) (user (irc-user U H S 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 (nick) T Text))))]
[_ (void)]))])))
(spawn #:name 'session-listener-factory
(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))
(assert (advertise (observe (tcp-channel _ server-handle _))))
(during/spawn (advertise (tcp-channel $this-conn server-handle _))
#:name `(ircd-connection ,this-conn ,server-handle)
(assert (advertise (tcp-channel server-handle this-conn _)))
(ircd-connection-facet this-conn server-handle))))