Browse Source

Add a bunch of IRC commands, and topic changing

- NAMES, TOPIC, and MODE are now all supported (in their query form).
- You can also actually change the topic now, if you have the rights.
- Sending NOTICEs is also supported.
master
eta 2 years ago
parent
commit
83bdd09b9a
  1. 13
      irc-messages.lisp
  2. 7
      ircd-db.lisp
  3. 9
      ircd-groupchats.lisp
  4. 44
      ircd-messages.lisp
  5. 2
      ircd-types.lisp
  6. 116
      ircd.lisp
  7. 3
      schema.sql

13
irc-messages.lisp

@ -21,7 +21,8 @@
(define-irc-message-classes (:cap-ls :cap-req :cap-ack :cap-nak :cap-end
:nick :quit :user :error :numeric
:authenticate :privmsg :ping :pong :pass :join
:part))
:part :topic-query :topic-set :mode-query
:mode-set :names :list :notice))
(defclass msg-authenticate (irc-message-notrailing) ())
@ -47,11 +48,21 @@
((equal cmd "NICK") (error 'invalid-arguments :command "NICK"))
((and (equal cmd "PRIVMSG") (eql (length params) 2)) 'msg-privmsg)
((equal cmd "PRIVMSG") (error 'invalid-arguments :command "PRIVMSG"))
((and (equal cmd "NOTICE") (eql (length params) 2)) 'msg-notice)
((equal cmd "NOTICE") (error 'invalid-arguments :command "NOTICE"))
((and (equal cmd "JOIN") (eql (length params) 1)) 'msg-join)
((equal cmd "JOIN") (error 'invalid-arguments :command "JOIN"))
((and (equal cmd "PART") (>= (length params) 1)) 'msg-part)
((equal cmd "PART") (error 'invalid-arguments :command "PART"))
((and (equal cmd "TOPIC") (eql (length params) 1)) 'msg-topic-query)
((and (equal cmd "TOPIC") (eql (length params) 2)) 'msg-topic-set)
((equal cmd "TOPIC") (error 'invalid-arguments :command "TOPIC"))
((and (equal cmd "MODE") (eql (length params) 1)) 'msg-mode-query)
((and (equal cmd "MODE") (>= (length params) 2)) 'msg-mode-set)
((equal cmd "MODE") (error 'invalid-arguments :command "MODE"))
((equal cmd "QUIT") 'msg-quit)
((equal cmd "NAMES") 'msg-names)
((equal cmd "LIST") 'msg-list)
((and (equal cmd "USER") (eql (length params) 4)) 'msg-user)
((equal cmd "USER") (error 'invalid-arguments :command "USER"))
((and (equal cmd "AUTHENTICATE") (eql (length params) 1)) 'msg-authenticate)

7
ircd-db.lisp

@ -84,7 +84,12 @@
:col-name local_ts
:initarg :local-ts
:initform (simple-date:universal-time-to-timestamp (get-universal-time))
:reader dbm-local-ts))
:reader dbm-local-ts)
(is-notice :col-type boolean
:col-name is_notice
:initarg :is-notice
:initform nil
:reader dbm-is-notice))
(:metaclass pomo:dao-class)
(:table-name messages))

9
ircd-groupchats.lisp

@ -123,7 +123,7 @@ Will add the *STANDARD-ROLES* to the newly created groupchat, and add this serve
(:or
(:= 'gcrc.capability '$3)
(:= 'gcrc.capability "*"))))
(format nil "~A" gcid) uid cap :single!)
(format nil "~A" gcid) uid (thing-to-string cap) :single!)
0))
(defun get-groupchat-by-directory-name (name)
@ -176,6 +176,13 @@ Will add the *STANDARD-ROLES* to the newly created groupchat, and add this serve
:where (:= 'uuid '$1))
(format nil "~A" gcid) :single))
(defun update-groupchat-subject (gcid subject)
"Sets the subject for the groupchat with ID GCID to SUBJECT."
(execute-one (:update 'groupchats
:set 'subject '$1
:where (:= 'uuid '$2))
subject (format nil "~A" gcid)))
(defun get-groupchat-name (gcid)
"Returns the client groupchat name for the groupchat with ID GCID."
(let ((dirname (get-groupchat-directory-name gcid)))

44
ircd-messages.lisp

@ -2,6 +2,7 @@
(define-symbol-macro systype-join 1)
(define-symbol-macro systype-part 2)
(define-symbol-macro systype-topic 3)
;; 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
@ -13,6 +14,7 @@
(defclass db-join-message (db-system-message) ())
(defclass db-part-message (db-system-message) ())
(defclass db-topic-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)."))
@ -53,14 +55,22 @@
(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-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-message))
(if (dbm-body m) "PRIVMSG" "TAGMSG"))
(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))
@ -89,6 +99,12 @@
`(,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-tags ((message db-message) client)
(let ((tags (when (client-supports-capability-p client :message-tags)
(irc:parse-tags nil (dbm-tags message))))
@ -98,8 +114,10 @@
tags)))
(defmethod db-message-tags ((obj db-system-message) client)
(declare (ignore obj client))
nil)
(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."
@ -115,11 +133,17 @@
"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)
(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
@ -140,7 +164,18 @@ Returns the inserted message object."
(slot-makunbound message 'body))
(pomo:insert-dao message)))
(defun insert-db-message (uid-from tags body &key uid-to gcid-to)
(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))
@ -148,6 +183,7 @@ Returns the inserted message object."
: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)))

2
ircd-types.lisp

@ -23,6 +23,8 @@
(rpl-endofnames "366")
(err-nosuchchannel "403")
(err-cannotsendtochan "404")
(rpl-channelmodeis "324")
(err-chanoprivsneeded "482" "You don't have sufficient permissions to do that.")
(err-notonchannel "442" "You're not in that channel")
(err-nicklocked "902")
(rpl-saslsuccess "903")

116
ircd.lisp

@ -80,26 +80,22 @@ Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
(make-client-source client))
client)))
(defun send-groupchat-join (gcid client)
"Sends the reply to a JOIN command (i.e. JOIN, RPL_NAMREPLY, RPL_TOPIC, etc.) for the groupchat with ID GCID to CLIENT."
(defun send-topic (gcid client)
"Sends the reply to a TOPIC command (i.e. either RPL_TOPIC or RPL_NOTOPIC) for the groupchat with ID GCID to CLIENT."
(let ((dirname (get-groupchat-name gcid))
(names (get-groupchat-names gcid))
(subject (get-groupchat-subject gcid)))
(write-irc-message
(with-irc-source
(make-irc-message
"JOIN"
:params `(,dirname))
(make-client-source client)
)
client)
(server-to-user
client
(if (and subject (not (u:string-empty-p subject)))
(make-irc-message (find-numeric 'rpl-topic)
:params `(,dirname ,subject))
(make-irc-message (find-numeric 'rpl-notopic)
:params `(,dirname "No topic is set"))))
:params `(,dirname "No topic is set"))))))
(defun send-names (gcid client)
"Sends the reply to a NAMES command (i.e. RPL_NAMREPLY etc.) for the groupchat with ID GCID to CLIENT."
(let ((dirname (get-groupchat-name gcid))
(names (get-groupchat-names gcid)))
(loop
for names-batch in (format-names names)
do (server-to-user
@ -113,6 +109,20 @@ Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
(find-numeric 'rpl-endofnames)
:params `(,dirname "End of /NAMES list."))))))
(defun send-groupchat-join (gcid client)
"Sends the reply to a JOIN command (i.e. JOIN, RPL_NAMREPLY, RPL_TOPIC, etc.) for the groupchat with ID GCID to CLIENT."
(let ((dirname (get-groupchat-name gcid)))
(write-irc-message
(with-irc-source
(make-irc-message
"JOIN"
:params `(,dirname))
(make-client-source client)
)
client)
(send-topic gcid client)
(send-names gcid client)))
(defun send-client-groupchats (client)
"Lets CLIENT, a newly registered client, know what groupchats they're in, by sending JOIN responses for each of those groupchats."
(loop
@ -183,7 +193,7 @@ Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
(starts-with #\+ (car tag))))
(remove-if (complement #'is-client-only) tags)))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-privmsg))
(defun privmsg-or-notice-inner (c msg is-notice)
(with-accessors ((params message-parameters)) msg
(let ((target (first params))
(tags (filter-client-tags (message-tags msg))))
@ -193,25 +203,49 @@ Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
(raise-user-error-with-text 'err-nosuchchannel "Channel does not exist"))
(unless (groupchat-member-p gcid (client-userid c))
(raise-user-error-with-text 'err-cannotsendtochan "You're not in that groupchat"))
(insert-db-message (client-userid c) tags (car (last params)) :gcid-to gcid))
(insert-db-message (client-userid c) tags (car (last params))
:gcid-to gcid
:is-notice is-notice))
(progn
(let ((target (query-user-target target)))
(unless target
(raise-user-error 'err-nosuchnick))
(insert-db-message (client-userid c) tags (car (last params)) :uid-to target))))
(insert-db-message (client-userid c) tags (car (last params))
:uid-to target
:is-notice is-notice))))
(notify-new-messages))))
(defun get-groupchat-target (name)
"Takes NAME, a groupchat target (e.g. #CHANNELNAME), and returns a groupchat ID for that target. Throws an error if the target is invalid."
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-privmsg))
(privmsg-or-notice-inner c msg nil))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-notice))
(privmsg-or-notice-inner c msg t))
(defun get-or-make-groupchat-target (name)
"Takes NAME, a groupchat target (e.g. #CHANNELNAME), and returns a groupchat ID for that target, creating a new groupchat if one doesn't exist. Throws an error if the target is invalid."
(unless (scan *channel-regex* name)
(raise-user-error-with-text 'err-nosuchchannel "Channel name is invalid"))
(get-or-make-groupchat-by-directory-name (subseq name 1)))
(defun get-groupchat-target (name)
"Takes NAME, a groupchat target (e.g. #CHANNELNAME), and returns a groupchat ID for that target. Throws an error if the target is invalid, or the groupchat doesn't exist."
(unless (scan *channel-regex* name)
(raise-user-error-with-text 'err-nosuchchannel "Channel name is invalid"))
(let ((gcid (get-groupchat-by-directory-name (subseq name 1))))
(unless gcid
(raise-user-error-with-text 'err-nosuchchannel "Channel does not exist"))
gcid))
(defun check-groupchat-member (gcid uid)
"Checks that the user with ID UID is in the groupchat with ID GCID, and raises the ERR_NOTONCHANNEL usre error if not."
(unless (groupchat-member-p gcid uid)
(raise-user-error 'err-notonchannel)))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-join))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(multiple-value-bind (gcid newly-created-p)
(get-groupchat-target (first params))
(get-or-make-groupchat-target (first params))
(pomo:with-logical-transaction ()
(when (groupchat-member-p gcid uid)
;; Do nothing
@ -222,23 +256,55 @@ Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
(send-groupchat-join gcid c)
(notify-new-messages))))))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-part))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(unless (scan *channel-regex* (first params))
(raise-user-error-with-text 'err-nosuchchannel "Channel name is invalid"))
(pomo:with-logical-transaction ()
(let ((gcid (get-groupchat-by-directory-name (subseq (first params) 1)))
(let ((gcid (get-groupchat-target (first params)))
(body (when (> (length params) 1) (car (last params)))))
(unless gcid
(raise-user-error-with-text 'err-nosuchchannel "Channel does not exist"))
(unless (groupchat-member-p gcid uid)
(raise-user-error 'err-notonchannel))
(insert-db-part-message uid gcid body)
(delete-groupchat-membership gcid uid)
(send-groupchat-part gcid c body)
(notify-new-messages))))))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-mode-query))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(let ((gcid (get-groupchat-target (first params))))
(check-groupchat-member gcid uid)
(server-to-user c
(make-irc-message
(find-numeric 'rpl-channelmodeis)
:params `(,(first params) "+nt")))))))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-topic-query))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(let ((gcid (get-groupchat-target (first params))))
(check-groupchat-member gcid uid)
(send-topic gcid c)))))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-topic-set))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(pomo:with-logical-transaction ()
(let ((gcid (get-groupchat-target (first params)))
(new-topic (car (last params))))
(check-groupchat-member gcid uid)
(unless (check-groupchat-capability gcid uid :change-subject)
(raise-user-error 'err-chanoprivsneeded (get-groupchat-name gcid)))
(update-groupchat-subject gcid new-topic)
(insert-db-topic-message uid gcid new-topic)
(notify-new-messages))))))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-names))
(with-accessors ((params message-parameters)) msg
(with-accessors ((uid client-userid)) c
(let ((gcid (get-groupchat-target (first params))))
(check-groupchat-member gcid uid)
(send-names gcid c)))))
(defun irc-client-thread (client)
(format t "New client, address ~A~%" (slot-value client 'address))
(handler-case

3
schema.sql

@ -77,7 +77,8 @@ CREATE TABLE messages (
tags VARCHAR NOT NULL DEFAULT '',
body VARCHAR NOT NULL DEFAULT '',
origin_ts TIMESTAMP NOT NULL,
local_ts TIMESTAMP NOT NULL
local_ts TIMESTAMP NOT NULL,
is_notice BOOLEAN NOT NULL DEFAULT false,
);
CREATE TABLE system_messages (

Loading…
Cancel
Save