diff --git a/syndicate/examples/ircd/greeter.rkt b/syndicate/examples/ircd/greeter.rkt index b8c8f70..1eb72f6 100644 --- a/syndicate/examples/ircd/greeter.rkt +++ b/syndicate/examples/ircd/greeter.rkt @@ -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"))))) diff --git a/syndicate/examples/ircd/irssi-config b/syndicate/examples/ircd/irssi-config index a829a4d..d69ba85 100644 --- a/syndicate/examples/ircd/irssi-config +++ b/syndicate/examples/ircd/irssi-config @@ -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"; }; diff --git a/syndicate/examples/ircd/protocol.rkt b/syndicate/examples/ircd/protocol.rkt index 5ba533c..a649438 100644 --- a/syndicate/examples/ircd/protocol.rkt +++ b/syndicate/examples/ircd/protocol.rkt @@ -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) diff --git a/syndicate/examples/ircd/session.rkt b/syndicate/examples/ircd/session.rkt index 38986ee..ee62f65 100644 --- a/syndicate/examples/ircd/session.rkt +++ b/syndicate/examples/ircd/session.rkt @@ -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)))))