Parse contacts, chats, and new incoming messages (!); keep connected with pings

- We now actually parse the contact and chat information we get sent after
  the connection handshake.
- A massive protobuf autogenerated file has been added, which takes care of
  parsing the actual WhatsApp message objects -- i.e. the actual chat messages.
  We still need to actually translate that protobuf into something more
  usable though.
- Also, we don't disconnect now, because we actually send pings.

api.lisp

@@ -0,0 +1,100 @@
+;;;; Higher-level API types
+
+(in-package :whatscl)
+
+(defclass contact ()
+  ((jid
+    :accessor contact-jid
+    :initarg :jid
+    :initform (error "A contact JID must be provided")
+    :documentation "JID (unique address) for this contact.")
+   (notify
+    :accessor contact-notify
+    :initarg :notify
+    :initform nil
+    :documentation "The name the user set for themselves on WhatsApp (i.e. the ~name).")
+   (name
+    :accessor contact-name
+    :initarg :name
+    :initform nil
+    :documentation "A name for this contact, as specified in the user's address book."))
+  (:documentation "An entry in the list of the user's WhatsApp contacts."))
+
+(defun parse-contact (contact)
+  "Parse the wire-formatted CONTACT into an actual `contact' object."
+  (make-instance 'contact
+                 :jid (aval :jid contact)
+                 :notify (cassoc :notify contact)
+                 :name (cassoc :name contact)))
+
+(defmethod print-object ((obj contact) stream)
+  (print-unreadable-object (obj stream :type t)
+    (with-slots (jid notify name) obj
+      (format stream "~A~@[ (\"~~~A\")~]~@[ (\"~A\")~]" jid notify name))))
+
+(defclass chat-entry ()
+  ((jid
+    :accessor chat-jid
+    :initarg :jid
+    :initform (error "A groupchat JID must be provided")
+    :documentation "JID (unique address) for this chat entry.")
+   (subject
+    :accessor chat-subject
+    :initarg :subject
+    :initform nil
+    :documentation "If this chat is a groupchat, the subject (topic) of the groupchat.")
+   (last-activity
+    :accessor chat-last-activity
+    :initarg :last-activity
+    :initform nil
+    :documentation "The Unix timestamp of the last thing which happened in this chat.")
+   (is-spam
+    :accessor chat-is-spam
+    :initarg :is-spam
+    :initform nil
+    :documentation "Whether the chat is marked as spam.")
+   (is-read-only
+    :accessor chat-is-read-only
+    :initarg :is-read-only
+    :initform nil
+    :documentation "Whether the chat is read-only (you can't send to it)")
+   (muted-until
+    :accessor chat-muted-until
+    :initarg :muted-until
+    :initform nil
+    :documentation "The Unix timestamp of when this chat is muted until, or NIL if the chat is not muted.")
+   (modify-tag
+    :accessor chat-modify-tag
+    :initarg :modify-tag
+    :initform nil))
+  (:documentation "An entry in the user's list of WhatsApp chats (i.e. private messages and groupchats)."))
+
+(defun parse-chat-entry (entry)
+  "Parse the wire-formatted ENTRY into an actual `chat-entry' object."
+  (flet ((is-true (x) (equal x "true"))
+         (parse-muted (x)
+           (let ((ts (parse-integer x)))
+             (unless (eql ts 0) ts))))
+    (make-instance 'chat-entry
+                   :jid (aval :jid entry)
+                   :subject (cassoc :name entry)
+                   :last-activity (parse-integer (aval :t entry))
+                   :is-spam (map-when #'is-true (cassoc :spam entry))
+                   :is-read-only (map-when #'is-true (cassoc :read_only entry))
+                   :muted-until (map-when #'parse-muted (cassoc :mute entry))
+                   :modify-tag (cassoc :modify_tag entry))))
+
+(defmethod print-object ((obj chat-entry) stream)
+  (print-unreadable-object (obj stream :type t)
+    (with-slots (jid subject) obj
+      (format stream "~A~@[ (\"~A\")~]" jid subject))))
+
+(defun parse-pb-object (vector class length)
+  "Parse a protobuf object of class CLASS from the bytes stored in VECTOR."
+  (let ((ret (make-instance class)))
+    (pb:merge-from-array ret vector 0 length)
+    ret))
+
+(defun parse-web-message (vector)
+  "Parse a protobuf chat message stored in VECTOR."
+  (parse-pb-object vector 'wpb:web-message-info (length vector)))

connection.lisp

@@ -47,7 +47,14 @@
    (keypair
     :initarg :keypair
     :initform nil
-    :accessor wac-keypair))
+    :accessor wac-keypair)
+   (is-connected
+    :initform nil
+    :accessor wac-is-connected)
+   (ts-last
+    :initform 0
+    :accessor wac-ts-last
+    :documentation "The timestamp, as measured by GET-INTERNAL-REAL-TIME, of the last message received from WhatsApp."))
   (:documentation "Represents a WhatsApp Web connection."))
 
 (defmacro with-wac-lock ((wac) &body body)

packages.lisp

@@ -1,2 +1,5 @@
 (defpackage :whatscl
   (:use :cl :event-emitter :alexandria :split-sequence))
+
+(defpackage :whatscl/protobuf
+  (:nicknames :wpb))

utils.lisp

@@ -0,0 +1,24 @@
+;;;; Utility functions
+
+(in-package :whatscl)
+
+(defmacro cassoc (key alist)
+  "Macro for (CDR (ASSOC KEY ALIST))."
+  `(cdr (assoc ,key ,alist)))
+
+(defmacro aval (key alist)
+  "Retrieves the value associated with KEY from the association list ALIST, throwing an error if the value wasn't found."
+  (let ((val-sym (gensym))
+        (key-sym (gensym)))
+    `(let* ((,key-sym ,key)
+            (,val-sym (cassoc ,key-sym ,alist)))
+       (unless ,val-sym
+         (error "Malformed WhatsApp response: missing ~A" ,key-sym))
+       ,val-sym)))
+
+(defmacro map-when (func value)
+  "If VALUE is not NIL, applies FUNC to VALUE and returns the result."
+  (let ((val-sym (gensym)))
+    `(let ((,val-sym ,value))
+       (when ,val-sym
+         (funcall ,func ,val-sym)))))

whatscl.asd

@@ -1,9 +1,11 @@
 (defsystem "whatscl"
-  :depends-on ("websocket-driver-client" "ironclad" "cl-qrencode" "qbase64" "cl-json" "babel" "alexandria" "split-sequence" "nibbles" "flexi-streams" "bordeaux-threads")
+  :depends-on ("websocket-driver-client" "ironclad" "cl-qrencode" "qbase64" "cl-json" "babel" "alexandria" "split-sequence" "nibbles" "flexi-streams" "bordeaux-threads" "com.google.base" "protobuf" "trivial-timer")
   :serial t
   :components
   ((:file "packages")
+   (:file "utils")
    (:file "crypto")
    (:file "connection")
    (:file "binproto")
+   (:file "message_wire")
    (:file "whatscl")))

whatscl.lisp

@@ -14,6 +14,10 @@
 (defparameter *websocket-headers*
   '(("Origin" . "https://web.whatsapp.com"))
   "Headers to use when connecting to the WebSocket.")
+(defparameter *ping-interval-ms* 13000
+  "Milliseconds to wait between sending pings.")
+(defparameter *ping-deadline-ms* 3000
+  "Milliseconds to wait for a pong before declaring a connection timed out.")
 
 (defvar *last-message-tag* 0)
 
@@ -69,6 +73,26 @@
     ((vector (unsigned-byte 8)) (parse-binary-ws-message conn msg))
     (string (parse-string-ws-message msg))))
 
+(defun on-response-timer (conn registered-ts delay)
+  "Callback for the response timer: checks whether CONN has had any new messages since REGISTERED-TS, and, if not, disconnects."
+  (declare (ignore delay))
+  (with-wac-lock (conn)
+    (when (> registered-ts (wac-ts-last conn))
+      (emit :ping-timeout conn)
+      (wsd:close-connection (wac-ws conn)))))
+
+(defun on-ping-timer (conn)
+  "Callback for the periodic ping timer."
+  (with-wac-lock (conn)
+    (when (wac-is-connected conn)
+      (flet ((call-response-timer (rts dly) (on-response-timer conn rts dly))
+             (call-ping-timer (rts dly)
+               (declare (ignore rts dly))
+               (on-ping-timer conn)))
+        (wsd:send-text (wac-ws conn) "?,,")
+        (trivial-timer:register-timer-call *ping-deadline-ms* #'call-response-timer)
+        (trivial-timer:register-timer-call *ping-interval-ms* #'call-ping-timer)))))
+
 (defun send-ws-message (conn message &optional callback)
   "Send a message through the websocket of connection CONN. MESSAGE can be a string, byte vector, or other JSON-encodable object (and the appropriate type of message will be sent, depending on its type).
 CALLBACK, if provided, specifies a function to run with the reply sent by WhatsApp, if one is received."
@@ -88,13 +112,6 @@ CALLBACK, if provided, specifies a function to run with the reply sent by WhatsA
           (setf (gethash tag outgoing) callback))
         tag))))
 
-(defmacro aval (key alist)
-  "Retrieves the value associated with KEY from the association list ALIST, throwing an error if the value wasn't found."
-  `(let ((val (cdr (assoc ,key ,alist))))
-     (unless val
-       (error "Malformed WhatsApp response: missing ~A" ,key))
-     val))
-
 (defun cb-check-status (conn details &optional (reason "Generic operation"))
   "Verifies that the included DETAILS object contains a :status key with value 200. If not, throws an error."
   (declare (ignore conn))
@@ -160,14 +177,52 @@ CALLBACK, if provided, specifies a function to run with the reply sent by WhatsA
     (format t "Connected to WhatsApp as ~A.~%" jid)
     (emit :connected conn jid)))
 
-(defun on-server-binary-message (conn msg)
-  "Handles a binary message from the server that isn't a reply to something we've sent."
-  )
+(defun on-contacts-payload (conn payload)
+  "Handles a wire-format PAYLOAD of contacts information for CONN."
+  (let ((contacts nil))
+    (loop
+      for entry in payload
+      when (eql (car entry) :user)
+        do (setf contacts (cons (parse-contact (second entry)) contacts)))
+    (format t "Got contacts: ~A~%" contacts)
+    (emit :contacts conn contacts)))
+
+(defun on-chats-payload (conn payload)
+  "Handles a wire-format PAYLOAD of chats information for CONN."
+  (let ((chats nil))
+    (loop
+      for entry in payload
+      when (eql (car entry) :chat)
+        do (setf chats (cons (parse-chat-entry (second entry)) chats)))
+    (format t "Got chats: ~A~%" chats)
+    (emit :chats conn chats)))
 
-(defun on-server-json-message (conn msg)
-  "Handles a JSON message from the server that isn't a reply to something we've sent."
+(defun on-server-action (conn act)
+  "Handles a 'server action' message ACT."
+  (let ((type (first act)))
+    (cond
+      ((eql type :message)
+       (progn
+         (let ((msg (parse-web-message (third act))))
+           (format t "Got a message: ~A~%" msg)
+           (emit :message conn msg))))
+      (t (warn "Unknown server action: ~A" type)))))
+
+(defun on-server-message (conn msg)
+  "Handles a message from the server that isn't a reply to something we've sent."
   (destructuring-bind (opcode &rest payload) msg
     (cond
+      ((equal opcode :response)
+       (progn
+         (let ((type (aval :type (first payload))))
+           (cond
+             ((equal type "contacts") (on-contacts-payload conn (second payload)))
+             ((equal type "chat") (on-chats-payload conn (second payload)))
+             (t (warn "Invalid 'response' type ~A" type))))))
+      ((equal opcode :action)
+       (loop
+         for node in (second payload)
+         do (on-server-action conn node)))
       ((equal opcode "Conn") (on-connection-ack conn (car payload)))
       ((equal opcode "Cmd")
        (progn
@@ -182,27 +237,26 @@ CALLBACK, if provided, specifies a function to run with the reply sent by WhatsA
   (with-wac-lock (conn)
     (format t "WebSocket connected.~%")
     (emit :ws-connected conn)
-    (send-login-message conn)))
+    (setf (wac-is-connected conn) t)
+    (send-login-message conn)
+    (on-ping-timer conn)))
 
 (defun on-ws-message (conn msg)
   "Handles an incoming message (binary or JSON) from the server."
   (with-wac-lock (conn)
-    (with-accessors ((outgoing wac-outgoing)) conn
+    (with-accessors ((outgoing wac-outgoing) (tsl wac-ts-last)) conn
+      (setf tsl (get-internal-real-time))
       (let ((msg (parse-ws-message conn msg)))
         (emit :raw-message conn msg)
-        (if (eql msg :pong)
-            (progn
-              (format t "Got a pong~%"))
-            (destructuring-bind (tag &rest payload) msg
-              (format t "--> message (tag ~A): ~S~%" tag payload)
-              (let ((callback (gethash tag outgoing)))
-                (if callback
-                    (progn
-                      (remhash tag outgoing)
-                      (funcall callback conn payload))
-                    (etypecase payload
-                      ((vector (unsigned-byte 8)) (on-server-binary-message conn payload))
-                      (list (on-server-json-message conn payload)))))))))))
+        (unless (eql msg :pong)
+          (destructuring-bind (tag &rest payload) msg
+            (format t "--> message (tag ~A): ~S~%" tag payload)
+            (let ((callback (gethash tag outgoing)))
+              (if callback
+                  (progn
+                    (remhash tag outgoing)
+                    (funcall callback conn payload))
+                  (on-server-message conn payload)))))))))
 
 (defun on-ws-error (conn err)
   (format t "WebSocket error: ~A~%" err)
@@ -212,6 +266,7 @@ CALLBACK, if provided, specifies a function to run with the reply sent by WhatsA
 (defun on-ws-close (conn &key reason code)
   (format t "WebSocket closed: ~A (~A)~%" reason code)
   (with-wac-lock (conn)
+    (setf (wac-is-connected conn) nil)
     (emit :ws-close conn reason code)))
 
 (defun make-connection (&optional old-session &rest login-options)
@@ -225,6 +280,7 @@ If OLD-SESSION is provided, attempts to resume an old connection."
                               :login-information login-options
                               :client-id client-id
                               :keypair (multiple-value-list (crypto:generate-key-pair :curve25519)))))
+    (trivial-timer:initialize-timer)
     (when old-session
       (setf (wac-session conn) old-session))
     (on :open ws (lambda (&rest args) (apply #'on-ws-open conn args)))