a3x/whatsxmpp
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

IQ handlers, XEP-0363 stuff, and SQLite, oh my!

Browse source
This commit is contained in:
eta 2020-04-03 17:40:05 +01:00
parent a297e6b70f
commit 2d873df755
6 changed files with 266 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
.gitignore vendored
View file

@ -1,2 +1,3 @@
*.fasl
*~
*~
*.sqlite*

2
packages.lisp Normal file
View file

@ -0,0 +1,2 @@
(defpackage :whatsxmpp
(:use :cl :usocket :event-emitter :blackbird :blackbird-base))

15
schema.sql Normal file
View file

@ -0,0 +1,15 @@
CREATE TABLE users (
id SERIAL PRIMARY KEY,
jid VARCHAR UNIQUE NOT NULL,
session_data VARCHAR
);
CREATE TABLE user_contacts (
id SERIAL PRIMARY KEY,
user_id INT NOT NULL REFERENCES users,
wa_jid VARCHAR UNIQUE NOT NULL,
subscription_state VARCHAR NOT NULL DEFAULT 'none',
avatar_url VARCHAR,
name VARCHAR,
notify VARCHAR
);

67
sqlite.lisp Normal file
View file

@ -0,0 +1,67 @@
(in-package :whatsxmpp)
(defvar *db* nil
"Connection to the database.")
(defparameter *default-database-path* "data.sqlite3"
"Default path to the SQLite database file.")
(defvar *prepared-statements* nil
"List of statements prepared by PREPARED-STATEMENT.")
(defparameter *sqlite-pragmas*
'("PRAGMA journal_mode = WAL"
"PRAGMA foreign_keys = ON"
"PRAGMA synchronous = NORMAL")
"List of SQLite pragmas to run on connection to make things bearable")
(defun run-pragmas ()
"Runs all statements in *SQLITE-PRAGMAS*."
(mapc (lambda (x) (sqlite:execute-non-query *db* x)) *sqlite-pragmas*))
(defun connect-database (&optional (path *default-database-path*))
"Establish a connection to the database."
(setf *db* (sqlite:connect path))
(run-pragmas)
(loop for sym in *prepared-statements*
do (eval `(setf ,sym nil)))
(setf *prepared-statements* nil))
(defmacro prepared-statement (statement)
"Caches the creation of a prepared statement with SQL text STATEMENT.
In other words, prepares STATEMENT once, then returns the prepared statement after that instead of doing that work again."
(let ((statement-sym (gensym "PREPARED-STATEMENT-")))
(eval `(defvar ,statement-sym nil))
`(progn
(defvar ,statement-sym nil)
(unless ,statement-sym
(setf ,statement-sym (sqlite:prepare-statement *db* ,statement))
(setf *prepared-statements* (cons ',statement-sym *prepared-statements*)))
,statement-sym)))
(defmacro with-prepared-statement ((name statement) &body forms)
"Evaluates FORMS, binding a prepared statement with SQL text STATEMENT to NAME, and ensuring it is reset when control is transferred."
`(let ((,name (prepared-statement ,statement)))
(unwind-protect
(progn ,@forms)
(ignore-errors (sqlite:reset-statement ,name)))))
(defmacro with-prepared-statements (statements &body forms)
"Like WITH-PREPARED-STATEMENT, but takes multiple statements."
(let ((let-forms (loop for (name statement) in statements
collect `(,name (prepared-statement ,statement))))
(reset-forms (loop for (name statement) in statements
collect `(ignore-errors (sqlite:reset-statement ,name)))))
`(let (,@let-forms)
(unwind-protect
(progn ,@forms))
(ignore-errors (progn ,@reset-forms)))))
(defmacro bind-parameters (statement &rest parameters)
"Binds PARAMETERS to the prepared statement STATEMENT.
PARAMETERS are either simple values (in which case they're bound to parameters 1, 2, ...),
or cons cells, where the `car` is the index to bind to and the `cdr' is the value to use."
`(progn
,@(loop for param in parameters
for idx from 1 upto (length parameters)
collect (if (listp param)
`(sqlite:bind-parameter ,statement ,(car param) ,(second param))
`(sqlite:bind-parameter ,statement ,idx ,param)))))

176
stuff.lisp
View file

@ -1,5 +1,3 @@
(defpackage :whatsxmpp
(:use :cl :usocket :event-emitter :blackbird :blackbird-base))
(in-package :whatsxmpp)
(defvar *last-stanza*)
@ -8,6 +6,9 @@
(defparameter +component-ns+ "jabber:component:accept")
(defparameter +disco-info-ns+ "http://jabber.org/protocol/disco#info")
(defparameter +disco-items-ns+ "http://jabber.org/protocol/disco#items")
(defparameter +muc-ns+ "http://jabber.org/protocol/muc")
(defparameter +file-upload-ns+ "urn:xmpp:http:upload:0")
(defparameter +vcard-temp-ns+ "vcard-temp")
(defclass xmpp-component (event-emitter)
((socket
@ -31,6 +32,9 @@
(shared-secret
:initarg :shared-secret
:reader component-shared-secret)
(handlers
:initform (make-hash-table)
:accessor component-handlers)
(promises
:initform (make-hash-table :test 'equal)
:accessor component-promises)))
@ -270,6 +274,36 @@
items)))))
items))))
(defun request-http-upload-slot (comp service-jid filename size mime-type)
"Requests an XEP-0363 HTTP Upload slot from the service at SERVICE-JID, aiming to upload the file with FILENAME, SIZE (in bytes) and MIME-TYPE. Returns a promise that resolves with a list of the form ((PUT-URL . ((HEADER-NAME . HEADER-VALUE) ...)) GET-URL)."
(declare (type xmpp-component comp) (type string service-jid filename mime-type) (type integer size))
(attach
(with-iq (comp service-jid)
(cxml:with-element "request"
(cxml:attribute "xmlns" +file-upload-ns+)
(cxml:attribute "filename" filename)
(cxml:attribute "size" (write-to-string size))
(cxml:attribute "content-type" mime-type)))
(lambda (results)
(let ((slot-node (get-node-named results "slot")))
(unless slot-node
(error "Malformed XEP-0363 response: no <slot/>"))
(let* ((children (dom:child-nodes slot-node))
(put-node (get-node-named children "put"))
(get-node (get-node-named children "get"))
(headers '()))
(unless (and put-node get-node)
(error "Malformed XEP-0363 response: PUT or GET nodes missing"))
(loop
for node across (dom:child-nodes put-node)
do (let ((name (dom:tag-name node)))
(when (equal name "header")
(setf headers (cons
(cons (dom:get-attribute node "name")
(dom:node-value (elt (dom:child-nodes node) 0)))
headers)))))
`((,(dom:get-attribute put-node "url") . ,headers) ,(dom:get-attribute get-node "url")))))))
(defun send-text-message (comp to-jid text &optional from)
"Send a simple text message to TO-JID, containing TEXT."
(with-message (comp to-jid :from from)
@ -303,6 +337,7 @@
:accessor stanza-error-text)
(raw
:initarg :raw
:initform nil
:accessor stanza-error-raw))
(:report (lambda (err stream)
(with-slots (defined-condition type text) err
@ -334,6 +369,112 @@
(declare (ignore comp))
(format *debug-io* "Connection complete! \o/"))
(defun send-iq-error (comp id to from e)
"Send E (a STANZA-ERROR) as an IQ error response."
(with-component-xml-output (comp)
(cxml:with-element "iq"
(cxml:attribute "type" "error")
(cxml:attribute "id" id)
(cxml:attribute "from" to)
(cxml:attribute "to" from)
(cxml:with-element "error"
(cxml:attribute "type" (stanza-error-type e))
(cxml:with-element (stanza-error-condition e)
(cxml:attribute "xmlns" +stanzas-ns+))
(when (stanza-error-text e)
(cxml:with-element "text"
(cxml:text (stanza-error-text e))))))))
(defmacro disco-identity (name type category)
`(cxml:with-element "identity"
(cxml:attribute "name" ,name)
(cxml:attribute "type" ,type)
(cxml:attribute "category" ,category)))
(defmacro disco-feature (feature)
`(cxml:with-element "feature"
(cxml:attribute "var" ,feature)))
(defun disco-info-handler (comp &key to &allow-other-keys)
"Handles XEP-0030 disco#info requests."
(format *debug-io* "~&disco#info: ~A~%" to)
(with-component-data-lock (comp)
`((cxml:with-element "query"
(cxml:attribute "xmlns" ,+disco-info-ns+)
(disco-feature +disco-info-ns+)
,@(cond
((equal to (component-name comp))
`((disco-identity "whatsxmpp bridge" "xmpp" "gateway")
(disco-feature ,+muc-ns+)))
(t nil))))))
(defun disco-items-handler (comp &key to &allow-other-keys)
"Handles XEP-0030 disco#items requests."
(format *debug-io* "~&disco#items: ~A~%" to)
(with-component-data-lock (comp)
`((cxml:with-element "query"
(cxml:attribute "xmlns" ,+disco-info-ns+)))))
(defun register-component-iq-handler (comp handler-name func)
"Register FUNC to be called for the HANDLER-NAME IQ handler on COMP."
(with-component-data-lock (comp)
(setf (gethash handler-name (component-handlers comp)) func)))
(defun call-component-iq-handler (comp handler &rest args)
"Calls the IQ handler identified by the symbol HANDLER on COMP, with the provided ARGS."
(destructuring-bind (&key id to from &allow-other-keys) args
(with-component-data-lock (comp)
(catcher
(attach
(let ((func (gethash handler (component-handlers comp))))
(unless func
(error 'stanza-error
:defined-condition "feature-not-implemented"
:text (format nil "No handler for ~A registered" handler)
:type "cancel"))
(let ((result (apply func comp args)))
result))
(lambda (result-forms)
(eval `(with-component-xml-output (,comp)
(cxml:with-element "iq"
(cxml:attribute "type" "result")
(cxml:attribute "id" ,id)
(cxml:attribute "from" ,to)
(cxml:attribute "to" ,from)
,@result-forms)))))
(stanza-error (e) (send-iq-error comp id to from e))
(t (e)
(send-iq-error comp id to from
(make-condition 'stanza-error
:defined-condition "internal-server-error"
:text (write-to-string e)
:type "cancel"))
(with-simple-restart
(continue "Continue execution.")
(invoke-debugger e)))))))
(defun handle-iq-get (comp id from stanza)
"Handles an IQ-get STANZA for component COMP."
(let* ((first-child (elt (dom:child-nodes stanza) 0))
(tag-name (dom:tag-name first-child))
(to (dom:get-attribute stanza "to"))
(xmlns (dom:get-attribute first-child "xmlns"))
(handler-type
(cond
((and (equal xmlns +disco-info-ns+) (equal tag-name "query"))
:disco-info)
((and (equal xmlns +disco-items-ns+) (equal tag-name "query"))
:disco-items)
((and (equal xmlns +vcard-temp-ns+) (equal tag-name "vCard"))
:vcard-temp-get)
(t
:generic-iq))))
(call-component-iq-handler comp handler-type
:to to
:id id
:from from
:stanza stanza)))
(defun handle-iq-response (comp stanza)
"Handles an IQ response STANZA for component COMP."
(with-component-data-lock (comp)
@ -341,7 +482,7 @@
(id (dom:get-attribute stanza "id"))
(from (dom:get-attribute stanza "from")))
(if (equal type "get")
(emit :iq-get comp id from stanza)
(handle-iq-get comp id from stanza)
(symbol-macrolet
((promise (gethash id (component-promises comp))))
(if promise
@ -354,7 +495,34 @@
(setf promise nil))
(warn "Unsolicited IQ stanza from ~A of type ~A, ID ~A" from type id)))))))
(defun handle-presence (comp stanza)
"Handles a presence STANZA for component COMP."
(let* ((type (dom:get-attribute stanza "type"))
(from (dom:get-attribute stanza "from"))
(to (dom:get-attribute stanza "to"))
(event-name
(cond
((equal type "subscribe") :presence-subscribe)
((equal type "probe") :presence-probe)
((equal type "unavailable") :presence-unavailable)
(t :presence))))
(emit event-name comp :from from :to to :stanza stanza)))
(defun handle-message (comp stanza)
"Handles a message STANZA for component COMP."
(let* ((from (dom:get-attribute stanza "from"))
(to (dom:get-attribute stanza "to"))
(body (get-node-named (dom:child-nodes stanza) "body")))
(if body
(let* ((child-nodes (dom:child-nodes body))
(text (if (> (length child-nodes) 0)
(dom:node-value (elt child-nodes 0))
"")))
(emit :text-message comp :from from :to to :body text :stanza stanza))
(emit :message comp :from from :to to :stanza stanza))))
(defun component-stanza (comp stanza)
"Handles a STANZA received by component COMP."
(setf *last-stanza* stanza)
(let* ((stanza (dom:document-element stanza))
(tag-name (dom:tag-name stanza)))
@ -362,6 +530,8 @@
((equal tag-name "stream:error") (handle-stream-error comp stanza))
((equal tag-name "handshake") (handle-connection-complete comp))
((equal tag-name "iq") (handle-iq-response comp stanza))
((equal tag-name "presence") (handle-presence comp stanza))
((equal tag-name "message") (handle-message comp stanza))
(t (emit :stanza comp stanza)))))
(defun make-component (server port shared-secret name)

7
whatsxmpp.asd Normal file
View file

@ -0,0 +1,7 @@
(defsystem "whatsxmpp"
:depends-on ("usocket" "bordeaux-threads" "event-emitter" "blackbird" "cxml" "sha1" "uuid" "sqlite")
:serial t
:components
((:file "packages")
(:file "sqlite")
(:file "stuff")))