You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

230 lines
10 KiB

(in-package :nea/ircd)
(define-symbol-macro systype-join 1)
(define-symbol-macro systype-part 2)
(define-symbol-macro systype-topic 3)
(define-symbol-macro systype-mode 4)
;; 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) ())
(defclass db-topic-message (db-system-message) ())
(defclass db-mode-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."))
(defgeneric db-message-should-send-to (msg client)
(:documentation "Returns a generalized boolean, specifying whether MSG should be sent to CLIENT or not."))
(defmethod db-message-should-send-to (msg client)
(declare (ignore msg client))
;; The answer's probably T
t)
(defmethod db-message-should-send-to ((m db-join-message) client)
(not (eql (client-userid client) (dbm-user-ref m))))
(defmethod db-message-should-send-to ((m db-part-message) client)
(not (eql (client-userid client) (dbm-user-ref m))))
(defmethod db-message-should-send-to ((m db-message) client)
(or (eql (dbm-groupchat-to m) :null)
(not (eql (dbm-user-from m) (client-userid 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-source ((m db-topic-message))
(get-user-source (dbm-user-ref m)))
(defmethod db-message-source ((m db-mode-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-topic-message))
(declare (ignore m)) "TOPIC")
(defmethod db-message-command ((m db-mode-message))
(declare (ignore m)) "MODE")
(defmethod db-message-command ((m db-message))
(if (dbm-body m)
(if (dbm-is-notice m) "NOTICE" "PRIVMSG")
"TAGMSG"))
(defmethod db-message-parameters ((m db-message) client)
(let* ((body (dbm-body m))
(ts (simple-date->local-time (dbm-local-ts m)))
(gcto (dbm-groupchat-to m))
(target (if (eql gcto :null) (client-username client) (get-groupchat-name gcto))))
(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)))))
`(,target ,body))
`(,target))))
(defmethod db-message-parameters ((m db-join-message) client)
(let ((gcname (get-groupchat-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-name (dbm-groupchat-ref m)))
(body (dbm-body m)))
(assert gcname () "DB-PART-MESSAGE has a groupchat with no directory entry")
(if (eql body :null)
`(,gcname)
`(,gcname ,body))))
(defmethod db-message-parameters ((m db-topic-message) client)
(let ((gcname (get-groupchat-name (dbm-groupchat-ref m)))
(body (dbm-body m)))
(assert gcname () "DB-TOPIC-MESSAGE has a groupchat with no directory entry")
`(,gcname ,body)))
(defmethod db-message-parameters ((m db-mode-message) client)
(let ((gcname (get-groupchat-name (dbm-groupchat-ref m)))
(target-nick (message-source-nick (get-user-source (dbm-target-user-ref m))))
(body (dbm-body m)))
(assert gcname () "DB-MODE-MESSAGE has a groupchat with no directory entry")
`(,gcname ,body ,target-nick)))
(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)
(let ((ts (simple-date->local-time (dbm-local-ts obj))))
(if (client-supports-capability-p client :server-time)
(acons "time" (timestamp-to-v3-server-time ts) nil)
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)))
(cond
((eql 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)
((eql type systype-part)
(assert (and (dbm-user-ref syst) (dbm-groupchat-ref syst)) ()
"Invalid SYSTYPE-PART system message")
(change-class syst 'db-part-message)
syst)
((eql type systype-topic)
(assert (and (dbm-user-ref syst) (dbm-groupchat-ref syst) (dbm-body syst)) ()
"Invalid SYSTYPE-TOPIC system message")
(change-class syst 'db-topic-message)
syst)
((eql type systype-mode)
(assert (and (dbm-user-ref syst) (dbm-groupchat-ref syst) (dbm-body syst) (dbm-target-user-ref syst)) ()
"Invalid SYSTYPE-TOPIC system message")
(change-class syst 'db-mode-message)
syst)
(t (error "Invalid system message type ~A" type)))))
(defun insert-db-join-message (uid gcid)
"Insert a JOIN message into the database, describing how the user with ID UID has just joined the groupchat with ID GCID.
Returns the inserted message object."
(declare (type uuid:uuid gcid) (type integer uid))
(let ((message (make-instance 'db-system-message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:type systype-join
:user-ref uid
:groupchat-ref (format nil "~A" gcid))))
(pomo:insert-dao message)))
(defun insert-db-mode-message (uid gcid mode-changes target-uid)
"Insert a MODE message into the database, describing how the user with ID UID has executed MODE-CHANGES on the user with ID TARGET-UID.
Returns the inserted message object."
(let ((message (make-instance 'db-system-message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:type systype-mode
:body mode-changes
:user-ref uid
:target-user-ref target-uid
:groupchat-ref (format nil "~A" gcid))))
(pomo:insert-dao message)))
(defun insert-db-part-message (uid gcid body)
"Insert a PART message into the database, describing how the user with ID UID has just left the groupchat with ID GCID.
Returns the inserted message object."
(let ((message (make-instance 'db-system-message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:type systype-part
:body body
:user-ref uid
:groupchat-ref (format nil "~A" gcid))))
(unless body
(slot-makunbound message 'body))
(pomo:insert-dao message)))
(defun insert-db-topic-message (uid gcid topic)
"Insert a TOPIC message into the database, describing how the user with ID UID has just changed the topic in the groupchat with ID GCID to TOPIC.
Returns the inserted message object."
(let ((message (make-instance 'db-system-message
:msgid (format nil "~A" (uuid:make-v4-uuid))
:type systype-topic
:body topic
:user-ref uid
:groupchat-ref (format nil "~A" gcid))))
(pomo:insert-dao message)))
(defun insert-db-message (uid-from tags body &key uid-to gcid-to is-notice)
"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
:is-notice is-notice
:groupchat-to (when gcid-to (format nil "~A" gcid-to))
:tags tags
:body body)))
;; This is kinda hacky.
;; Postmodern translates NIL to false, not NULL, so we need to make slots unbound
;; if they're supposed to be NULL.
(unless uid-to
(slot-makunbound message 'user-to))
(unless gcid-to
(slot-makunbound message 'groupchat-to))
(pomo:insert-dao message)))