Browse Source

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.
master
eta 2 years ago
parent
commit
55d2eec147
  1. 13
      irc-parser.lisp
  2. 52
      ircd-db.lisp
  3. 26
      ircd-types.lisp
  4. 50
      ircd.lisp
  5. 7
      schema.sql
  6. 5
      utils.lisp

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

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

26
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

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

7
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 (

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

Loading…
Cancel
Save