Browse Source

Add PRIVMSG support and actually insert messages!

- You can now actually send messages back and forth. Huzzah!
- Message tags are now represented with actual alists instead
  of "I've only used lisp for 3 days" alists.
- We now make more of an effort to remove clients from the
  *CLIENTS* hashtable if the thread dies for some reason.
master
eta 2 years ago
parent
commit
5b8ed2dad9
  1. 19
      irc-parser.lisp
  2. 57
      ircd-db.lisp
  3. 5
      ircd-types.lisp
  4. 23
      ircd.lisp
  5. 1
      packages.lisp

19
irc-parser.lisp

@ -43,8 +43,8 @@
(multiple-value-bind (key value)
(split-string-at-first tag #\= t)
(if (string-empty-p value)
(list key)
(list key (parse-tag-value
(cons key nil)
(cons key (parse-tag-value
(make-array (length value)
:element-type 'character
:fill-pointer 0
@ -135,13 +135,11 @@
(defun serialize-tags (tags out)
(when tags
(write-char #\@ out)
(dolist (tagpair tags)
(serialize-tag-value (car tagpair) out)
(when (cdr tagpair)
(write-char #\= out)
(serialize-tag-value (cdr tagpair) out)))
(write-char #\Space out)))
(serialize-tag-value (cdr tagpair) out)))))
(defgeneric irc-message-serialize-end (src out))
@ -157,9 +155,18 @@
(assert (<= (length args) 1) () "Invalid number of arguments for a NOTRAILING IRC message class.")
(serialize-args args out)))
(defun serialize-tags-to-string (tags)
"Serializes TAGS (an alist of message tags) to a string, returning this string."
(let ((out (make-string-output-stream)))
(serialize-tags tags out)
(get-output-stream-string out)))
(defun irc-message-serialize (src out)
(with-slots ((tags tags) (source source) (command command) (args parameters)) src
(serialize-tags tags out)
(when tags
(write-char #\@ out)
(serialize-tags tags out)
(write-char #\Space out))
(serialize-source source out)
(write-sequence command out)
(when (> (length args) 0)

57
ircd-db.lisp

@ -13,6 +13,8 @@
(let ((rows-modified (pomo:execute ,@args)))
(assert (eql rows-modified 1) () "Modified ~A rows in an EXECUTE-ONE command" rows-modified))))
(cl-postgres-plus-uuid:set-uuid-sql-reader)
(defclass message ()
((msgid :col-type uuid
:initarg :msgid
@ -42,12 +44,15 @@
(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)
(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))
(:metaclass pomo:dao-class))
(:metaclass pomo:dao-class)
(:table-name messages))
(defparameter *ircv3-server-time-format*
`((:year 4) #\- (:month 2) #\- (:day 2) #\T (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:msec 3) #\Z)
@ -164,6 +169,56 @@ If they authenticate successfully, returns the user ID; if they don't, returns N
:user username))
(error "No user has UID ~A." uid))))
(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 query-user-target (target)
"Convert a possible TARGET expression to a user ID.
TARGET can be formatted like:
- user@domain.name (searches for `user' on server `domain.name')
- user|hex-id (where hex-id is a hexidecimal number representing a server's internal server ID; searches for `user' on that server)
- just an ordinary nickname (searches for that nickname on the local server)"
(multiple-value-bind (nick-part host-part)
(split-string-at-first target #\@ t t)
(if (string-empty-p host-part)
(multiple-value-bind (nick-part id-part)
(split-string-at-first target #\| t t)
(let ((id (parse-integer id-part
:radix 16
:junk-allowed t)))
(if id
(pomo:query
(:select 'users.id
:from 'users 'servers
:where (:and
(:= 'servers.id '$1)
(:= 'users.username '$2)))
id nick-part :single)
(pomo:query
(:select 'id
:from :users
:where (:and
(:= 'server '$1)
(:= 'username '$2)))
*local-server-id* target :single))))
(pomo:query
(:select 'users.id
:from 'users 'servers
:where (:and
(:= 'servers.id 'users.server)
(:= 'servers.domain '$1)
(:= 'users.username '$2)))
host-part nick-part :single))))
(defun initialize-database (&optional (args *default-database-args*))
"Connect to the PostgreSQL database."
(apply #'postmodern:connect-toplevel args))

5
ircd-types.lisp

@ -97,7 +97,10 @@
(deviceid
:initarg :deviceid
:initform nil
:accessor client-deviceid)))
:accessor client-deviceid)
(has-quit
:initform nil
:accessor client-has-quit)))
(defclass unregistered-irc-client (irc-client) ())
(defclass registered-irc-client (irc-client) ())

23
ircd.lisp

@ -78,7 +78,8 @@
:params (cons (or reason "Closing link after QUIT") nil)))
(socket-close (slot-value c 'socket)))
(when (typep c (find-class 'registered-irc-client))
(remove-client c)))
(remove-client c))
(setf (client-has-quit c) t))
(defmethod handle-quit ((c irc-client) reason) ())
@ -101,6 +102,21 @@
(when (client-can-register c)
(graduate-client c)))
(defun filter-client-tags (tags)
"Filters TAGS, a set of IRCv3 tags, to contain only tags prefixed with + (which are client-only)."
(flet ((is-client-only (tag)
(starts-with #\+ (car tag))))
(remove-if (complement #'is-client-only) tags)))
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-privmsg))
(with-accessors ((params message-parameters)) msg
(let ((target (query-user-target (first params)))
(tags (filter-client-tags (message-tags msg))))
(unless target
(raise-user-error 'err-nosuchnick))
(insert-message (client-userid c) target tags (car (last params)))
(pomo:execute "NOTIFY \"ircd-messages\";"))))
(defun irc-client-thread (client)
(format t "New client, address ~A~%" (slot-value client 'address))
(handler-case
@ -129,7 +145,10 @@
(make-thread
(lambda ()
(pomo:with-connection *default-database-args*
(irc-client-thread client))))
(unwind-protect
(irc-client-thread client)
(unless (client-has-quit client)
(handle-quit client "Thread terminated unexpectedly"))))))
:name "ircd client thread"))
(ignore-errors (socket-close master-socket)))))

1
packages.lisp

@ -23,6 +23,7 @@
:make-irc-message
:make-irc-message-source
:serialize-irc-message-source
:serialize-tags-to-string
:with-irc-source
:to-irc-message-source
:irc-message-serialize

Loading…
Cancel
Save