diff options
Diffstat (limited to 'plugins.lisp')
| -rw-r--r-- | plugins.lisp | 247 |
1 files changed, 247 insertions, 0 deletions
diff --git a/plugins.lisp b/plugins.lisp new file mode 100644 index 0000000..d9834ad --- /dev/null +++ b/plugins.lisp @@ -0,0 +1,247 @@ +;;;; Common utilities to help in building bots + +(in-package :granolin) + +;;; Logging Bot + +(defclass message-log () + ((output + :accessor output + :initarg :output + :initform *standard-output* + :type stream + :documentation "An output stream to which messages are logged.") + (logging-p + :accessor logging-p + :initform t) )) + +(defun print-assoc (alist &optional (stream t)) + (loop :for (k . v) :in alist + :do (format stream "~a: ~a~%" k v))) + +(defmethod handle-event :after ((log message-log) (event timeline-event)) + (when (logging-p log) + (print "Joined Room Message/Timeline Event" (output log)) + (terpri (output log)) + (let ((fields `(("room" . ,*room-id*) + ("sender" . ,(sender event)) + ("event type" . ,(event-type event)) + ("message type" . ,(msg-type event)) + ("messge body" . ,(msg-body event)) + ("content" . ,(event-content event))))) + (print-assoc fields (output log)) + (terpri (output log))))) + + +(defmethod handle-event :after ((log message-log) (event room-state-event)) + (when (logging-p log) + (print "Joined Room State Event" (output log)) + (terpri (output log)) + (let ((fields `(("room" . ,*room-id*) + ("sender" . ,(sender event)) + ("event type" . ,(event-type event)) + ("state key" . ,(state-key event)) + ("content" . ,(event-content event))))) + (print-assoc fields (output log)) + (terpri (output log))))) + +(defmethod handle-event :after ((log message-log) (event account-data-event)) + (when (logging-p log) + (print "Account Data Event" (output log)) + (terpri (output log)) + (print-assoc `(("content" . ,(event-content event)) + ("type" . ,(event-type event))) + (output log)) + (terpri (output log)))) + + +(defmethod handle-event :after ((log message-log) (event invitation-event)) + (when (logging-p log) + (print "Invitation Event" (output log)) + (terpri (output log)) + (let ((fields `(("room" . ,*room-id*) + ("sender" . ,(sender event)) + ("event type" . ,(event-type event)) + ("state key" . ,(state-key event)) + ("content" . ,(event-content event))))) + (print-assoc fields (output log)) + (terpri (output log))))) + + +;;; A Room and User Directory Bot + +(defclass server-room () + ((id :accessor room-id :initarg :id :initform (error "Must have a room-id")) + (name :accessor room-name :initarg :name :initform "") + (aliases :accessor room-aliases :initarg :aliases :initform nil) + (members :accessor room-members :initarg :members :initform nil) + (direct-p :accessor direct-p :initarg :direct-p :initform nil))) + +(defclass server-directory () + ((directory-table + :reader directory-table + :initform (make-hash-table :test 'equal) + :documentation "A table mapping room IDs to room struct instances.") + (m-direct-event-content + :accessor m-direct-event-content + :initform nil + :documentation "A cached copy of the current m.direct event"))) + +(defun get-room (client room-id) + "Get the SERVER-ROOM struct keyed by ROOM-ID, or return NIL." + (gethash room-id (directory-table client))) + +(defun update-room-name (client room-id name) + (let ((room (get-room client room-id))) + (if room + (setf (room-name room) name) + (setf room (make-instance 'server-room :id room-id :name name))) + (setf (gethash room-id (directory-table client)) room))) + +(defun update-room-member (client room-id member) + (let ((room (get-room client room-id))) + (if room + (pushnew member (room-members room) :test #'equal) + (setf room (make-instance 'server-room :id room-id :members (list member)))) + (setf (gethash room-id (directory-table client)) room))) + +;; TODO +(defun update-room-aliases (client room-id member) + (declare (ignore client room-id member))) + +(defmethod handle-event :after ((client server-directory) (event room-state-event)) + (cond + ((string= "m.room.name" (event-type event)) + (update-room-name client *room-id* (room-name event))) + + ((string= "m.room.member" (event-type event)) + (update-room-member client *room-id* (sender event))) + + ((string= "m.room.aliases" (event-type event)) + (update-room-aliases client *room-id* (room-aliases event))))) + +(defmethod handle-event :after ((client server-directory) (event timeline-event)) + (update-room-member client *room-id* (sender event))) + + +(defmethod handle-event :after ((client server-directory) (event account-data-event)) + (when (equal "m.direct" (event-type event)) + (setf (m-direct-event-content client) (event-content event)) + (loop :for (user room-ids . more) :on (event-content event) :by #'cddr :do + (dolist (room-id room-ids) + (mark-as-direct client (symbol-name user) room-id))))) + +(defun mark-as-direct (client user room-id) + (let-if (room (get-room client room-id)) + (progn + (setf (direct-p room) t) + (push user (room-members room)) + (setf (gethash room-id (directory-table client)) room)) + (setf (gethash room-id (directory-table client)) + (make-instance 'server-room :direct-p t :members (list user) :id room-id)))) + +(defun name-of-room (client room-id) + "Looks up the name of a room with ROOM-ID. Returns a string of NIL" + (let ((room (get-room client room-id))) + (when room (room-name room)))) + +(defun find-rooms-named (client name &key like full) + "Looks up the room ID of rooms with the name NAME. If LIKE is T, then any room + whose name contains the NAME as a substring is returned. If FULL is T, then + the SERVER-ROOM structs themselves are returned." + (with-slots (directory-table) client + (loop :for room :being :the :hash-values :of directory-table + :when (or (string-equal name (room-name room)) + (and like (search name (room-name room) :test #'string-equal))) + :collect (if full room (room-id room))))) + +(defun client-contacts (client) + "Returns a list of all users this client knows about." + (let (contacts) + (loop :for room :being :the :hash-values :of (directory-table client) :do + (dolist (user (room-members room)) + (pushnew user contacts :test #'equal))) + contacts)) + +(defun room-member-p (room name &key like) + (some (lambda (memb) (or (equal name memb) + (and like (search name memb :test #'string-equal)))) + (room-members room))) + +;; TODO might be too nebulous. Could be split up into two functions. +(defun find-contact (client name &key like get-direct-room) + "Finds a specific matrix or room ID by user name. + + If LIKE is NIL, returns a string equal to NAME if this client has a contact + with that NAME, or NIL otherwise. + + If LIKE is not NIL, returns the first matrix ID found that contains NAME as a + substring, or NIL if no such matrix ID is found. + + If GET-DIRECT-ROOM is not NIL, behave as above, except return a room address + instead. The returned address is usable for direct chats with the contact." + (if get-direct-room + ;; return a room-id if the room is marked as direct and has name as a member + (with-hash-table-iterator (next-room (directory-table client)) + (loop + (multiple-value-bind (theres-more room-id room) (next-room) + (unless theres-more (return nil)) + (when (and (direct-p room) + (room-member-p room name :like like)) + (return room-id))))) + ;; return a user-id + (find-if (lambda (contact) + (or (equal name contact) + (and like (search name contact :test #'string-equal)))) + (client-contacts client)))) + +(defun ensure-direct-room (client name &key like) + "Returns the room ID of a direct chat room between the bot and the user with NAME. If + no direct chat currently exists between the bot and the user, then an attempt will + be made to create one before returning the room id." + (let-cond + (room (find-contact client name :like like :get-direct-room t) + room) + (full-name (find-contact client name :like like) + (create-direct-message-room client full-name)))) + + + + +(defun create-direct-message-room (client name) + "Attempt to create a direct message room with the given name. If successful + the room id is returned. Returns nil and prints to *error-output* if + unsuccessful." + (let ((body (list :|invite| (list name) + :|is_direct| t))) + (send (client +create-room-path+ body :method :post :wrap make-basic-json) + ;; if successful + (let* ((room-id (getob (basic-json-data *response-object*) :|room_id|)) + (user-key (string->json-key name)) + (direct (m-direct-event-content client))) + + ;; add the room to the m.direct content for the user + (if (getf direct user-key) + (push (getf direct user-key) room-id) + (setf (getf direct user-key) (list room-id))) + + (setf (m-direct-event-content client) direct) ; update it here + + (when (update-account-data client "m.direct" direct) + room-id)) + ;; else + (format *error-output* + "FAILED to create private chat with ~a~%HTTP response: ~a ~a~%" + name *response-status* + (flexi-streams:octets-to-string *response-body*))))) + + +;;; Basic Joiner Bot + +(defclass auto-joiner () ()) + +(defmethod handle-event :after ((client auto-joiner) (event invitation-event)) + (when (equal "invite" + (getf (event-content event) :|join_rule|)) + (join-room client *room-id*))) + |