Associate each connection with a device ID as well

- Each connection can now specify a device name (by appending
  a colon to the password and then putting it in there).
- This will be useful later when tracking per-device read state.
- Also we fixed a bug in the parser where colons without
  spaces before them would be interpreted as trailing. Oops.

irc-parser.lisp

@@ -71,10 +71,15 @@
 (defun parse-inner (tags source args msg)
   (if (or (and tags source) source args)
     (multiple-value-bind (args-bit trailing-bit)
-      (split-string-at-first msg #\: t)
-      (if (string-empty-p trailing-bit)
-        (slurp-args tags source args nil args-bit)
-        (slurp-args tags source args trailing-bit args-bit)))
+      (split-string-at-first msg #\: t t)
+      ;; The : has to have a space before it to be a valid trailing bit.
+      ;; The first `if' checks whether it's something else; if it is, we continue as if we never did the split.
+      (if (and (not (string-empty-p args-bit))
+               (not (equal (elt args-bit (1- (length args-bit))) #\Space)))
+          (slurp-args tags source args nil msg)
+          (if (string-empty-p trailing-bit)
+              (slurp-args tags source args nil args-bit)
+              (slurp-args tags source args trailing-bit args-bit))))
     (multiple-value-bind (first-word remaining)
         (split-string-at-first msg #\Space t)
       (if (string-empty-p remaining)

ircd-db.lisp

@@ -13,14 +13,33 @@
      (let ((rows-modified (pomo:execute ,@args)))
        (assert (eql rows-modified 1) () "Modified ~A rows in an EXECUTE-ONE command" rows-modified))))
 
-(defclass local-user ()
-  ((username :initarg :username
-             :accessor user-name)
-   (password :initarg :password
-             :initform "*"
-             :accessor local-user-password)
-   (email :initarg :email
-          :accessor local-user-email)))
+(defclass message ()
+  ((msgid :col-type uuid
+          :initarg :msgid
+          :reader message-msgid)
+   (user-from :col-type int
+              :col-name user_from
+              :initarg :user-from
+              :reader message-user-from)
+   (user-to :col-type int
+            :col-name user_to
+            :initarg :user-to
+            :reader message-user-to)
+   (tags :col-type varchar
+         :initarg :tags
+         :reader message-tags)
+   (body :col-type varchar
+         :initarg :body
+         :reader message-body)
+   (origin-ts :col-type timestamp
+              :col-name origin_ts
+              :initarg :origin-ts
+              :reader message-origin-ts)
+   (local-ts :col-type timestamp
+             :col-name local_ts
+             :initarg :local-ts
+             :reader message-local-ts))
+  (:metaclass pomo:dao-class))
 
 (defun register-user (username plaintext-password email)
   "Registers a user with a given USERNAME, PLAINTEXT-PASSWORD and EMAIL, returning the ID of the new user created."
@@ -67,6 +86,23 @@ If they authenticate successfully, returns the user ID; if they don't, returns N
         (when (ironclad:pbkdf2-check-password provided-pw pw-string)
           uid)))))
 
+(defun get-user-device (uid device-name)
+  "Gets or creates a user device (called DEVICE-NAME) for the user with ID UID."
+  (pomo:with-logical-transaction ()
+    (let ((maybe-device
+            (pomo:query (:select 'id
+                         :from 'local_user_devices
+                         :where (:and
+                                 (:= 'name '$1)
+                                 (:= 'user_id '$2)))
+                        device-name uid :single)))
+      (if maybe-device
+          maybe-device
+          (pomo:query (:insert-into 'local_user_devices
+                       :set 'user_id '$1 'name '$2
+                       :returning 'id)
+                      uid device-name :single!)))))
+
 (defun initialize-database (&optional (args *default-database-args*))
   "Connect to the PostgreSQL database."
   (apply #'postmodern:connect-toplevel args))

ircd-types.lisp

@@ -74,10 +74,7 @@
   (make-instance 'reginfo))
 
 (defclass irc-client ()
-  ((uid
-    :initarg :uid
-    :reader client-uid)
-   (socket
+  ((socket
     :initarg :socket)
    (address
     :initarg :address)
@@ -96,7 +93,11 @@
    (userid
     :initarg :userid
     :initform nil
-    :accessor client-userid)))
+    :accessor client-userid)
+   (deviceid
+    :initarg :deviceid
+    :initform nil
+    :accessor client-deviceid)))
 
 (defclass unregistered-irc-client (irc-client) ())
 (defclass registered-irc-client (irc-client) ())
@@ -121,18 +122,20 @@
 (defgeneric server-to-user (client msg))
 (defgeneric authenticate-client (client authentication-data)
   (:documentation "Authenticate a client with the provided information.
-Returns the new username and user ID (as second value) if successful, and NIL if not."))
+Returns the new username, user ID, and device ID (as multiple values) if successful, and NIL if not."))
 
 (defmethod authenticate-client (client ad)
   (format t "Client authentication fallback hit~%")
   nil)
 
 (defmethod authenticate-client :around ((client irc-client) ad)
-  (multiple-value-bind (username uid) (call-next-method)
+  (multiple-value-bind (username uid devid) (call-next-method)
     (when username
-      (format t "Client authenticated as ~A (#~A)~%" username uid)
+      (assert (and uid devid) () "AUTHENTICATE-CLIENT didn't return a uid or devid")
+      (format t "Client authenticated as ~A (#~A, device #~A)~%" username uid devid)
       (setf (client-username client) username)
       (setf (client-userid client) uid)
+      (setf (client-deviceid client) devid)
       (symbol-macrolet ((nick (reginfo-nick (client-reginfo client))))
         (unless (eql nick username)
           (setf nick username)
@@ -172,16 +175,9 @@ Returns the new username and user ID (as second value) if successful, and NIL if
 (defmethod server-to-user ((client registered-irc-client) (msg irc-message))
   (call-next-method client (cons-onto-params (reginfo-nick (client-reginfo client)) msg)))
 
-(defvar *client-number* 0
-  "Monotonically incrementing client ID number")
-
-(defun make-client-uid ()
-  (incf *client-number*))
-
 (defun make-irc-client (sock)
   (let ((rl (make-lock)) (wl (make-lock)))
     (make-instance 'unregistered-irc-client
-                   :uid (make-client-uid)
                    :socket sock
                    :address (get-peer-address sock)
                    :socket-reader-lock rl

ircd.lisp

@@ -3,18 +3,39 @@
 (in-package :nea/ircd)
 
 (defvar *clients* (make-hash-table)
-  "A table of clients, indexed by their client UID.")
+  "A table of clients, indexed by their account IDs.")
 (defvar *clients-lock* (make-lock))
 
+(defun add-client (client)
+  "Add CLIENT to *CLIENTS*."
+  (check-type client registered-irc-client)
+  (assert (client-userid client) () "Client has no user id")
+  (with-lock-held (*clients-lock*)
+    (symbol-macrolet ((entry (gethash (client-userid client) *clients*)))
+      (setf entry (cons client entry)))))
+
+(defun remove-client (user-id)
+  "Remove the client with USER-ID from *CLIENTS*."
+  (with-lock-held (*clients-lock*)
+    (symbol-macrolet ((entry (gethash user-id *clients*)))
+      (flet ((remove-test (client) (eql user-id (client-userid client))))
+        (when entry
+          (setf entry (remove-if #'remove-test entry)))))))
+
 (defgeneric handle-irc-message (client msg))
 (defgeneric handle-irc-user-error (client condit))
 (defgeneric handle-quit (client reason))
 
 (defmethod authenticate-client ((client irc-client) (ad basic-authentication-data))
-  (with-accessors ((username authdata-username) (password authdata-password)) ad
-    (let ((uid (check-user-credentials username password)))
-      (when uid
-        (values username uid)))))
+  (with-accessors ((username authdata-username) (password-str authdata-password)) ad
+    (destructuring-bind (password &optional device-name)
+        (uiop:split-string password-str
+                           :max 2
+                           :separator ":")
+      (let ((uid (check-user-credentials username password)))
+        (when uid
+          (let ((devid (get-user-device uid (or device-name "default"))))
+            (values username uid devid)))))))
 
 (defmethod handle-irc-user-error ((client irc-client) (err irc-user-error))
   (server-to-user
@@ -33,7 +54,7 @@
            :reason "You must authenticate (via SASL or PASS) to use this server"))
   (format t "Client at ~A registered~%" (slot-value c 'address))
   (change-class c 'registered-irc-client)
-  (setf (gethash (client-uid c) *clients*) c)
+  (add-client c)
   (mapcar (lambda (msg) (server-to-user c msg)) *client-registration-wall-o-text*))
 
 (defmethod handle-irc-user-error :after ((c irc-client) o)
@@ -51,7 +72,7 @@
                       :params (cons (or reason "Closing link after QUIT") nil)))
    (socket-close (slot-value c 'socket)))
   (when (typep c (find-class 'registered-irc-client))
-    (with-lock-held (*clients-lock*) (remhash (client-uid c) *clients*))))
+    (remove-client (client-userid c))))
 
 (defmethod handle-quit ((c irc-client) reason) ())
 
@@ -101,13 +122,18 @@
                          (client (make-irc-client sock)))
                     (make-thread
                      (lambda ()
-                       (irc-client-thread client)))))
+                       (pomo:with-connection *default-database-args*
+                         (irc-client-thread client))))))
       (ignore-errors (socket-close master-socket)))))
 
+(defun message-delivery-thread ()
+  "Thread entry point for the message delivery thread.
+This thread waits for new messages to be added to the database (via PostgreSQL LISTEN).
+When they arrive, it delivers them to connected clients."
+  (pomo:execute (:listen "ircd-messages"))
+  (loop
+    (cl-postgres:wait-for-notification pomo:*database*)))
+
 (defun start-ircd (&optional (host *listen-host*) (port *listen-port*))
-  (unless (and pomo:*database* (pomo:connected-p pomo:*database*)
-    (format t "Connecting to database...")
-    (initialize-database)
-    (format t "done.~%"))
   (format t "Starting server on ~A, port ~A...~%" host port)
   (irc-listen host port))

schema.sql

@@ -19,10 +19,11 @@ CREATE TABLE local_users (
 );
 
 CREATE TABLE local_user_devices (
+       id SERIAL PRIMARY KEY,
+       name VARCHAR NOT NULL,
        user_id INT NOT NULL REFERENCES users ON DELETE CASCADE,
-       device_id VARCHAR NOT NULL,
-       delivered_ts TIMESTAMP NOT NULL,
-       UNIQUE(user_id, device_id)
+       delivered_ts TIMESTAMP NOT NULL DEFAULT '1970-01-01',
+       UNIQUE(user_id, name)
 );
 
 CREATE TABLE groupchats (

utils.lisp

@@ -10,10 +10,11 @@
     ((eql pos (length str)) (values str ""))
     (t (values (subseq str 0 pos) (subseq str (+ pos (if consume-value-at-pos-p 1 0)))))))
 
-(defun split-string-at-first (str char &optional (consume-value-at-pos-p nil))
+(defun split-string-at-first (str char &optional (consume-value-at-pos-p nil) (from-end nil))
   "Splits STR at the first instance of CHAR, otherwise behaving like SPLIT-STRING-AT. If no CHAR is found, returns the input string and an empty string."
   (declare (type string str) (type character char))
-  (let ((pos (position char str)))
+  (let ((pos (position char str
+                       :from-end from-end)))
     (if pos
       (split-string-at str pos consume-value-at-pos-p)
       (values str ""))))