room and direct room managment

3 files changed, 123 insertions, 51 deletions

diff --git a/granolin.lisp b/granolin.lisp
index 3585615..96af47c 100644
--- a/granolin.lisp
+++ b/granolin.lisp
@@ -193,12 +193,14 @@
 (def-json-wrap basic-json)
 
 
-;;; URI constants for interacting with the Matrix API
+;;; URI constants (format) strings for interacting with the Matrix API
 
 (defparameter +login-path+ "/_matrix/client/r0/login")
 (defparameter +sync-path+ "/_matrix/client/r0/sync")
 (defparameter +join-room-path+ "/_matrix/client/r0/rooms/~a/join")
 (defparameter +text-message-path+ "/_matrix/client/r0/rooms/~a/send/m.room.message/~a")
+(defparameter +create-room-path+ "/_matrix/client/r0/createRoom")
+(defparameter +update-account-data-path+ "/_matrix/client/r0/user/~a/account_data/~a")
 
 ;;; Utility functions and macros for making HTTP requests to the MATRIX API
 
@@ -292,14 +294,14 @@
 
           (progn
             (setf (user-id client)
-                  (user-id *response-body*))
+                  (user-id *response-object*))
             (setf (access-token client)
                   (access-token *response-object*)))
 
           (error "Attempt to login ~a : ~a failed with ~a"
                  user password *response-status*))))
 
-(defun sync (client &key (full-state "false"))
+(defun sync (client &key full-state extra-params)
   "Synchronize client state with server state. CLIENT should have a valid
   ACCESS-TOKEN slot value (i.e. the CLIENT should have been logged in).
 
@@ -310,9 +312,12 @@
   https://matrix.org/docs/spec/client_server/r0.5.0#get-matrix-client-r0-sync
   "
   (let (params)
-    (push (cons "full_state" full-state) params)
+    (setf params (append params extra-params))
+    (when full-state
+      (push (cons "full_state" "true") params))
     (push (cons "timeout" (format nil "~a" (timeout client))) params)
-    (when (next-batch client)
+    (when (and (next-batch client)
+               (not full-state))
       (push (cons "since" (next-batch client))  params))
 
     (fetch (client +sync-path+ :params params :wrap make-sync-response)
@@ -321,6 +326,7 @@
                   *response-status* +sync-path+))))
 
 (defun handle-sync-response (client)
+  (print *response-object*)
   (setf (next-batch client)
         (next-batch *response-object*))
   (process-joined-events client)
@@ -424,18 +430,20 @@
                   (flexi-streams:octets-to-string *response-body*)))))
 
 
-(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 (user-id client) name)
-                    :|is_direct| t)))
-    (send (client +create-room-path+ body :method :post :wrap make-basic-json)
-          (getob (basic-json-data *response-object*) :|room_id|)
+(defun update-account-data (client m-type data)
+  "Serializes the PLIST DATA as JSON and PUTs it in account_data at the given M-TYPE.
+
+   E.g. M-TYPE might be the string m.direct"
+  (let ((url  (format nil
+                      +update-account-data-path+
+                      (user-id client)
+                      m-type)))
+    (send (client url data :method :put :wrap make-basic-json)
+          t
           (format *error-output*
-                  "FAILED to create private chat with ~a~%HTTP response: ~a ~a~%"
-                  name *response-status*
-                  (flexi-streams:octets-to-string *response-body)))))
+                  "FAILED to update user account data.~%HTTP respponse: ~a ~a~%"
+                  *response-status*
+                  (flexi-streams:octets-to-string *response-body*)))))
 
 ;;; bot loop
 
diff --git a/package.lisp b/package.lisp
index df94db6..c0e639b 100644
--- a/package.lisp
+++ b/package.lisp
@@ -24,9 +24,20 @@
    #:handle-event
    #:clean-up
 
-   ;; utility classes
-   #:message-log
-   #:server-directory
+   ;; utility classes & their APIS
+   #:message-log ; plugin 
+   #:server-directory ; plugin
+   #:server-room      ; data class
+   #:room-members
+   #:direct-p
+   #:get-room
+   #:get-direct-room
+   #:find-rooms-named
+   #:client-contacts
+   #:room-member-p
+   #:find-contact
+   #:ensure-direct-room
+
    #:auto-joiner
 
    ;; json data utilities & accessors
diff --git a/utility-apps.lisp b/utility-apps.lisp
index 01ac5b6..da32674 100644
--- a/utility-apps.lisp
+++ b/utility-apps.lisp
@@ -8,47 +8,65 @@
   ((output
     :accessor output
     :initarg :output
-    :initform (error "Message Log requires an output stream")
+    :initform *standard-output*
     :type stream
-    :documentation "An output stream to which messages are logged."
-    )))
+    :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) &optional room)
-  (print "Joined Room Message/Timeline Event" (output log))  
-  (let ((fields `(("room" . ,room)
-                  ("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))))
+  (when (logging-p log)
+    (print "Joined Room Message/Timeline Event" (output log))
+    (terpri (output log))
+    (let ((fields `(("room" . ,room)
+                    ("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) &optional room)
-  (print "Joined Room State Event" (output log))  
-  (let ((fields `(("room" . ,room)
-                  ("sender" . ,(sender event))
-                  ("event type" . ,(event-type event))
-                  ("state key" . ,(state-key event))
-                  ("content" . ,(event-content event)))))
-    (print-assoc fields (output log))
+  (when (logging-p log)
+    (print "Joined Room State Event" (output log))
+    (terpri (output log))
+    (let ((fields `(("room" . ,room)
+                    ("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) &optional room)
+  (declare (ignore room))
+  (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) &optional room)
-  (print "Invitation Event" (output log))
-  (let ((fields `(("room" . ,room)
-                  ("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))))
+  (when (logging-p log)
+    (print "Invitation Event" (output log))
+    (terpri (output log))
+    (let ((fields `(("room" . ,room)
+                    ("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
@@ -64,7 +82,11 @@
   ((directory-table
     :reader directory-table
     :initform (make-hash-table :test 'equal)
-    :documentation "A table mapping room IDs to room struct instances.")))
+    :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."
@@ -106,6 +128,7 @@
                                 &optional room-id)
   (declare (ignore room-id))
   (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 room-id)))))
@@ -169,10 +192,40 @@
                (client-contacts client))))
 
 (defun ensure-direct-room (client name &key like)
-  (let-if (room (find-contact client name :like like :get-direct-room t))
-          room
-          (create-direct-message-room client name :like 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)
+    (room (find-contact client name :like like)
+          (create-direct-message-room client room))))
+
+
+(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)))
+
+            (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