PASS; better NICK collision avoidance
This commit is contained in:
Tony Garnock-Jones
parent
823754c8b5
commit
c5848e4c0b
|
|
@ -13,3 +13,9 @@
|
|||
;; TODO: history replay? As the following illustrates, we are able to forge messages
|
||||
(send! (ircd-event conn (irc-message (irc-source-nick N U) "PRIVMSG" (list Ch)
|
||||
(format "Welcome to ~a, ~a!" Ch N))))))
|
||||
|
||||
(spawn #:name 'authenticator
|
||||
(stop-when-reloaded)
|
||||
(during (observe (ircd-credentials $nick $user $password _))
|
||||
(log-info "Credentials: ~a ~a ~a" nick user password)
|
||||
(assert (ircd-credentials nick user password (equal? password "foobar")))))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ servers = (
|
|||
chatnet = "Syndicate";
|
||||
port = "6667";
|
||||
autoconnect = "yes";
|
||||
password = "foobar";
|
||||
}
|
||||
);
|
||||
|
||||
|
|
@ -15,8 +16,8 @@ channels = (
|
|||
);
|
||||
settings = {
|
||||
core = {
|
||||
real_name = "Tony Garnock-Jones";
|
||||
user_name = "tonyg";
|
||||
real_name = "Alice Exampleuser";
|
||||
user_name = "alice";
|
||||
nick = "client";
|
||||
};
|
||||
"fe-text" = { actlist_sort = "refnum"; };
|
||||
|
|
|
|||
|
|
@ -3,6 +3,10 @@
|
|||
(provide (struct-out ircd-listener)
|
||||
(struct-out ircd-motd)
|
||||
|
||||
(struct-out claim)
|
||||
(struct-out decision)
|
||||
|
||||
(struct-out ircd-nick)
|
||||
(struct-out ircd-connection-info)
|
||||
(struct-out ircd-channel)
|
||||
(struct-out ircd-channel-member)
|
||||
|
|
@ -12,14 +16,39 @@
|
|||
(struct-out ircd-action)
|
||||
(struct-out ircd-event)
|
||||
|
||||
(struct-out ircd-credentials)
|
||||
|
||||
lookup-nick)
|
||||
|
||||
;; A Connection is a TcpAddress
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Configuration
|
||||
|
||||
;; (ircd-listener PortNumber) - causes TCP connections to be accepted on this port
|
||||
(assertion-struct ircd-listener (port))
|
||||
|
||||
;; (ircd-motd (Listof String)) - Message Of The Day text
|
||||
(assertion-struct ircd-motd (lines))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Affine resources
|
||||
|
||||
;; (claim Any NonFalse) -- any number of these. Decider picks a claimant
|
||||
(assertion-struct claim (resource claimant))
|
||||
|
||||
;; (decision Any NonFalse) -- zero or one of these for a given resource.
|
||||
(assertion-struct decision (resource resource-holder))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; IRC protocol
|
||||
|
||||
;; (ircd-nick String) - a unique resource
|
||||
(assertion-struct ircd-nick (name))
|
||||
|
||||
;; (ircd-connection-info Connection String IRCUser) -- mapping: nick <--> conn + userinfo
|
||||
(assertion-struct ircd-connection-info (conn nick user))
|
||||
|
||||
(assertion-struct ircd-channel (channel))
|
||||
(assertion-struct ircd-channel-member (channel conn))
|
||||
(assertion-struct ircd-channel-topic (channel topic))
|
||||
|
|
@ -28,6 +57,11 @@
|
|||
(message-struct ircd-action (conn message))
|
||||
(message-struct ircd-event (conn message))
|
||||
|
||||
(assertion-struct ircd-credentials (nick user password valid?))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Application: chatroom model
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (lookup-nick conn)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,18 @@
|
|||
(require syndicate/support/hash)
|
||||
(require (only-in racket/list append*))
|
||||
|
||||
(define (ircd-connection-facet this-conn peer-host)
|
||||
(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)
|
||||
|
|
@ -27,9 +38,11 @@
|
|||
(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))
|
||||
[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
|
||||
|
|
@ -37,10 +50,18 @@
|
|||
(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)))))))
|
||||
(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"))]
|
||||
[else
|
||||
(send* 464 (nick) #:trailing "Password incorrect")
|
||||
(stop-facet connection-root-facet)]))))))))))
|
||||
|
||||
(field [peer-common-channels (hash)]
|
||||
[peer-names (hash)])
|
||||
|
|
@ -124,19 +145,28 @@
|
|||
(send! (ircd-action this-conn m))
|
||||
(match m
|
||||
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
||||
[(irc-message _ "PASS" (list P) _)
|
||||
(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
|
||||
(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)))]
|
||||
(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
|
||||
(user (irc-user U peer-host R))]
|
||||
(if (registered?)
|
||||
(send* 462 (nick) #:trailing "You may not reregister")
|
||||
(user (irc-user U peer-host R)))]
|
||||
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
||||
[_
|
||||
(when (and (nick) (user))
|
||||
(when (registered?)
|
||||
(match m
|
||||
[(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
|
|
@ -187,6 +217,7 @@
|
|||
(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))
|
||||
(during (tcp-connection-peer this-conn (tcp-address $peer-host _))
|
||||
(assert (tcp-accepted this-conn))
|
||||
(ircd-connection-facet this-conn peer-host)))))
|
||||
(ircd-connection-facet connection-root-facet this-conn peer-host)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue