diff --git a/.gitignore b/.gitignore index 9a995f5..b383d8d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.fasl -*~ \ No newline at end of file +*~ +*.sqlite* \ No newline at end of file diff --git a/packages.lisp b/packages.lisp new file mode 100644 index 0000000..27664f2 --- /dev/null +++ b/packages.lisp @@ -0,0 +1,2 @@ +(defpackage :whatsxmpp + (:use :cl :usocket :event-emitter :blackbird :blackbird-base)) diff --git a/schema.sql b/schema.sql new file mode 100644 index 0000000..9a21100 --- /dev/null +++ b/schema.sql @@ -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 +); diff --git a/sqlite.lisp b/sqlite.lisp new file mode 100644 index 0000000..e0d113e --- /dev/null +++ b/sqlite.lisp @@ -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))))) diff --git a/stuff.lisp b/stuff.lisp index 7e7a51e..51f0a50 100644 --- a/stuff.lisp +++ b/stuff.lisp @@ -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 ")) + (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) diff --git a/whatsxmpp.asd b/whatsxmpp.asd new file mode 100644 index 0000000..8d3e9ef --- /dev/null +++ b/whatsxmpp.asd @@ -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")))