;;; rudel-xmpp.el --- XMPP transport backend for Rudel -*- lexical-binding:t -*- ;; ;; Copyright (C) 2009, 2010, 2014, 2016 Free Software Foundation, Inc. ;; ;; Author: Jan Moringen ;; Keywords: rudel, xmpp, transport, backend ;; X-RCS: $Id:$ ;; ;; This file is part of Rudel. ;; ;; Rudel is free software: you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Rudel is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Rudel. If not, see . ;;; Commentary: ;; ;; This file contains the XMPP transport backend class ;; `rudel-xmpp-backend', which implements transporting XML messages ;; through XMPP connections. ;;; History: ;; ;; 0.1 - initial version ;;; Code: ;; (require 'cl-lib) (require 'rudel-state-machine) (require 'rudel-backend) (require 'rudel-transport) (require 'rudel-transport-util) ;; For `rudel-transport-filter' (require 'rudel-socket) ;; We instantiate the TCP transport (require 'rudel-util) (require 'rudel-xmpp-util) (require 'rudel-xmpp-state) ;;; Constants ;; (defconst rudel-xmpp-transport-version '(0 2) "Version of the XMPP transport backend for Rudel.") (defconst rudel-xmpp-protocol-version '(1 0) "Version of the XMPP protocol supported by this implementation.") ;;; Class rudel-xmpp-backend ;; ;;;###rudel-autoload (defclass rudel-xmpp-backend (rudel-transport-backend) ((capabilities :initform '(connect))) "Transport backend works by transporting XMPP messages through XMPP connections.") (cl-defmethod initialize-instance ((this rudel-xmpp-backend) _slots) "Initialize slots and set version of THIS." (cl-call-next-method) (oset this :version rudel-xmpp-transport-version)) (cl-defmethod rudel-ask-connect-info ((_this rudel-xmpp-backend) &optional info) "Augment INFO by reading a hostname and a port number." ;; Read server host and port. (let ((host (or (plist-get info :host) (read-string "Server: "))) (port (or (plist-get info :port) (read-number "Port: "))) (jid (or (plist-get info :jid) (read-string "Jabber ID (JID): ")))) (append (list :host host :port port :jid jid) info))) (cl-defmethod rudel-make-connection ((this rudel-xmpp-backend) info info-callback &optional progress-callback) "Connect to an XMPP server using the information in INFO. INFO has to be a property list containing at least the keys + :host a server name + :port TCP port to connect to + :jid jabber id that should be used If non-nil, PROGRESS-CALLBACK has to be a function which is called repeatedly to report progress." ;; Ensure that INFO contains all necessary information. (unless (cl-every (lambda (keyword) (member keyword info)) '(:host :jid)) (setq info (funcall info-callback this info))) ;; Extract information from INFO and connect. (let* ((host (plist-get info :host)) (jid (plist-get info :jid)) ;; Create the underlying transport. ;; TODO handle errors (tcp-transport (rudel-make-connection (cdr (rudel-backend-get 'transport 'tcp)) info info-callback progress-callback)) ;; Create a suitable stack of transport filters on top of the ;; underlying transport. (stack (rudel-xmpp-make-transport-filter-stack tcp-transport)) ;; Create the actual XMPP transport. (xmpp-transport (rudel-xmpp-transport (format "to %s as %s" host jid) :transport stack :start (list 'new host jid)))) ;; Now start receiving via the TCP connection and wait until the ;; connection has been established. (rudel-start tcp-transport) (rudel-state-wait xmpp-transport '(established) '(we-finalize they-finalize disconnected) progress-callback) ;; Return the usable transport object. xmpp-transport)) ;;; Class rudel-xmpp-state-new ;; (defclass rudel-xmpp-state-new (rudel-xmpp-state) () "Initial state of new XMPP connections.") (cl-defmethod rudel-enter ((_this rudel-xmpp-state-new) to jid) "Switch to \"negotiate-stream\" state." (list 'negotiate-stream to jid (list 'sasl-start jid to))) ;;; Class rudel-xmpp-state-negotiate-stream ;; (defclass rudel-xmpp-state-negotiate-stream (rudel-xmpp-state) ((success-state :initarg :success-state :type (or list symbol) :documentation "State to switch to in case of successful negotiation.")) "Stream negotiation state.") (cl-defmethod rudel-enter ((this rudel-xmpp-state-negotiate-stream) to jid success-state) "Send opening stream tag constructed with TO and JID." ;; Store the name of the successor state in case of successful ;; stream negotiation for later. (oset this :success-state success-state) ;; The first message we receive will be an incomplete XML document ;; with root . (with-slots (transport) this (rudel-set-assembly-function transport #'rudel-xmpp-assemble-stream) (rudel-set-generate-function transport #'identity)) ;; We cannot generate this message by serializing an XML infoset ;; since the document is incomplete. We construct it as a string ;; instead. (rudel-send this (format " \ " "UTF-8" (mapconcat #'identity (mapcar #'number-to-string rudel-xmpp-protocol-version) ".") ;; TODO rudel-version->string. hm, Emacs ;; has version-to-list, maybe also ;; version-list-to-string? to jid)) nil) (cl-defmethod rudel-leave ((this rudel-xmpp-state-negotiate-stream)) "Stop assembling based on opening stream tag." ;; One the stream is negotiated, assemble data based on complete XML ;; trees rather than the opening stream tag. (with-slots (transport) this (rudel-set-assembly-function transport #'rudel-xml-assemble-tags) (rudel-set-generate-function transport #'xml->string))) (cl-defmethod rudel-accept ((this rudel-xmpp-state-negotiate-stream) xml) "" (cond ;; Stream negotiation error. ;;((eq (xml-node-name xml) 'stream:stream) ;;nil) ;; TODO send error ;; Success (t ;; Extract features from received message and pass them to success ;; state. (with-slots (success-state) this (let ((features (xml-node-children (car (xml-get-children xml 'stream:features))))) (if (listp success-state) (append success-state (list features)) (list success-state features)))))) ) ;;; Class rudel-xmpp-state-authenticated ;; ;; TODO similar to new state; could use common base class (defclass rudel-xmpp-state-authenticated (rudel-xmpp-state) () "") (cl-defmethod rudel-enter ((_this rudel-xmpp-state-authenticated)) "" ;; Switch to negotiate-stream telling it to switch to established in ;; case the negotiation succeeds. (list 'negotiate-stream "jabber.org" "scymtym" 'established)) ;; TODO use real server- and username ;;; Class rudel-xmpp-state-authentication-failed ;; (defclass rudel-xmpp-state-authentication-failed (rudel-xmpp-state) () "") (cl-defmethod rudel-enter ((_this rudel-xmpp-state-authentication-failed)) "" 'we-finalize) ;;; Class rudel-xmpp-state-established ;; (defclass rudel-xmpp-state-established (rudel-xmpp-state) () "The XMPP connection enters this state when security negotiation and the negotiation of the actual stream are complete.") (cl-defmethod rudel-accept ((this rudel-xmpp-state-established) xml) "Store XML in buffer of THIS for later processing." (with-slots (shelve-buffer) this (push xml shelve-buffer)) nil) ;;; Class rudel-xmpp-state-idle ;; (defclass rudel-xmpp-state-idle (rudel-xmpp-state) () "The XMPP connection enters this state when security negotiation and the negotiation of the actual stream are complete.") (cl-defmethod rudel-enter ((this rudel-xmpp-state-idle)) "Process data previously shelved in (the transport owning) THIS." (with-slots (filter shelve-buffer) this (when filter (dolist (item shelve-buffer) (funcall filter item))) (setq shelve-buffer nil)) nil) (cl-defmethod rudel-accept ((this rudel-xmpp-state-idle) xml) "" (with-slots (filter) this (when filter (funcall filter xml))) nil) ;;; Class rudel-xmpp-state-we-finalize ;; (defclass rudel-xmpp-state-we-finalize (rudel-xmpp-state) () "") (cl-defmethod rudel-enter ((this rudel-xmpp-state-we-finalize)) "" ;; We send the closing tag, , of the stream ;; document. This has be processed as string, not XML. (with-slots (transport) this (rudel-set-generate-function transport #'identity)) (rudel-send this "") ;; TODO (rudel-close connection))? 'disconnected) ;;; Class rudel-xmpp-state-they-finalize ;; (defclass rudel-xmpp-state-they-finalize (rudel-xmpp-state) () "") (cl-defmethod rudel-enter ((this rudel-xmpp-state-they-finalize)) "" (rudel-close this) nil) ;;; Class rudel-xmpp-state-disconnected ;; (defclass rudel-xmpp-state-disconnected (rudel-xmpp-state) () "") ;;; XMPP state list ;; (defvar rudel-xmpp-states '(;; Basic XMPP states (new . rudel-xmpp-state-new) (negotiate-stream . rudel-xmpp-state-negotiate-stream) (authenticated . rudel-xmpp-state-authenticated) (authentication-failed . rudel-xmpp-state-authentication-failed) (established . rudel-xmpp-state-established) (idle . rudel-xmpp-state-idle) (we-finalize . rudel-xmpp-state-we-finalize) (they-finalize . rudel-xmpp-state-they-finalize) (disconnected . rudel-xmpp-state-disconnected)) "Basic states used in an XMPP connection. Authentication mechanisms can add more states to this list.") ;;; Class rudel-xmpp-transport ;; (defclass rudel-xmpp-transport (rudel-state-machine rudel-transport-filter) ((shelve-buffer :initarg :shelve-buffer :type list :initform nil :documentation "Stores parsed data that cannot be processed in the current for processing in a successor state.")) "") (cl-defmethod initialize-instance ((this rudel-xmpp-transport) _slots) "Initialize THIS and register states." ;; Initialize slots of THIS. (cl-call-next-method) ;; Register states. (rudel-register-states this rudel-xmpp-states) ;; Install a handler that passes received data to the user-provided ;; handler. (with-slots (transport) this (rudel-set-filter transport (lambda (data) (rudel-accept this data))))) (cl-defmethod rudel-register-state ((this rudel-xmpp-transport) _symbol state) "Associate THIS to STATE before registering STATE." ;; Associate THIS connection to STATE. (oset state :transport this) ;; Register the modified STATE. (cl-call-next-method) ) (cl-defmethod rudel-start ((this rudel-xmpp-transport)) "Start processing by THIS. Starting the transport can lead to immediate processing of previously shelved data" (rudel-switch this 'idle)) (cl-defmethod rudel-close ((this rudel-xmpp-transport)) "Close the XMPP connection used by THIS." (unless (member (rudel-current-state this) '(we-finalize they-finalize disconnected)) (rudel-switch this 'we-finalize)) (rudel-state-wait this '(disconnected)) (when (cl-next-method-p) (cl-call-next-method)) ;; TODO does this call rudel-close again? ) ;;; Autoloading ;; ;;;###rudel-autoload (rudel-add-backend (rudel-backend-get-factory 'transport) 'xmpp 'rudel-xmpp-backend) (provide 'rudel-xmpp) ;;; rudel-xmpp.el ends here