Browse Source

Make message handling more generic (adding in system messages)

- This sets us up for storing JOIN and PART messages (for groupchats)
  in the database.
  - These are stored as 'system messages', which are essentially
    somewhat hacky objects with various reference fields that
    are filled in depending on the type.
- A set of generic functions are used to transform some message-like
  database object into an IRC message to be sent down the wire.
master
eta 2 years ago
parent
commit
2fdc75c3e5
  1. 68
      ircd-db.lisp
  2. 11
      ircd-groupchats.lisp
  3. 110
      ircd-messages.lisp
  4. 4
      ircd-registration.lisp
  5. 2
      ircd-types.lisp
  6. 36
      ircd.lisp
  7. 2
      nea.asd
  8. 11
      schema.sql

68
ircd-db.lisp

@ -4,7 +4,7 @@
(defparameter *local-server-id* 1
"Server ID of the local server.")
(defvar *default-database-args* '("nea" "eeeeeta" "" "localhost")
(defparameter *default-database-args* '("nea" "eeeeeta" "" "localhost")
"Default arguments to pass to POSTMODERN:CONNECT.")
(defmacro execute-one (&rest args)
@ -15,57 +15,79 @@
(cl-postgres-plus-uuid:set-uuid-sql-reader)
(defclass message ()
(defclass db-system-message ()
((msgid :col-type uuid
:initarg :msgid
:reader message-msgid)
:reader dbm-msgid)
(seq :col-type int
:col-default (:nextval messages_sequence)
:initarg :seq
:reader message-seq)
:reader dbm-seq)
(type :col-type int
:initarg :type
:reader dbm-type)
(user-ref :col-type int
:col-name user_ref
:initarg :user-ref
:reader dbm-user-ref)
(target-user-ref :col-type int
:col-name target_user_ref
:initarg :target-user-ref
:reader dbm-target-user-ref)
(groupchat-ref :col-type uuid
:col-name groupchat_ref
:initarg :groupchat-ref
:reader dbm-groupchat-ref)
(body :col-type varchar
:initarg :body
:reader dbm-body)
(local-ts :col-type timestamp
:col-name local_ts
:initarg :local-ts
:initform (simple-date:universal-time-to-timestamp (get-universal-time))
:reader dbm-local-ts))
(:metaclass pomo:dao-class)
(:table-name system_messages))
(defclass db-message ()
((msgid :col-type uuid
:initarg :msgid
:reader dbm-msgid)
(seq :col-type int
:col-default (:nextval messages_sequence)
:initarg :seq
:reader dbm-seq)
(user-from :col-type int
:col-name user_from
:initarg :user-from
:reader message-user-from)
:reader dbm-user-from)
(user-to :col-type int
:col-name user_to
:initarg :user-to
:reader message-user-to)
:reader dbm-user-to)
(groupchat-to :col-type int
:col-name groupchat_to
:initarg :groupchat-to
:reader message-groupchat-to)
:reader dbm-groupchat-to)
(tags :col-type varchar
:initarg :tags
:reader message-tags)
:reader dbm-tags)
(body :col-type varchar
:initarg :body
:reader message-body)
:reader dbm-body)
(origin-ts :col-type timestamp
:col-name origin_ts
:initarg :origin-ts
:initform (simple-date:universal-time-to-timestamp (get-universal-time))
:reader message-origin-ts)
:reader dbm-origin-ts)
(local-ts :col-type timestamp
:col-name local_ts
:initarg :local-ts
:initform (simple-date:universal-time-to-timestamp (get-universal-time))
:reader message-local-ts))
:reader dbm-local-ts))
(:metaclass pomo:dao-class)
(:table-name messages))
(defun insert-message (uid-from uid-to tags body)
"Insert a message into the database, addressed to the user with ID UID-TO and containing TAGS (an alist of message tags) and BODY as text.
Returns the inserted message object."
(let* ((tags (irc:serialize-tags-to-string tags))
(message (make-instance 'message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:user-from uid-from
:user-to uid-to
:tags tags
:body body)))
(pomo:insert-dao message)))
(defun initialize-database (&optional (args *default-database-args*))
"Connect to the PostgreSQL database."
(apply #'postmodern:connect-toplevel args))

11
ircd-groupchats.lisp

@ -1,9 +1,9 @@
(in-package :nea/ircd)
(defparameter *capabilities*
(defparameter *groupchat-capabilities*
'(:send-message :change-roles :change-subject :invite-user
:change-invite-only :remove-user)
"List of defined capabilities in this implementation.")
"List of defined groupchat capabilities in this implementation.")
(defparameter *standard-roles*
'((:operator . (:*))
@ -134,6 +134,13 @@ Will add the *STANDARD-ROLES* to the newly created groupchat, and add this serve
(setf ret (acons username role-name ret)))
ret))
(defun get-groupchat-directory-name (gcid)
"Returns the directory entry name for the groupchat with ID GCID, or NIL if it doesn't exist."
(pomo:query (:select 'name
:from 'groupchat_directory_entries
:where (:= 'uuid '$1))
(format nil "~A" gcid) :single))
(defun get-or-make-groupchat-by-directory-name (name)
"Retrieves or creates a groupchat with server-local directory name #NAME, returning its groupchat ID.
Rather like joining a channel in IRC, asking for a NAME that doesn't exist results in a new groupchat being created, and a directory entry being added for it.

110
ircd-messages.lisp

@ -0,0 +1,110 @@
(in-package :nea/ircd)
(define-symbol-macro systype-join 1)
(define-symbol-macro systype-part 2)
;; CLOS doesn't let us subclass things that have POMO:DAO-CLASS as their
;; metaclass -- presumably because that doesn't make much sense, as such
;; objects couldn't really be used as database access objects.
;; However, we don't care about using the objects as DAOs -- we just want to
;; inherit the slots -- so we override this behaviour.
(defmethod closer-mop:validate-superclass ((class standard-class) (superclass pomo:dao-class))
t)
(defclass db-join-message (db-system-message) ())
(defclass db-part-message (db-system-message) ())
(defgeneric db-message-command (msg)
(:documentation "Gets the IRC message command (a string) for the given MSG object (which is either a MESSAGE or a SYSTEM-MESSAGE)."))
(defgeneric db-message-source (msg)
(:documentation "Gets the IRC message source (an IRC-MESSAGE-SOURCE object) for the given MSG object (which can be either a MESSAGE or a SYSTEM-MESSAGE)."))
(defgeneric db-message-parameters (msg client)
(:documentation "Gets the list of IRC message parameters for MSG, assuming it's being delivered to the provided CLIENT."))
(defgeneric db-message-tags (msg client)
(:documentation "Gets the IRC message tags (as an alist) for the given MSG object, assuming it's being delivered to the provided CLIENT."))
(defmethod db-message-source ((m db-message))
(get-user-source (dbm-user-from m)))
(defmethod db-message-source ((m db-join-message))
(get-user-source (dbm-user-ref m)))
(defmethod db-message-source ((m db-part-message))
(get-user-source (dbm-user-ref m)))
(defmethod db-message-command ((m db-join-message))
(declare (ignore m)) "JOIN")
(defmethod db-message-command ((m db-part-message))
(declare (ignore m)) "PART")
(defmethod db-message-command ((m db-message))
(if (dbm-body m) "PRIVMSG" "TAGMSG"))
(defmethod db-message-parameters ((m db-message) client)
(let ((body (dbm-body m))
(ts (simple-date->local-time (dbm-local-ts m))))
(if body
(progn
(unless (client-supports-capability-p client :server-time)
(let ((human-time-prefix (timestamp-to-human-time-prefix ts)))
(when human-time-prefix
(setf body (format nil "[~A] ~A" human-time-prefix body)))))
`(,(client-username client) ,body))
`(,(client-username client)))))
(defmethod db-message-parameters ((m db-join-message) client)
(let ((gcname (get-groupchat-directory-name (dbm-groupchat-ref m))))
(assert gcname () "DB-JOIN-MESSAGE has a groupchat with no directory entry")
`(,gcname)))
(defmethod db-message-parameters ((m db-part-message) client)
(let ((gcname (get-groupchat-directory-name (dbm-groupchat-ref m)))
(body (dbm-body m)))
(assert gcname () "DB-PART-MESSAGE has a groupchat with no directory entry")
(if body
`(,gcname ,body)
`(,gcname))))
(defmethod db-message-tags ((message db-message) client)
(let ((tags (when (client-supports-capability-p client :message-tags)
(irc:parse-tags nil (dbm-tags message))))
(ts (simple-date->local-time (dbm-local-ts message))))
(if (client-supports-capability-p client :server-time)
(acons "time" (timestamp-to-v3-server-time ts) tags)
tags)))
(defmethod db-message-tags ((obj db-system-message) client)
(declare (ignore obj client))
nil)
(defun parse-db-system-message (syst)
"Validates the DB-SYSTEM-MESSAGE in SYST, changing its class and returning it if validation succeeds. If validation fails, signals an error."
(let ((type (dbm-type syst)))
(ecase type
(systype-join
(assert (and (dbm-user-ref syst) (dbm-groupchat-ref syst)) ()
"Invalid SYSTYPE-JOIN system message")
(change-class syst 'db-join-message)
syst)
(systype-part
(assert (and (dbm-user-ref syst) (dbm-groupchat-ref syst)) ()
"Invalid SYSTYPE-PART system message")
(change-class syst 'db-part-message)
syst))))
(defun insert-db-message (uid-from uid-to tags body)
"Insert a message into the database, addressed to the user with ID UID-TO and containing TAGS (an alist of message tags) and BODY as text.
Returns the inserted message object."
(let* ((tags (irc:serialize-tags-to-string tags))
(message (make-instance 'db-message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:user-from uid-from
:user-to uid-to
:tags tags
:body body)))
(pomo:insert-dao message)))

4
ircd-registration.lisp

@ -5,7 +5,7 @@
(defgeneric handle-registration-message (client msg))
(defun get-capabilities ()
(join-by-spaces *capabilities*))
(join-by-spaces *v3-capabilities*))
;; Fallback
@ -73,7 +73,7 @@
(let ((requested-capabs (uiop:split-string (elt (message-parameters msg) 1) :separator " "))
(accepted-capabs) (rejected-capabs))
(dolist (capab requested-capabs)
(if (member capab *capabilities* :test #'equal)
(if (member capab *v3-capabilities* :test #'equal)
(push capab accepted-capabs)
(push capab rejected-capabs)))
(dolist (capab accepted-capabs)

2
ircd-types.lisp

@ -6,7 +6,7 @@
"Port to listen for connections on.")
(defparameter *server-name* "nea-ircd"
"IRCd server name.")
(defparameter *capabilities* '("server-time" "sasl" "message-tags")
(defparameter *v3-capabilities* '("server-time" "sasl" "message-tags")
"IRCv3 capabilities supported by this IRCd.")
(defparameter *irc-numerics*
'((err-notregistered "451" "You have not registered")

36
ircd.lisp

@ -114,7 +114,7 @@
(tags (filter-client-tags (message-tags msg))))
(unless target
(raise-user-error 'err-nosuchnick))
(insert-message (client-userid c) target tags (car (last params)))
(insert-db-message (client-userid c) target tags (car (last params)))
(pomo:execute "NOTIFY \"ircd-messages\";"))))
(defun irc-client-thread (client)
@ -165,27 +165,13 @@
(defun deliver-message-to-client (message client)
"Delivers MESSAGE (a message from the database) to CLIENT."
(let ((tags (when (client-supports-capability-p client :message-tags)
(irc:parse-tags nil (message-tags message))))
(ts (simple-date->local-time (message-local-ts message)))
(source (get-user-source (message-user-from message)))
(text (message-body message)))
(if (client-supports-capability-p client :server-time)
(setf tags (acons "time" (timestamp-to-v3-server-time ts) tags))
(let ((human-time-prefix (timestamp-to-human-time-prefix ts)))
(when human-time-prefix
(setf text (format nil "[~A] ~A" human-time-prefix text)))))
(unless (or text tags)
(warn "Dropped message ~A for client ~A/~A: no text or tags (or message-tags unsupported)"
(message-msgid message) (client-userid client) (client-deviceid client))
(return-from deliver-message-to-client nil))
(write-irc-message
(make-irc-message
(if (not text) "TAGMSG" "PRIVMSG")
:tags tags
:source source
:params `(,(client-username client) ,text))
client)))
(write-irc-message
(make-irc-message
(db-message-command message)
:tags (db-message-tags message client)
:source (db-message-source message)
:params (db-message-parameters message client))
client))
(defun message-delivery-thread ()
"Thread entry point for the message delivery thread.
@ -203,11 +189,11 @@ When they arrive, it delivers them to connected clients."
(:= 'lud.id '$2)
(:= 'm.user_to '$1)
(:< 'lud.highest_seq 'm.seq)))
uid devid (:dao message)))
uid devid (:dao db-message)))
(seq (loop
for msg in messages
do (deliver-message-to-client msg client)
maximizing (message-seq msg) into seq
maximizing (dbm-seq msg) into seq
finally (return seq))))
(unless (null messages)
(flush-client client)
@ -224,7 +210,7 @@ When they arrive, it delivers them to connected clients."
(format t "Starting message delivery thread...~%")
(when *message-delivery-thread*
(format t "(Destroying old thread!)~%")
(destroy-thread *message-delivery-thread*))
(ignore-errors (destroy-thread *message-delivery-thread*)))
(setf *message-delivery-thread*
(make-thread (lambda ()
(pomo:with-connection *default-database-args*

2
nea.asd

@ -2,7 +2,7 @@
:depends-on ("usocket" "bordeaux-threads" "uiop" "cl-ppcre" "qbase64"
"babel" "postmodern" "ironclad" "cl-postgres-plus-uuid"
"simple-date" "simple-date/postgres-glue"
"local-time")
"local-time" "closer-mop")
:serial t
:components
((:file "packages")

11
schema.sql

@ -80,4 +80,15 @@ CREATE TABLE messages (
local_ts TIMESTAMP NOT NULL
);
CREATE TABLE system_messages (
msgid UUID PRIMARY KEY,
seq INT NOT NULL DEFAULT nextval('messages_sequence'),
type INT NOT NULL,
user_ref INT REFERENCES users,
target_user_ref INT REFERENCES users,
groupchat_ref UUID REFERENCES groupchats,
body VARCHAR,
local_ts TIMESTAMP NOT NULL
);
CREATE INDEX messages_user_to ON messages (user_to);
Loading…
Cancel
Save