239 lines
11 KiB
Racket
239 lines
11 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang syndicate
|
|
|
|
(require racket/set)
|
|
(require racket/string)
|
|
|
|
(require "protocol.rkt")
|
|
(require "message.rkt")
|
|
|
|
(require/activate syndicate/reload)
|
|
(require/activate syndicate/drivers/tcp)
|
|
(require syndicate/support/hash)
|
|
(require (only-in racket/list append*))
|
|
|
|
(spawn #:name 'affine-resource-arbiter
|
|
(stop-when-reloaded)
|
|
(during (claim $resource _)
|
|
(define/query-set claimants (claim resource $claimant) claimant)
|
|
(field [holder #f])
|
|
(begin/dataflow
|
|
(when (not (set-member? (claimants) (holder)))
|
|
(holder (and (not (set-empty? (claimants)))
|
|
(set-first (claimants))))))
|
|
(assert #:when (holder) (decision resource (holder)))))
|
|
|
|
(define (ircd-connection-facet connection-root-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]
|
|
[password #f]
|
|
[registered? #f])
|
|
(assert (ircd-connection-info this-conn (nick) (user)))
|
|
(assert #:when (nick) (claim (ircd-nick (nick)) this-conn))
|
|
|
|
(on-start
|
|
(react
|
|
(stop-when (asserted (ircd-motd $motd-lines))
|
|
(react
|
|
(begin/dataflow
|
|
(when (and (nick) (user))
|
|
(stop-current-facet
|
|
(react
|
|
(stop-when (asserted (ircd-credentials (nick) (user) (password) $valid?))
|
|
(cond
|
|
[valid?
|
|
(registered? #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"))
|
|
(assert! (ircd-channel-member "#syndicate" this-conn)) ;; force membership!
|
|
]
|
|
[else
|
|
(send* 464 (nick) #:trailing "Password incorrect")
|
|
(stop-facet connection-root-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 $notice?)))
|
|
(when (not (equal? other-conn this-conn))
|
|
(send* #:source source (if notice? "NOTICE" "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 $notice?)))
|
|
(when (not (equal? other-conn this-conn))
|
|
(send* #:source source (if notice? "NOTICE" "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))
|
|
(issue-credit! tcp-in this-conn)
|
|
(match m
|
|
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
|
[(or (irc-message _ "PASS" (list P) _)
|
|
(irc-message _ "PASS" '() P)) ;; libpurple does this (!)
|
|
(if (registered?)
|
|
(send* 462 (nick) #:trailing "You may not reregister")
|
|
(password P))]
|
|
[(or (irc-message _ "NICK" (list N) _)
|
|
(irc-message _ "NICK" '() N)) ;; libpurple does this (!)
|
|
;; TODO: enforce syntactic restrictions on nick
|
|
(react (assert (claim (ircd-nick N) this-conn))
|
|
(on (asserted (decision (ircd-nick N) $who))
|
|
(if (equal? who this-conn)
|
|
(begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
|
|
(nick N))
|
|
(send* 433 (or (nick) "*") N #:trailing "Nickname is already in use"))
|
|
(stop-current-facet)))]
|
|
[(irc-message _ "USER" (list U _Hostname _Servername) R)
|
|
;; TODO: enforce syntactic restrictions on parameters to USER
|
|
(if (registered?)
|
|
(send* 462 (nick) #:trailing "You may not reregister")
|
|
(user (irc-user U peer-host R)))]
|
|
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
|
[_
|
|
(when (registered?)
|
|
(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 _
|
|
(and cmd (or "PRIVMSG" "NOTICE"))
|
|
(list Targets)
|
|
Text)
|
|
(for [(T (string-split Targets #px",+"))]
|
|
(send! (ircd-action this-conn
|
|
(irc-privmsg (irc-source-nick (nick) (user))
|
|
T
|
|
Text
|
|
(equal? cmd "NOTICE")))))]
|
|
[_ (void)]))])))
|
|
|
|
(spawn #:name 'ison-responder
|
|
(stop-when-reloaded)
|
|
(define/query-set nicks (ircd-connection-info _ $N _) N)
|
|
(on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
|
|
(define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
|
|
(define (on? N) (set-member? (nicks) N))
|
|
(define Present (string-join (filter on? Nicks) " "))
|
|
(send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
|
|
|
|
(spawn #:name 'list-responder
|
|
(stop-when-reloaded)
|
|
(define/query-hash topics (ircd-channel-topic $Ch $topic) Ch topic)
|
|
(define/query-hash counts (ircd-channel-user-count $Ch $count) Ch count)
|
|
(on (message (ircd-action $conn (irc-message _ "LIST" $requested-channel-names0 _)))
|
|
(define requested-channel-names
|
|
(append* (map (lambda (ns) (string-split ns #px",+")) requested-channel-names0)))
|
|
(send! (ircd-event conn (irc-message server-prefix 321 '("*" "Channel") "Users Name")))
|
|
(for [(Ch (if (null? requested-channel-names)
|
|
(in-hash-keys (topics))
|
|
(in-list requested-channel-names)))]
|
|
(when (hash-has-key? (topics) Ch)
|
|
(define topic (hash-ref (topics) Ch))
|
|
(define count (hash-ref (counts) Ch 0))
|
|
(send! (ircd-event conn (irc-message server-prefix 322 (list "*" Ch count) topic)))))
|
|
(send! (ircd-event conn (irc-message server-prefix 323 '("*") "End of /LIST")))))
|
|
|
|
(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)
|
|
(define connection-root-facet (current-facet))
|
|
(on-start (issue-credit! server-handle)
|
|
(issue-credit! tcp-in this-conn))
|
|
(during (tcp-connection-peer this-conn (tcp-address $peer-host _))
|
|
(assert (tcp-accepted this-conn))
|
|
(ircd-connection-facet connection-root-facet this-conn peer-host)))))
|