PASS; better NICK collision avoidance

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")))))

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";
+    real_name = "Alice Exampleuser";
-    user_name = "tonyg";
+    user_name = "alice";
     nick = "client";
   };
   "fe-text" = { actlist_sort = "refnum"; };

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)

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])
+         [user #f]
-  (define/dataflow conn-info (ircd-connection-info this-conn (nick) (user)))
+         [password #f]
-  (assert (conn-info))
+         [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))
+           (stop-current-facet
-           (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
+            (react
-           (send* 376 (nick) #:trailing (format "End of /MOTD command"))
+             (stop-when (asserted (ircd-credentials (nick) (user) (password) $valid?))
-           (stop-current-facet)))))))
+               (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])
+         (react (assert (claim (ircd-nick N) this-conn))
-             (send* 433 N #:trailing "Nickname is already in use")
+                (on (asserted (decision (ircd-nick N) $who))
-             (begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
+                    (if (equal? who this-conn)
-                    (nick N)))]
+                        (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)))))