├── .gitignore ├── src ├── client │ ├── domains │ │ ├── message-chat-manager.lisp │ │ ├── multi-user-chat-manager.lisp │ │ ├── multi-user-chat.lisp │ │ ├── message-chat.lisp │ │ └── roster.lisp │ ├── package.lisp │ ├── examples │ │ ├── echo-bot.lisp │ │ └── groupchat-bot.lisp │ ├── domain.lisp │ ├── session.lisp │ └── client.lisp ├── xeps │ ├── package.lisp │ ├── xep-0203.lisp │ ├── xep-0077.lisp │ ├── xep-0045.lisp │ ├── xep-0004.lisp │ └── xeps.lisp └── core │ ├── adapters.lisp │ ├── adapters │ ├── usocket-adapter.lisp │ └── iolib-adapter.lisp │ ├── connection.lisp │ ├── package.lisp │ ├── tls-negotiation.lisp │ ├── utils.lisp │ ├── sasl-negotiation.lisp │ ├── xml-stream.lisp │ └── stanzas.lisp ├── Makefile ├── tests ├── core │ ├── package.lisp │ ├── suite.lisp │ ├── usocket-adapter-test.lisp │ ├── xml-stream-test.lisp │ └── stanzas-test.lisp └── client │ ├── package.lisp │ ├── suite.lisp │ ├── session-test.lisp │ └── client-test.lisp ├── .travis.yml ├── cl-ngxmpp-client.examples.asd ├── cl-ngxmpp-client.asd ├── cl-ngxmpp-client-test.asd ├── cl-ngxmpp-xeps.asd ├── cl-ngxmpp-test.asd ├── cl-ngxmpp.asd ├── README.md └── COPYING /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | -------------------------------------------------------------------------------- /src/client/domains/message-chat-manager.lisp: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/client/domains/multi-user-chat-manager.lisp: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: clean 3 | 4 | clean: 5 | rm -v *.fasl 6 | 7 | -------------------------------------------------------------------------------- /tests/core/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-test 9 | (:use #:cl #:lift) 10 | (:export #:run-all-tests)) 11 | -------------------------------------------------------------------------------- /tests/client/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-client-test 9 | (:use #:cl #:lift) 10 | (:export #:run-all-tests)) 11 | -------------------------------------------------------------------------------- /src/client/domains/multi-user-chat.lisp: -------------------------------------------------------------------------------- 1 | ;;;; multi-user-chat.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | (define-domain multi-user-chat (multi-user-chat) 11 | ()) 12 | -------------------------------------------------------------------------------- /src/client/domains/message-chat.lisp: -------------------------------------------------------------------------------- 1 | ;;;; message-chat.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | (define-domain message-chat () 11 | ((recipient :accessor recipient :initarg :recipient :initform ""))) 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: lisp 2 | 3 | env: 4 | matrix: 5 | - LISP=sbcl 6 | - LISP=ccl 7 | 8 | install: 9 | - if [ -x ./install.sh ] && head -2 ./install.sh | grep '^#cl-travis' > /dev/null; 10 | then 11 | ./install.sh; 12 | else 13 | curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | sh; 14 | fi 15 | 16 | script: 17 | - cl -e '(ql:quickload :cl-ngxmpp-test) 18 | (cl-ngxmpp-test:run-all-tests)' 19 | -------------------------------------------------------------------------------- /tests/core/suite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; suite.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-test) 9 | 10 | (deftestsuite cl-ngxmpp-test () 11 | ()) 12 | 13 | (defparameter *test-print-test-case-names* t) 14 | 15 | (defun run-all-tests () 16 | "Run suite." 17 | (describe (run-tests :suite 'cl-ngxmpp-test))) 18 | -------------------------------------------------------------------------------- /src/xeps/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-xeps 9 | (:use #:cl #:xmpp%) 10 | (:nicknames #:xmpp-xeps) 11 | (:export ;; Utils 12 | #:get-xep ;; TODO: consider removing this from the export list 13 | #:xep-available-p 14 | #:register-xeps)) 15 | -------------------------------------------------------------------------------- /tests/client/suite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; suite.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client-test) 9 | 10 | (deftestsuite cl-ngxmpp-client-test () 11 | ()) 12 | 13 | (defparameter *test-print-test-case-names* t) 14 | 15 | (defun run-all-tests () 16 | "Run suite." 17 | (describe (run-tests :suite 'cl-ngxmpp-client-test))) 18 | -------------------------------------------------------------------------------- /cl-ngxmpp-client.examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp-client.examples.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp-client.examples 11 | :name "cl-ngxmpp-client.examples" 12 | :author "Michael Nedokushev " 13 | :license "Lisp-LGPL" 14 | :depends-on (:cl-ngxmpp-client) 15 | :components ((:module "src/client/examples" 16 | :components ((:file "echo-bot"))))) 17 | 18 | -------------------------------------------------------------------------------- /cl-ngxmpp-client.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp-client.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp-client 11 | :name "cl-ngxmpp-client" 12 | :author "Michael Nedokushev " 13 | :license "Lisp-LGPL" 14 | :depends-on (:cl-ngxmpp :cl-ngxmpp-xeps) 15 | :serial t 16 | :components ((:module "src/client" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "client") 20 | (:file "session") 21 | (:file "domain"))))) 22 | 23 | 24 | -------------------------------------------------------------------------------- /cl-ngxmpp-client-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp-client-test.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp-client-test 11 | :name "cl-ngxmpp-test" 12 | :author "Michael Nedokushev " 13 | :depends-on (:lift :cl-ngxmpp-client) 14 | :license "Lisp-LGPL" 15 | :serial t 16 | :components ((:module "tests/client" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "suite") 20 | (:file "client-test") 21 | (:file "session-test"))))) 22 | 23 | -------------------------------------------------------------------------------- /cl-ngxmpp-xeps.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp-xeps.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp-xeps 11 | :name "cl-ngxmpp-xeps" 12 | :author "Michael Nedokushev " 13 | :license "Lisp-LGPL" 14 | :depends-on (:cl-ngxmpp) 15 | :serial t 16 | :components ((:module "src/xeps" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "xeps"))))) 20 | ;;(:file "xep-0004") 21 | ;;(:file "xep-0045") 22 | ;;(:file "xep-0203"))))) 23 | 24 | -------------------------------------------------------------------------------- /cl-ngxmpp-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp-test.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp-test 11 | :name "cl-ngxmpp-test" 12 | :author "Michael Nedokushev " 13 | :depends-on (:lift :cl-ngxmpp) 14 | :license "Lisp-LGPL" 15 | :serial t 16 | :components ((:module "tests/core" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "suite") 20 | (:file "stanzas-test") 21 | (:file "usocket-adapter-test") 22 | (:file "xml-stream-test"))))) 23 | 24 | -------------------------------------------------------------------------------- /src/core/adapters.lisp: -------------------------------------------------------------------------------- 1 | ;;;; adapter.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | (defclass adapter () 11 | ((socket-stream :accessor socket-stream :initarg :socket-stream :initform nil))) 12 | 13 | (defgeneric adapter-close-connection (adapter) 14 | (:documentation "Close connection")) 15 | 16 | (defgeneric adapter-open-connection (adapter hostname port) 17 | (:documentation "Open connection")) 18 | 19 | (defgeneric adapter-read-from-stream (adapter &key stanza-reader) 20 | (:documentation "Read from XML stream")) 21 | 22 | (defgeneric adapter-write-to-stream (adapter string) 23 | (:documentation "Write to XML stream")) 24 | 25 | (defgeneric adapter-connectedp (adapter) 26 | (:documentation "Connected predicate") 27 | (:method ((adapter adapter)) 28 | (with-slots (socket-stream) adapter 29 | (and (streamp socket-stream) 30 | (open-stream-p socket-stream))))) 31 | -------------------------------------------------------------------------------- /src/client/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-client 9 | (:use #:cl) 10 | (:nicknames #:xmpp) 11 | (:export ;; Basics 12 | #:disconnect-client 13 | #:connect-client 14 | #:login-client 15 | #:connectedp 16 | #:loggedinp 17 | 18 | #:proceed-stanza 19 | #:proceed-stanza-loop 20 | #:receive-stanza 21 | #:send-stanza 22 | 23 | #:register-xeps 24 | 25 | ;; Deprecated 26 | #:send-message 27 | #:send-presence 28 | 29 | ;; Classes 30 | #:client 31 | 32 | 33 | ;; ;; High interface: client/high/ 34 | ;; #:open-session 35 | ;; #:close-session 36 | 37 | ;; ;;Classes 38 | ;; #:session 39 | ;; #:domain 40 | 41 | )) 42 | 43 | -------------------------------------------------------------------------------- /cl-ngxmpp.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-ngxmpp.asd 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-user) 9 | 10 | (asdf:defsystem #:cl-ngxmpp 11 | :name "cl-ngxmpp" 12 | :author "Michael Nedokushev " 13 | :license "Lisp-LGPL" 14 | :depends-on (:blackbird :alexandria :usocket :cxml :babel :cl+ssl :cl-base64 :uuid :cl-mop :cl-sasl) 15 | :serial t 16 | :components ((:module "src/core" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "utils") 20 | (:file "connection") 21 | (:file "xml-stream") 22 | (:file "stanzas") 23 | (:file "tls-negotiation") 24 | (:file "sasl-negotiation") 25 | (:file "adapters") 26 | (:module "adapters/" 27 | :serial t 28 | :components ((:file "usocket-adapter"))))))) 29 | -------------------------------------------------------------------------------- /src/core/adapters/usocket-adapter.lisp: -------------------------------------------------------------------------------- 1 | ;;;; usocket-adapter.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | (defclass usocket-adapter (adapter) 11 | ((socket :accessor socket :initarg :socket :initform nil))) 12 | 13 | (defmethod adapter-close-connection ((adapter usocket-adapter)) 14 | (close (socket-stream adapter))) 15 | 16 | (defmethod adapter-open-connection ((adapter usocket-adapter) hostname port) 17 | (with-proxy-error connection-error 18 | (usocket:ns-host-not-found-error 19 | usocket:timeout-error 20 | usocket:connection-refused-error) 21 | (let* ((socket (usocket:socket-connect hostname port :element-type 'character)) 22 | (stream (usocket:socket-stream socket))) 23 | (setf (socket adapter) socket 24 | (socket-stream adapter) stream)))) 25 | 26 | (defmethod adapter-read-from-stream ((adapter usocket-adapter) &key stanza-reader) 27 | (bb:promisify (result (stanza-reader-read-stream 28 | (make-instance stanza-reader 29 | :stanza-stream (socket-stream adapter)))))) 30 | 31 | (defmethod adapter-write-to-stream ((adapter usocket-adapter) string) 32 | (with-slots (socket-stream) adapter 33 | (write-string string socket-stream) 34 | (force-output socket-stream)) 35 | (length string)) 36 | -------------------------------------------------------------------------------- /src/client/domains/roster.lisp: -------------------------------------------------------------------------------- 1 | ;;;; roster.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | (define-domain :singleton roster () 11 | ;; Each route will be added into a global routing table. 12 | ;; The table looks like: 13 | ;; (:presence-stanza 14 | ;; (roster add-entry 15 | ;; ;; implicit function for destructuring incoming stanza. 16 | ;; #'(lambda (jid name description) (destruct-stanza-object-and-return-needed-fields)) 17 | ;; ;; user-defined function on which the main action takes the place. 18 | ;; #'(lambda (jid name desription) action)) 19 | ;; :message-stanza 20 | ;; (...)) 21 | :routes ((add-entry (s 'presence-subscribed-stanza (jid name subscription)) 22 | (destruct-stanza-object-and-return-needed-fields)) 23 | (delete-entry (s 'presence-unsubscribed-stanza (jid name subscription)) 24 | (...))) 25 | :slots ((entries :accessor entries :initarg :entries :initform nil))) 26 | 27 | (defclass roster-entry () 28 | ((jid :accessor jid :initarg :jid :initform "") 29 | (resource :accessor resource :initarg :resource :initform "") 30 | (subscription :accessor subscription :initarg :subscription :initform "") 31 | (status :accessor status :initarg :status :initform "online"))) 32 | -------------------------------------------------------------------------------- /src/core/connection.lisp: -------------------------------------------------------------------------------- 1 | ;;;; connection.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | (defvar +default-hostname+ "localhost") 11 | (defvar +default-port+ 5222) 12 | 13 | 14 | (define-condition connection-error (proxy-error) 15 | ()) 16 | 17 | (defclass connection () 18 | ((hostname :accessor hostname :initarg :hostname :initform +default-hostname+) 19 | (port :accessor port :initarg :port :initform +default-port+) 20 | (adapter :accessor adapter :initarg :adapter :initform nil))) 21 | 22 | #+nil 23 | (defmethod print-object ((obj connection) stream) 24 | "Just print a human readable representation of connection object." 25 | (print-unreadable-object (obj stream :type t :identity t) 26 | (let ((connected (connectedp obj))) 27 | (when connected 28 | (format stream "localhost:~A -> " (usocket:get-local-port (socket obj)))) 29 | (format stream "~A:~A" (hostname obj) (port obj)) 30 | (let ((status (if connected " (opened)" " (closed)"))) 31 | (format stream status))))) 32 | 33 | (defmethod connectedp ((connection connection)) 34 | (adapter-connectedp (adapter connection))) 35 | 36 | (defmethod close-connection ((connection connection)) 37 | (adapter-close-connection (adapter connection))) 38 | 39 | (defmethod open-connection ((connection connection)) 40 | (adapter-open-connection (adapter connection) 41 | (hostname connection) 42 | (port connection))) 43 | 44 | -------------------------------------------------------------------------------- /tests/client/session-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; session-test.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client-test) 9 | 10 | 11 | (deftestsuite session-test (cl-ngxmpp-client-test) 12 | ((session nil) 13 | (server-hostname "ch3kr.net") 14 | (server-port 5222) 15 | (username "clngxmpp") 16 | (password "clngxmpp") 17 | (mechanism nil)) 18 | (:setup (setf session (xmpp::create-session 19 | :server-hostname server-hostname 20 | :server-port server-port 21 | :username username 22 | :password password 23 | :mechanism mechanism 24 | :debuggable nil))) 25 | (:teardown (setf session nil))) 26 | 27 | 28 | (deftestsuite session-open-test (session-test) 29 | () 30 | (:teardown (xmpp:close-session session))) 31 | 32 | (addtest (session-open-test) 33 | correct-open 34 | (progn 35 | (xmpp:open-session session) 36 | (ensure (xmpp%:openedp 37 | (xmpp::xml-stream session))))) 38 | 39 | (addtest (session-open-test) 40 | incorrect-server-hostname-open 41 | (progn 42 | (setf (xmpp::server-hostname session) "incorrect.hostname") 43 | (ensure-condition xmpp%:connection-error 44 | (xmpp:open-session session)))) 45 | 46 | (addtest (session-open-test) 47 | incorrect-username-open 48 | (progn 49 | (setf (xmpp::username session) "incorrect-username-unknown") 50 | (ensure-condition xmpp%:negotiate-sasl-error 51 | (xmpp:open-session session)))) 52 | 53 | -------------------------------------------------------------------------------- /src/xeps/xep-0203.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xep-0203.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-xeps) 9 | 10 | (defun delayed-delivery-dispatcher (stanza) 11 | (get-element-by-name (dom:first-child (xml-node stanza)) "delay")) 12 | 13 | (define-xep (delayed-delivery :order "0203" 14 | :description "XEP 0203, Delayed Delivery" 15 | :depends-on (multi-user-chat)) 16 | 17 | ((root-stanza () 18 | (description 19 | (delay-from "") 20 | (stamp "") 21 | (delay-xmlns "urn:xmpp:delay")) 22 | 23 | (:methods 24 | ((xml-to-stanza ((stanza) dispatchers) 25 | (let* ((delay-node (get-element-by-name (dom:first-child (xml-node stanza)) "delay")) 26 | (from (dom:get-attribute delay-node "from")) 27 | (stamp (dom:get-attribute delay-node "stamp")) 28 | (description (get-element-data delay-node))) 29 | (setf (description stanza) description 30 | (delay-from stanza) from 31 | (stamp stanza) stamp) 32 | stanza))))) 33 | 34 | (message-stanza (delayed-delivery-root-stanza 35 | message-stanza) 36 | () 37 | 38 | (:methods 39 | ((xml-to-stanza ((stanza) dispatchers) 40 | (call-next-method stanza))) 41 | 42 | :dispatcher ((stanza) 43 | (delayed-delivery-dispatcher stanza)))) 44 | 45 | 46 | (message-groupchat-stanza (delayed-delivery-root-stanza 47 | multi-user-chat-message-groupchat-stanza) 48 | () 49 | 50 | (:methods 51 | ((xml-to-stanza ((stanza) dispatchers) 52 | (call-next-method stanza dispatchers))) 53 | 54 | :dispatcher ((stanza) 55 | (delayed-delivery-dispatcher stanza)))))) 56 | -------------------------------------------------------------------------------- /src/client/examples/echo-bot.lisp: -------------------------------------------------------------------------------- 1 | ;;;; echo-bot.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-client.examples.echo-bot 9 | (:use #:cl) 10 | (:export #:run)) 11 | 12 | (in-package #:cl-ngxmpp-client.examples.echo-bot) 13 | 14 | (defun run (&key server-hostname username password mechanism to message) 15 | (labels ((handle-stanzas (xmpp-client) 16 | (let ((stanza (xmpp:receive-stanza xmpp-client))) 17 | (when (typep stanza 'xmpp%:message-stanza) 18 | (let ((from (xmpp%::from stanza)) 19 | (body (xmpp%::body stanza))) 20 | (if (string= body "stop talking") 21 | (progn 22 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza 23 | :to from :body ">> Thanks for talking with me. Bye! :)") 24 | (xmpp:disconnect-client xmpp-client)) 25 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza 26 | :to from 27 | :body (format nil ">> ~A" body))))) 28 | (when (xmpp:connectedp xmpp-client) 29 | (handle-stanzas xmpp-client))))) 30 | 31 | (let ((xmpp-client (make-instance 'xmpp:client :debuggable t))) 32 | (xmpp:connect-client xmpp-client :server-hostname server-hostname) 33 | (when (xmpp:connectedp xmpp-client) 34 | (xmpp:login-client xmpp-client 35 | :username username 36 | :password password 37 | :mechanism mechanism) 38 | (when (xmpp:loggedinp xmpp-client) 39 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza :to to :body message) 40 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza :to to 41 | :body "To end up the session, send me a message 'stop talking'") 42 | (handle-stanzas xmpp-client)))))) 43 | 44 | -------------------------------------------------------------------------------- /src/core/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp 9 | (:use #:cl) 10 | (:nicknames #:xmpp%) 11 | (:export #:+default-hostname+ 12 | #:+default-port+ 13 | 14 | ;; Utils 15 | #:debuggable 16 | #:statefull 17 | 18 | #:chain-statefull 19 | #:string-to-keyword 20 | #:string-case 21 | 22 | ;; Methods 23 | #:negotiate-tls 24 | #:negotiate-sasl 25 | #:connectedp 26 | #:open-connection 27 | #:close-connection 28 | #:open-stream 29 | #:close-stream 30 | #:create-stream 31 | #:with-stanza-input 32 | #:with-stanza-output 33 | #:openedp 34 | #:closedp 35 | #:tls-negotiatedp 36 | #:sasl-negotiatedp 37 | #:handle-stanza 38 | #:xep-available-p 39 | #:concat-symbols 40 | #:stanza-reader-read-stream 41 | #:resolve-async-value 42 | #:print-debug 43 | #:get-stanza-xml-string 44 | 45 | ;; DSL 46 | #:define-xep 47 | #:defstanza 48 | 49 | ;; Classes 50 | #:connection 51 | #:xml-stream 52 | #:stanza-reader 53 | #:stanza-reader-header 54 | #:stanza-reader-features 55 | #:adapter 56 | #:usocket-adapter 57 | #:iolib-adapter 58 | 59 | ;; Stanzas 60 | #:stanza 61 | #:message-stanza 62 | #:iq-result-stanza 63 | #:iq-get-stanza 64 | #:iq-set-stanza 65 | #:iq-result-stanza 66 | #:iq-set-bind-stanza 67 | #:iq-set-session-stanza 68 | #:presence-stanza 69 | #:presence-subscribe-stanza 70 | #:presence-show-stanza 71 | #:unknown-stanza 72 | 73 | ;; Conditions 74 | #:handle-stanza-error 75 | #:negotiate-sasl-error 76 | #:stanza-reader-error 77 | #:connection-error 78 | #:defstanza-method%-error 79 | #:defstanza-class%-error)) 80 | -------------------------------------------------------------------------------- /tests/client/client-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; client-test.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client-test) 9 | 10 | (deftestsuite client-test (cl-ngxmpp-client-test) 11 | ((client nil) 12 | (server-hostname "ch3kr.net") 13 | (server-port 5222) 14 | (adapter (make-instance 'xmpp%:usocket-adapter)))) 15 | 16 | 17 | (deftestsuite client-connect/disconnect-test (client-test) 18 | () 19 | (:setup (setf client 20 | (make-instance 'xmpp:client 21 | :server-hostname server-hostname 22 | :server-port server-port 23 | :debuggable nil 24 | :adapter adapter))) 25 | (:teardown (xmpp:disconnect client))) 26 | 27 | (addtest (client-connect/disconnect-test) 28 | correct-open 29 | (progn 30 | (xmpp:connect client) 31 | (ensure (xmpp%:openedp (xmpp::xml-stream client))))) 32 | 33 | (addtest (client-connect/disconnect-test) 34 | incorrect-hostname-open 35 | (progn 36 | (setf (xmpp::server-hostname client) "incorrect-hostname") 37 | (ensure-condition xmpp%:connection-error 38 | (xmpp:connect client)))) 39 | 40 | (addtest (client-connect/disconnect-test) 41 | incorrect-port-open 42 | (progn 43 | (setf (xmpp::server-port client) 123) 44 | (ensure-condition xmpp%:connection-error 45 | (xmpp:connect client)))) 46 | 47 | (addtest (client-connect/disconnect-test) 48 | disconnect-from-connected 49 | (progn 50 | (xmpp:connect client) 51 | (ensure (xmpp:disconnect client)))) 52 | 53 | 54 | (deftestsuite client-authorize-test (client-test) 55 | ((username "clngxmpp") 56 | (password "clngxmpp")) 57 | (:setup (progn 58 | (setf client 59 | (make-instance 'xmpp:client 60 | :server-hostname server-hostname 61 | :server-port server-port 62 | :debuggable nil 63 | :adapter adapter)) 64 | (xmpp:connect client)))) 65 | 66 | (addtest (client-authorize-test) 67 | correct-authorize 68 | (progn 69 | (xmpp:authorize client 70 | :username username 71 | :password password) 72 | (ensure 73 | (xmpp%:sasl-negotiatedp (xmpp::xml-stream client))))) 74 | -------------------------------------------------------------------------------- /src/core/tls-negotiation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tls-negotiation.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (defstanza starttls-element (meta-element) 13 | ((xmlns "urn:ietf:params:xml:ns:xmpp-tls")) 14 | 15 | (stanza-to-xml ((stanza)) 16 | (cxml:with-element "starttls" 17 | (cxml:attribute "xmlns" (xmlns stanza)))) 18 | 19 | (xml-to-stanza ((stanza) dispatchers) 20 | stanza)) 21 | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (defstanza proceed-element (meta-element) 25 | () 26 | 27 | (xml-to-stanza ((stanza) dispatchers) 28 | stanza)) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | (define-condition negotiate-tls-error (simple-condition) 33 | ((failure-stanza :accessor failure-stanza :initarg :failure-stanza :initform nil))) 34 | 35 | (defun %tls-fail% (failure) 36 | (error (make-condition 'negotiate-tls-error 37 | :failure-stanza failure 38 | :format-control "TLS failied: ~A" 39 | :format-arguments (list failure)))) 40 | 41 | (defmethod negotiate-tls ((xml-stream xml-stream)) 42 | (send-tls-negotiation xml-stream) 43 | (receive-tls-negotiation xml-stream)) 44 | 45 | (defmethod send-tls-negotiation ((xml-stream xml-stream)) 46 | (with-stanza-output (xml-stream) 47 | (make-instance 'starttls-element))) 48 | 49 | (defmethod receive-tls-negotiation ((xml-stream xml-stream)) 50 | ;; We can omit dispatchers parameter here, because the xmpp protocol defines that 51 | ;; it is an error when an incoming stanza is not a proceed-element stanza, 52 | ;; so we don't care about dispatching in this case. 53 | (with-stanza-input (xml-stream stanza-input nil) 54 | (cond ((typep stanza-input 'proceed-element) 55 | (proceed-tls-negotiation xml-stream)) 56 | (t (%tls-fail% stanza-input))))) 57 | 58 | (defmethod proceed-tls-negotiation ((xml-stream xml-stream)) 59 | (let ((adapter (adapter (connection xml-stream)))) 60 | (with-slots (socket-stream) adapter 61 | (setf socket-stream (cl+ssl:make-ssl-client-stream socket-stream :external-format '(:utf-8 :eol-style :crlf))) 62 | (restart-stream xml-stream) 63 | (setf (state xml-stream) 'tls-negotiated)))) 64 | -------------------------------------------------------------------------------- /src/client/domain.lisp: -------------------------------------------------------------------------------- 1 | ;;;; domain.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | ;; TODO: 11 | ;; 12 | ;; Make possibility to receive roster and presence information manually. 13 | ;; 14 | ;; Routing for incoming stanzas: 15 | ;; - starting point for stanzas' routing could be a new facility 16 | ;; (i.e. (domain-route-stanza (read-stanza *client*))) 17 | ;; - each domain should describe what stanzas it can take. 18 | ;; - ??? 19 | 20 | ;; Global routing table. 21 | (defparameter *domains-routes* nil) 22 | 23 | (define-condition domain-error (simple-condition) 24 | ()) 25 | 26 | (defclass domain (session) 27 | ((domain-id 28 | :accessor domain-id 29 | :initform (xmpp%:string-to-keyword (symbol-name (gensym "domain")))) 30 | (mandatory-xep-deps :accessor mandatory-xep-deps :initform nil))) 31 | 32 | (defmacro define-domain (domain-name &optional (lifetime :singleton) 33 | (&rest mandatory-xep-deps) &body slots) 34 | `(progn 35 | (defclass ,domain-name (domain) (,@slots)) 36 | 37 | (defmethod initialize-instance :after ((domain ,domain-name) &key) 38 | (with-slots (mandatory-xep-deps) domain 39 | ;; Check if XEP is available for current session 40 | (mapcar #'(lambda (dep) 41 | (unless (member dep (xeps-list domain)) 42 | (error (make-condition 'domain-error 43 | :format-control "You should use one of specified xeps: ~A" 44 | :format-arguments (list mandatory-xep-deps))))) 45 | mandatory-xep-deps) 46 | (setf (mandatory-xep-deps domain) mandatory-xep-deps))) 47 | 48 | ;; TODO: replace with macros which will take same arguments, 49 | ;; and additional :routes argument. 50 | (defmethod ,@(alexandria:symbolicate 'make '- `,domain-name) ((session session)) 51 | (with-slots (domains) session 52 | (when (eql ,lifetime :singleton) 53 | (getf (domains session) (string-to-keyword (symbol-name `,domain-name)))) 54 | (let ((instance ((make-instance `,domain-name 55 | :username (username session) 56 | :server-hostname (server-hostname session) 57 | :xml-stream (xml-stream session) 58 | :xeps-list (xeps-list session))))) 59 | instance))))) 60 | 61 | -------------------------------------------------------------------------------- /src/xeps/xep-0077.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xep-0077.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-xeps) 9 | 10 | (define-xep (in-band-registration :order "0077" 11 | :description "XEP 0077, In-Band Registration" 12 | :depends-on (data-forms)) 13 | 14 | ((iq-get-registration-fields-stanza (iq-get-stanza) 15 | () 16 | 17 | (:methods 18 | ((stanza-to-xml ((stanza)) 19 | (with-iq-stanza stanza 20 | (cxml:with-element "query" 21 | (cxml:with-attribute "xmlns" "jabber:iq:register"))))))) 22 | 23 | (iq-result-registration-fields-stanza (iq-result-stanza) 24 | (instructions username nick password name first last email address city 25 | state zip phone url date misc text key registered) 26 | 27 | (:methods 28 | ((xml-to-stanza ((stanza)) 29 | ;; according to http://xmpp.org/extensions/xep-0077.html#registrar-formtypes 30 | (let* ((instructions-node (get-element-by-name query-node "instructions")) 31 | (instructions (when instructions-node 32 | (get-element-data instructions-node)))) 33 | (make-instance 'iq-result-registration-fields-stanza 34 | :instructions instructions 35 | :username (field-required-p stanza "username") 36 | :password (field-required-p stanza "password") 37 | :name (field-required-p stanza "name") 38 | :first (field-required-p stanza "first") 39 | :last (field-required-p stanza "last") 40 | :email (field-required-p stanza "email") 41 | :address (field-required-p stanza "address") 42 | :city (field-required-p stanza "city") 43 | :state (field-required-p stanza "state") 44 | :zip (field-required-p stanza "zip") 45 | :phone (field-required-p stanza "phone") 46 | :url (field-required-p stanza "url") 47 | :date (field-required-p stanza "date") 48 | :misc (field-required-p stanza "misc") 49 | :text (field-required-p stanza "text") 50 | :key (field-required-p stanza "key")))) 51 | ;; helper 52 | (field-required-p ((stanza) field-name) 53 | (get-element-by-name (dom:first-child (xml-node stanza)) field-name))))))) 54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/client/session.lisp: -------------------------------------------------------------------------------- 1 | ;;;; session.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | ;; (defclass session (client) 11 | ;; ((mechanism :accessor mechanism :initarg :mechanism :initform nil) 12 | ;; (xeps-list :accessor xeps-list :initarg :xeps-list :initform nil) 13 | ;; (domains :accessor domains :initarg :domains :initform nil))) 14 | 15 | ;; (defun create-session (&key server-hostname (server-port 5222) 16 | ;; username password (mechanism nil) (debuggable nil) 17 | ;; (xeps-list nil)) 18 | ;; "Creates a new connection to server, logs in, and uses xeps 19 | ;; from XEPS-LIST. When XEPS-LIST is NIL, all available xeps will be used." 20 | ;; (use-xeps xeps-list) 21 | ;; (make-instance 'session 22 | ;; :server-hostname server-hostname 23 | ;; :server-port server-port 24 | ;; :username username 25 | ;; :password password 26 | ;; :xeps-list xeps-list 27 | ;; :mechanism mechanism 28 | ;; :debuggable debuggable)) 29 | 30 | ;; (defmethod open-session ((session session)) 31 | ;; "Creates a new connection to the server, logs in. After this 32 | ;; step you can send and receive stanzas. 33 | ;; Exceptional situations: 34 | ;; If SERVER-HOSTNAME is wrong or not available, an error of type 35 | ;; CL-NGXMPP:CONNECTION-ERROR is signaled. If SERVER-PORT is closed 36 | ;; on SERVER-HOSTNAME, an error of type CL-NGXMPP:CONNECTION-ERROR is signaled. 37 | ;; If authorize step is failed for any reason, an error of type 38 | ;; CL-NGXMPP:NEGOTIATE-SASL-ERROR is signaled." 39 | ;; (with-slots (username password mechanism xml-stream) session 40 | ;; (connect session) 41 | ;; (when (xmpp%:openedp xml-stream) 42 | ;; (authorize session 43 | ;; :username username 44 | ;; :password password 45 | ;; :mechanism mechanism)))) 46 | 47 | ;; (defmethod close-session ((session session)) 48 | ;; (disconnect session)) 49 | 50 | 51 | ;; New API 52 | 53 | ;; (defclass session () 54 | ;; ((client :accessor client :initarg :client :initform nil) 55 | ;; (xeps-list :accessor xeps-list :initarg :xeps-list :initform nil) 56 | ;; (domains :accessor domains :initarg :domains :initform nil) 57 | ;; (hooks :accessor hooks :initarg :hooks :initform nil))) 58 | 59 | ;; (defun open-session (&key server-hostname (server-port 5222) 60 | ;; username password (mechanism nil) (debuggable nil) 61 | ;; (xeps-list nil) (hooks nil)) 62 | ;; (let ((client (make-instance 'client))) 63 | ;; (xmpp%::chain-statefull 64 | ;; (connect-client client 65 | ;; :server-hostname server-hostname 66 | ;; :server-port server-port) 67 | ;; ((connectedp client) (login-client client 68 | ;; :username username 69 | ;; :password password 70 | ;; :mechanism mechanism))))) 71 | 72 | 73 | -------------------------------------------------------------------------------- /src/core/adapters/iolib-adapter.lisp: -------------------------------------------------------------------------------- 1 | ;;;; usocket-adapter.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | 9 | ;; 10 | ;; Actually this adapter doesn't work because of problem 11 | ;; with underlying fd which is returned from cl+ssl:make-ssl-client-stream 12 | ;; function. Discussion about this issue you can find on this url: 13 | ;; http://www.reddit.com/r/lisp/comments/1q3kvs/clssl_and_iolib_problem/ 14 | ;; 15 | ;; But anyway I think the problem can be solved somehow ;). 16 | ;; 17 | 18 | (in-package #:cl-ngxmpp) 19 | 20 | (defparameter *timeout* 5) 21 | 22 | (defclass iolib-adapter (adapter) 23 | ((event-base :accessor event-base :initarg :event-base :initform nil))) 24 | 25 | (defmethod adapter-open-connection ((adapter iolib-adapter) hostname port) 26 | (let ((socket-stream (iolib.sockets:make-socket :connect :active 27 | :address-family :internet 28 | :ipv6 nil 29 | :type :stream 30 | :external-format '(:utf-8 :eol-style :crlf)))) 31 | (iolib.sockets:connect socket-stream 32 | (iolib.sockets:lookup-hostname hostname) 33 | :port port) 34 | (setf (socket-stream adapter) socket-stream 35 | (event-base adapter) (make-instance 'iolib.multiplex:event-base 36 | :exit-when-empty t)))) 37 | 38 | (defmethod adapter-close-connection ((adapter iolib-adapter)) 39 | (with-slots (event-base socket-stream) adapter 40 | (close event-base) 41 | (close socket-stream :abort t))) 42 | 43 | (defmethod async-read/write% ((adapter iolib-adapter) event-type function) 44 | (let* ((future (cl-async-future:make-future)) 45 | (event-base (event-base adapter)) 46 | (socket-stream (socket-stream adapter)) 47 | (cb (funcall function future event-base socket-stream))) 48 | (iolib.multiplex:set-io-handler event-base 49 | (iolib.sockets:socket-os-fd socket-stream) 50 | event-type cb 51 | :timeout *timeout*) 52 | (iolib.multiplex:event-dispatch event-base :one-shot t) 53 | future)) 54 | 55 | (defmethod adapter-read-from-stream ((adapter iolib-adapter) &key stanza-reader) 56 | (async-read/write% adapter :read 57 | #'(lambda (future event-base socket-stream) 58 | (lambda (fd event exception) 59 | (iolib.multiplex:remove-fd-handlers event-base fd :write t :read t :error t) 60 | (cl-async-future:finish 61 | future 62 | (result (stanza-reader-read-stream (make-instance stanza-reader :stanza-stream socket-stream)))))))) 63 | 64 | (defmethod adapter-write-to-stream ((adapter iolib-adapter) string) 65 | (async-read/write% adapter :write 66 | #'(lambda (future event-base socket-stream) 67 | (lambda (fd event exception) 68 | (iolib.multiplex:remove-fd-handlers event-base fd :write t :read t :error t) 69 | (write-string string socket-stream) 70 | (force-output socket-stream) 71 | (cl-async-future:finish future))))) 72 | 73 | -------------------------------------------------------------------------------- /src/client/examples/groupchat-bot.lisp: -------------------------------------------------------------------------------- 1 | ;;;; groupchat-bot.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (defpackage #:cl-ngxmpp-client.examples.groupchat-bot 9 | (:use #:cl) 10 | (:import-from #:cl-ngxmpp-client #:define-stanza-handler) 11 | (:export #:connect #:join-room #:exit-room)) 12 | 13 | (in-package #:cl-ngxmpp-client.examples.groupchat-bot) 14 | 15 | (defvar *client* nil) 16 | 17 | (xmpp:use-xeps '("delayed-delivery" 18 | "multi-user-chat")) 19 | 20 | ;; 21 | ;; Standard set of handlers. 22 | ;; 23 | (define-stanza-handler ((stanza stanza)) 24 | (write-line "Default handler.")) 25 | 26 | (define-stanza-handler ((stanza presence-show-stanza)) 27 | (let ((from (xmpp%:from stanza)) 28 | (to (xmpp%:to stanza)) 29 | (show (xmpp%:show stanza))) 30 | (write-line (format nil "Presence ~A -> ~A: ~A" from to show)))) 31 | 32 | (define-stanza-handler ((stanza presence-subscribe-stanza)) 33 | (let ((from (xmpp%:from stanza)) 34 | (status (xmpp%:status stanza))) 35 | (write-line (format nil "Presence ~A wants to subscribe to you, with status ~A" 36 | from status)))) 37 | 38 | (define-stanza-handler ((stanza iq-get-stanza)) 39 | (let ((from (xmpp%:from stanza)) 40 | (to (xmpp%:to stanza)) 41 | (id (xmpp%:id stanza)) 42 | (stanza-type (xmpp%:stanza-type stanza))) 43 | (write-line (format nil "IQ ~A (~A) ~A -> ~A" id stanza-type from to)))) 44 | 45 | (define-stanza-handler ((stanza iq-result-stanza)) 46 | (let ((id (xmpp%:id stanza)) 47 | (stanza-type (xmpp%:stanza-type stanza)) 48 | (to (xmpp%:to stanza)) 49 | (from (xmpp%:from stanza))) 50 | (write-line (format nil "IQ ~A (~A) ~A -> ~A" id stanza-type from to)))) 51 | 52 | ;; 53 | ;; XEP (Multi User Chat) related handlers. 54 | ;; 55 | (define-stanza-handler ((stanza message-groupchat-stanza) :xep multi-user-chat) 56 | (let ((body (xmpp%:body stanza)) 57 | (from (xmpp%:from stanza)) 58 | (to (xmpp%:to stanza))) 59 | (write-line (format nil "MUC message: ~A -> ~A: ~A" from to body)))) 60 | 61 | (define-stanza-handler ((stanza message-groupchat-stanza) :xep delayed-delivery) 62 | (write-line (format nil "MUC delayed message: ~A: ~A" 63 | (xmpp%:stamp stanza) (xmpp%:delay-from stanza)))) 64 | 65 | (define-stanza-handler ((stanza presence-user-stanza) :xep multi-user-chat) 66 | (let ((affiliation (xmpp%:affiliation stanza)) 67 | (role (xmpp%:role stanza)) 68 | (from (xmpp%:from stanza)) 69 | (to (xmpp%:to stanza))) 70 | (write-line (format nil "MUC User presence: ~A -> ~A, affil: ~A, role: ~A" 71 | from to affiliation role)))) 72 | 73 | (define-stanza-handler ((stanza presence-user-self-stanza) :xep multi-user-chat) 74 | (write-line (format nil "MUC user self presence, roster ends: ~A" (xmpp%:statuses stanza)))) 75 | 76 | (defun connect (&key server-hostname username password) 77 | (unless (null *client*) 78 | (xmpp:disconnect *client*)) 79 | (setf *client* (make-instance 'xmpp:client :server-hostname server-hostname)) 80 | (xmpp:connect *client*) 81 | (xmpp:authorize *client* :username username :password password)) 82 | 83 | 84 | (defun join-room (&key conference nickname) 85 | (xmpp:call-methods-with-xep (multi-user-chat) 86 | ((send-presence-join *client* 87 | :conference conference 88 | :nickname nickname))) 89 | (xmpp:proceed-stanza-loop *client*)) 90 | 91 | (defun exit-room (&key conference nickname) 92 | (xmpp:call-methods-with-xep (multi-user-chat) 93 | ((send-presence-exit *client* 94 | :conference conference 95 | :nickname nickname))) 96 | (xmpp:proceed-stanza-loop *client*)) 97 | -------------------------------------------------------------------------------- /tests/core/usocket-adapter-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; usocket-adapter-test.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-test) 9 | 10 | (deftestsuite usocket-adapter-test (cl-ngxmpp-test) 11 | ((adapter (make-instance 'xmpp%:usocket-adapter)) 12 | (hostname "ch3kr.net") 13 | (port 5222)) 14 | (:teardown (when (xmpp%::adapter-connectedp adapter) 15 | (xmpp%::adapter-close-connection adapter)))) 16 | 17 | 18 | (deftestsuite usocket-adapter-connectedp-test (usocket-adapter-test) 19 | ()) 20 | 21 | (addtest (usocket-adapter-connectedp-test) 22 | connected-adapter 23 | (progn 24 | (xmpp%::adapter-open-connection adapter hostname port) 25 | (ensure (xmpp%::adapter-connectedp adapter)))) 26 | 27 | (addtest (usocket-adapter-connectedp-test) 28 | closed-adapter 29 | (ensure-null (xmpp%::adapter-connectedp adapter))) 30 | 31 | 32 | (deftestsuite usocket-adapter-open-test (usocket-adapter-test) 33 | ()) 34 | 35 | (addtest (usocket-adapter-open-test) 36 | correct-open-test 37 | (progn 38 | (xmpp%::adapter-open-connection adapter hostname port) 39 | (ensure (xmpp%::adapter-connectedp adapter)))) 40 | 41 | (addtest (usocket-adapter-open-test) 42 | incorrect-hostname-open-test 43 | (ensure-condition xmpp%:connection-error 44 | (xmpp%::adapter-open-connection adapter "unknown.unknown" port))) 45 | 46 | (addtest (usocket-adapter-open-test) 47 | incorrect-port-open-test 48 | (ensure-condition xmpp%:connection-error 49 | (xmpp%::adapter-open-connection adapter hostname 123))) 50 | 51 | 52 | (deftestsuite usocket-adapter-close-test (usocket-adapter-test) 53 | () 54 | (:setup (xmpp%::adapter-open-connection adapter hostname port))) 55 | 56 | (addtest (usocket-adapter-close-test) 57 | close-correct-opened-adapter 58 | (progn 59 | (xmpp%::adapter-close-connection adapter) 60 | (ensure-null (xmpp%::adapter-connectedp adapter)))) 61 | 62 | (addtest (usocket-adapter-close-test) 63 | close-closed-adapter 64 | (progn 65 | (xmpp%::adapter-close-connection adapter) 66 | (xmpp%::adapter-close-connection adapter) 67 | (ensure-null (xmpp%::adapter-connectedp adapter)))) 68 | 69 | 70 | (deftestsuite usocket-adapter-read/write-stream-test (usocket-adapter-test) 71 | ((stream-header "") 72 | (stream-open "") 77 | (stream-close "")) 78 | (:setup (xmpp%::adapter-open-connection adapter hostname port))) 79 | 80 | (addtest (usocket-adapter-read/write-stream-test) 81 | write-to-opened-connection 82 | (ensure (xmpp%::adapter-write-to-stream adapter stream-header))) 83 | 84 | #+sbcl 85 | (addtest (usocket-adapter-read/write-stream-test) 86 | write-to-closed-connection 87 | (progn 88 | (xmpp%::adapter-close-connection adapter) 89 | (ensure-condition sb-int:closed-stream-error 90 | (xmpp%::adapter-write-to-stream adapter "")))) 91 | 92 | (addtest (usocket-adapter-read/write-stream-test) 93 | read-from-opened-stream 94 | (progn 95 | (xmpp%::adapter-write-to-stream adapter "") 96 | (ensure-same (xmpp%:resolve-async-value 97 | (xmpp%::adapter-read-from-stream adapter 98 | :stanza-reader 'xmpp%:stanza-reader-header)) 99 | stream-header))) 100 | 101 | (addtest (usocket-adapter-read/write-stream-test) 102 | read-from-closed-stream 103 | (progn 104 | (xmpp%::adapter-write-to-stream adapter "") 105 | (xmpp%::adapter-read-from-stream adapter :stanza-reader 'xmpp%:stanza-reader-header) 106 | (xmpp%::adapter-write-to-stream adapter stream-open) 107 | (xmpp%::adapter-read-from-stream adapter :stanza-reader 'xmpp%:stanza-reader-features) 108 | (xmpp%::adapter-write-to-stream adapter stream-close) 109 | (ensure-condition xmpp%:stanza-reader-error 110 | (xmpp%:resolve-async-value 111 | (xmpp%::adapter-read-from-stream 112 | adapter 113 | :stanza-reader 'xmpp%:stanza-reader)) 114 | ""))) 115 | -------------------------------------------------------------------------------- /src/core/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utils.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; Useful classes to inherit from 13 | ;; 14 | 15 | (defclass statefull () 16 | ((state :accessor state :initarg :state :initform nil))) 17 | 18 | (defclass debuggable () 19 | ((debuggable :accessor debuggable :initarg :debuggable :initform nil))) 20 | 21 | (defmethod print-debug ((debuggable debuggable) format &rest args) 22 | (when (debuggable debuggable) 23 | (write-string "[DEBUG]: ") 24 | (write-line (apply #'format nil format args) *debug-io*) 25 | (force-output *debug-io*))) 26 | 27 | ;; (defmacro chain-statefull (init-clause &body chain) 28 | ;; (labels ((unflat-chain (chain) 29 | ;; (if (null chain) 30 | ;; nil 31 | ;; (let ((next-clause (car chain))) 32 | ;; (if (= (length next-clause) 2) 33 | ;; (let* ((predicate (first next-clause)) 34 | ;; (action (second next-clause)) 35 | ;; (unflatten (unflat-chain (cdr chain))) 36 | ;; (actions (cond ((eq (first action) 'let) 37 | ;; `(,@action ,unflatten)) 38 | ;; (t `(,@(cons action unflatten)))))) 39 | 40 | ;; `(when ,predicate ,actions)) 41 | ;; (error "The clause ~A has a wrong format" next-clause)))))) 42 | ;; (let ((unflatten-chain (unflat-chain chain))) 43 | ;; `(progn 44 | ;; (unless (null ,init-clause) 45 | ;; ,init-clause) 46 | ;; ,unflatten-chain)))) 47 | 48 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 49 | ;; 50 | ;; Misc utils 51 | ;; 52 | 53 | (defmacro string-case (string &body cases) 54 | "I just didn't find a simple solution for case with strings, 55 | so I wrote this ugly and I think very slow macro. If you know 56 | a better way tell me, please." 57 | `(cond ,@(mapcar #'(lambda (case) 58 | (if (eq (car case) :default) 59 | (list 't (cadr case)) 60 | (list (list 'string= string (car case)) (cadr case)))) 61 | cases))) 62 | 63 | (defun string-to-keyword (string) 64 | (multiple-value-bind (keyword-name keyword-status) 65 | (values (intern (string-upcase string) :keyword)) 66 | (declare (ignore keyword-status)) 67 | keyword-name)) 68 | 69 | ;; 70 | ;; It allows us not to worry about underlying adapters (usocket, iolib, etc) 71 | ;; which can act in blocking or asynchronous ways. 72 | ;; 73 | (defun resolve-async-value (av) 74 | (cond ((not (bb:promisep av)) av) 75 | (t (let ((ret "")) 76 | (bb:alet ((v av)) 77 | (setf ret v)) 78 | ret)))) 79 | 80 | ;; 81 | ;; To use a condition with a WITH-PROXY-ERROR macro, 82 | ;; it should be a successor of a PROXY-ERROR condition. 83 | ;; 84 | ;; In this example: 85 | ;; 86 | ;; (with-proxy-error connection-error 87 | ;; (end-of-file) 88 | ;; (print (read-char in))) 89 | ;; 90 | ;; CONNECTION-ERROR will be thrown if READ-CHAR will cause the END-OF-FILE, 91 | ;; and original instance of END-OF-FILE will be saved in the ORIGINAL-ERROR 92 | ;; slot of the CONNECTION-ERROR. 93 | ;; 94 | (define-condition proxy-error (simple-condition) 95 | ((original-error :accessor original-error :initarg :original-error :initform nil))) 96 | 97 | (defmacro with-proxy-error (error (&rest proxied-errors) &body form) 98 | (let ((expanded-cases 99 | (mapcar #'(lambda (c) 100 | `(,c (e) (error (make-condition ',error 101 | :original-error e 102 | :format-control "Original error: ~A" 103 | :format-arguments (list e))))) 104 | proxied-errors))) 105 | `(handler-case 106 | (progn ,@form) 107 | ,@expanded-cases))) 108 | -------------------------------------------------------------------------------- /src/xeps/xep-0045.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xep-0045.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-xeps) 9 | 10 | (define-xep (multi-user-chat :order "0045" 11 | :description "XEP 0045, Multi User Chat") 12 | 13 | ((message-groupchat-stanza (message-stanza) 14 | () 15 | 16 | (:methods 17 | ((xml-to-stanza ((stanza) dispatchers) 18 | (let ((disp (dispatch-stanza stanza 'multi-user-chat-message-groupchat-stanza dispatchers))) 19 | (if (typep disp 'unknown-stanza) 20 | stanza 21 | disp))) 22 | 23 | (stanza-to-xml ((stanza)) 24 | (with-message-stanza (stanza)))) 25 | 26 | :dispatcher ((stanza) 27 | (let* ((message-node (dom:first-child (xml-node stanza))) 28 | (stanza-type (dom:get-attribute message-node "type"))) 29 | (equalp stanza-type "groupchat"))))) 30 | 31 | 32 | (presence-join-stanza (presence-stanza) 33 | ((x-xmlns "http://jabber.org/protocol/muc")) 34 | 35 | (:methods 36 | ((stanza-to-xml ((stanza)) 37 | (with-presence-stanza (stanza) 38 | (cxml:with-element "x" 39 | (cxml:attribute "xmlns" (x-xmlns stanza)))))))) 40 | 41 | 42 | (presence-exit-stanza (presence-stanza) 43 | ((stanza-type "unavailable")) 44 | 45 | (:methods 46 | ((stanza-to-xml ((stanza)) 47 | (call-next-method stanza))))) 48 | 49 | (presence-user-stanza (presence-stanza) 50 | ((x-xmlns "http://jabber.org/protocol/muc#user") 51 | (affiliation "member") 52 | (role "participant") 53 | jid) 54 | 55 | (:methods 56 | ((xml-to-stanza ((stanza) dispatchers) 57 | (let* ((x-node (get-x-node stanza)) 58 | (item-node (get-element-by-name x-node "item")) 59 | (affiliation (dom:get-attribute item-node "affiliation")) 60 | (role (dom:get-attribute item-node "role")) 61 | (disp (dispatch-stanza stanza 'multi-user-chat-presence-user-stanza dispatchers))) 62 | (if (typep disp 'unknown-stanza) 63 | (progn 64 | (setf (affiliation stanza) affiliation 65 | (role stanza) role) 66 | stanza) 67 | disp))) 68 | 69 | (make-stanza ((stanza) class-name) 70 | (let* ((item-node (get-element-by-name (get-x-node stanza) "item")) 71 | (affiliation (dom:get-attribute item-node "affiliation")) 72 | (role (dom:get-attribute item-node "role"))) 73 | (xml-to-stanza (make-instance 'multi-user-chat-presence-user-self-stanza 74 | :xml-node (xml-node stanza) 75 | :to (to stanza) 76 | :from (from stanza) 77 | :id (id stanza) 78 | :affiliation affiliation 79 | :role role) 80 | dispatchers))) 81 | 82 | ;; Helper for searhing "x" element with particular xmlns attr. 83 | (get-x-node ((stanza)) 84 | (let ((xs (remove-if #'(lambda (x-node) 85 | (not (equalp (dom:get-attribute x-node "xmlns") 86 | "http://jabber.org/protocol/muc#user"))) 87 | (get-elements-by-name (dom:first-child (xml-node stanza)) "x")))) 88 | (when xs 89 | (car xs))))) 90 | 91 | :dispatcher ((stanza) 92 | (get-x-node (make-instance 'multi-user-chat-presence-user-stanza 93 | :xml-node (xml-node stanza)))))) 94 | 95 | (presence-user-self-stanza (multi-user-chat-presence-user-stanza) 96 | (statuses) 97 | 98 | (:methods 99 | ((xml-to-stanza ((stanza) dispatchers) 100 | (let* ((x-node (get-element-by-name (dom:first-child (xml-node stanza)) "x")) 101 | (status-nodes (get-elements-by-name x-node "status"))) 102 | (loop :for status-node :in status-nodes 103 | :do (push (dom:get-attribute status-node "code") (statuses stanza))) 104 | stanza))) 105 | 106 | :dispatcher ((stanza) 107 | (let ((x-node (get-element-by-name (dom:first-child (xml-node stanza)) "x"))) 108 | (get-elements-by-name x-node "status"))))))) 109 | -------------------------------------------------------------------------------- /tests/core/xml-stream-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xml-stream-test.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-test) 9 | 10 | (defun write-data (str stream) 11 | (write str :stream stream) 12 | (force-output stream)) 13 | 14 | (defun stanza-reader-read (stream &key (reader 'xmpp%:stanza-reader)) 15 | (xmpp%:stanza-reader-read-stream 16 | (make-instance reader :stanza-stream stream))) 17 | 18 | 19 | (deftestsuite xml-stream-test (cl-ngxmpp-test) 20 | ()) 21 | 22 | 23 | (deftestsuite xml-stream-actions-test (xml-stream-test) 24 | ((xml-stream nil) 25 | (connection (make-instance 'xmpp%:connection 26 | :adapter (make-instance 'xmpp%:usocket-adapter) 27 | :hostname "ch3kr.net" 28 | :port 5222)) 29 | (debuggable nil)) 30 | (:setup (progn 31 | (xmpp%:open-connection connection) 32 | (when (xmpp%:connectedp connection) 33 | (setf xml-stream (make-instance 'xmpp%:xml-stream 34 | :connection connection 35 | :debuggable debuggable)))))) 36 | 37 | 38 | (deftestsuite xml-stream-actions-open-stream-test (xml-stream-actions-test) 39 | () 40 | (:teardown (when (xmpp%:openedp xml-stream) 41 | (xmpp%:close-stream xml-stream) 42 | (when (xmpp%:connectedp connection) 43 | (xmpp%:close-connection connection))))) 44 | 45 | (addtest (xml-stream-actions-open-stream-test) 46 | open-stream-with-opened-connection 47 | (progn 48 | (xmpp%:open-stream xml-stream) 49 | (ensure (xmpp%:openedp xml-stream)))) 50 | 51 | #+sbcl 52 | (addtest (xml-stream-actions-open-stream-test) 53 | open-stream-with-closed-connection 54 | (progn 55 | (xmpp%:close-connection (xmpp%::connection xml-stream)) 56 | (ensure-condition sb-int:closed-stream-error (xmpp%:open-stream xml-stream)))) 57 | 58 | 59 | (deftestsuite xml-stream-stanza-reader-test (xml-stream-test) 60 | ((filespec #P"reader-test") 61 | (stream-out nil) 62 | (stream-in nil) 63 | (correct-xml "dog") 64 | (incorrect-xml "") 65 | (empty-xml "")) 66 | (:setup (progn 67 | (setf stream-out (open filespec 68 | :direction :output 69 | :element-type 'character 70 | :if-does-not-exist :create)) 71 | (setf stream-in (open filespec :element-type 'character)))) 72 | (:teardown (progn 73 | (close stream-out) 74 | (close stream-in) 75 | (delete-file filespec)))) 76 | 77 | (addtest (xml-stream-stanza-reader-test) 78 | read-correct-xml 79 | (progn 80 | (write-data correct-xml stream-out) 81 | (ensure-null (not (xmpp%::result (stanza-reader-read stream-in)))))) 82 | 83 | (addtest (xml-stream-stanza-reader-test) 84 | read-incorrect-xml 85 | (progn 86 | (write-data incorrect-xml stream-out) 87 | (ensure-condition xmpp%:stanza-reader-error (stanza-reader-read stream-in)))) 88 | 89 | (addtest (xml-stream-stanza-reader-test) 90 | read-empty-xml 91 | (progn 92 | (write-data empty-xml stream-out) 93 | (ensure-condition xmpp%:stanza-reader-error (stanza-reader-read stream-in)))) 94 | 95 | 96 | (deftestsuite xml-stream-stanza-reader-header-test (xml-stream-stanza-reader-test) 97 | ((correct-header ""))) 98 | 99 | (addtest (xml-stream-stanza-reader-header-test) 100 | read-correct-header-depth 101 | (progn 102 | (write-data correct-header stream-out) 103 | (let ((reader (stanza-reader-read stream-in 104 | :reader 'xmpp%:stanza-reader-header))) 105 | (ensure-same 1 (xmpp%::depth reader))))) 106 | 107 | (addtest (xml-stream-stanza-reader-header-test) 108 | read-correct-header-state 109 | (progn 110 | (write-data correct-header stream-out) 111 | (ensure-same :node-opened 112 | (xmpp%::state (stanza-reader-read 113 | stream-in 114 | :reader 'xmpp%:stanza-reader-header))))) 115 | 116 | 117 | (deftestsuite xml-stream-stanza-reader-features-test (xml-stream-stanza-reader-test) 118 | ((correct-features " 119 | ") 120 | (incorrect-features ""))) 121 | 122 | (addtest (xml-stream-stanza-reader-features-test) 123 | read-correct-features-state 124 | (progn 125 | (write-data correct-features stream-out) 126 | (ensure-same :node-closed 127 | (xmpp%::state (stanza-reader-read 128 | stream-in 129 | :reader 'xmpp%:stanza-reader-features))))) 130 | 131 | (addtest (xml-stream-stanza-reader-features-test) 132 | read-incorrect-features 133 | (progn 134 | (write-data incorrect-features stream-out) 135 | (ensure-condition xmpp%:stanza-reader-error 136 | (stanza-reader-read stream-in 137 | :reader 'xmpp%:stanza-reader-features)))) 138 | 139 | -------------------------------------------------------------------------------- /src/core/sasl-negotiation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sasl-negotiation.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package :cl-ngxmpp) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; Stanzas 13 | ;; 14 | 15 | (defstanza sasl-element (meta-element) 16 | (identity-string (xmlns "urn:ietf:params:xml:ns:xmpp-sasl")) 17 | 18 | (xml-to-stanza ((stanza) dispatchers) 19 | (let* ((xml-node (xml-node stanza)) 20 | (response-node (dom:first-child xml-node))) 21 | (setf (xmlns stanza) (dom:get-attribute response-node "xmlns")) 22 | stanza))) 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (defstanza sasl-auth-element (sasl-element) 27 | ((mechanism "DIGEST-MD5")) 28 | 29 | (stanza-to-xml ((stanza)) 30 | (cxml:with-element "auth" 31 | (cxml:attribute "xmlns" (xmlns stanza)) 32 | (cxml:attribute "mechanism" (mechanism stanza)) 33 | (unless (null (identity-string stanza)) 34 | (cxml:text (identity-string stanza)))))) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | 38 | (defstanza sasl-response-element (sasl-element) 39 | () 40 | 41 | (stanza-to-xml ((stanza)) 42 | (cxml:with-element "response" 43 | (cxml:attribute "xmlns" (xmlns stanza)) 44 | (unless (null (identity-string stanza)) 45 | (cxml:text (identity-string stanza)))))) 46 | 47 | ;; 48 | ;; The end of stanzas 49 | ;; 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | 52 | (defstanza sasl-challenge-element (sasl-element) 53 | () 54 | 55 | (print-object ((obj) stream) 56 | (print-unreadable-object (obj stream :type t :identity t) 57 | (format stream "identity-string: ~A" (identity-string obj)))) 58 | 59 | (xml-to-stanza ((stanza) dispatchers) 60 | (let ((xml-node (xml-node stanza))) 61 | (setf (identity-string stanza) 62 | (base64:base64-string-to-string 63 | (dom:data (dom:first-child (dom:first-child xml-node))))) 64 | stanza))) 65 | 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | ;; 68 | ;; Because cl-sasl library doesn't support SCRAM-SHA-1 and SCRAM-SHA-1-PLUS 69 | ;; mechanisms we are forced to support old and week PLAIN and DIGEST-MD5 70 | ;; 71 | ;; Ordered list of SASL mechanisms. 72 | ;; 73 | (defparameter *sasl-mandatory-mechanisms* 74 | '("DIGEST-MD5" "PLAIN")) 75 | 76 | (define-condition negotiate-sasl-error (simple-condition) 77 | ((failure-stanza :accessor failure-stanza :initarg :failure-stanza :initform nil))) 78 | 79 | (defmethod negotiate-sasl ((xml-stream xml-stream) &key username password mechanism) 80 | (let* ((sasl-mechanism (sasl:get-mechanism (%choose-mechanism% mechanism))) 81 | (sasl-client (make-instance sasl-mechanism 82 | :authentication-id username 83 | :password password 84 | :service "xmpp" 85 | :host (hostname (connection xml-stream)))) 86 | (negotiation-result (string-case sasl-mechanism 87 | ("PLAIN" (%sasl-plain-negotiation% xml-stream sasl-client)) 88 | ("DIGEST-MD5" (%sasl-digest-md5-negotiation% xml-stream sasl-client))))) 89 | (cond ((typep negotiation-result 'success-element) 90 | (restart-stream xml-stream) 91 | (setf (state xml-stream) 'sasl-negotiated)) 92 | ((typep negotiation-result 'failure-element) 93 | (%sasl-fail% negotiation-result))))) 94 | 95 | ;; TODO: improve algorithm, now it's so dumb. 96 | (defun %choose-mechanism% (mechanism) 97 | (if (null mechanism) 98 | (car *sasl-mandatory-mechanisms*) 99 | mechanism)) 100 | 101 | (defun %sasl-fail% (failure) 102 | (error (make-condition 'negotiate-sasl-error 103 | :failure-stanza failure 104 | :format-control "SASL failed: ~A" 105 | :format-arguments (list failure)))) 106 | 107 | (defmethod %sasl-plain-negotiation% ((xml-stream xml-stream) sasl-client) 108 | (print (cl-sasl::password sasl-client)) 109 | (let ((step-response (base64:usb8-array-to-base64-string 110 | ;; BUG: I found a bug in cl+ssl. 111 | ;; A client-step throws an error about that a 112 | ;; server-input is nil, but in the client-step 113 | ;; the server-input argument is ignored. 114 | (sasl:client-step sasl-client nil)))) 115 | (with-stanza-output (xml-stream) 116 | (make-instance 'sasl-auth-element 117 | :mechanism "PLAIN" 118 | :identity-string step-response)) 119 | ;; dispatchers argument should be ommited. 120 | (with-stanza-input (xml-stream success-element nil) 121 | success-element))) 122 | 123 | (defmethod %sasl-digest-md5-negotiation% ((xml-stream xml-stream) sasl-client) 124 | (with-stanza-output (xml-stream) 125 | (make-instance 'sasl-auth-element :mechanism "DIGEST-MD5")) 126 | (with-stanza-input (xml-stream first-challenge-stanza nil) 127 | (cond ((typep first-challenge-stanza 'sasl-challenge-element) 128 | (let ((response (base64:usb8-array-to-base64-string 129 | (sasl:client-step 130 | sasl-client 131 | (babel:string-to-octets (identity-string first-challenge-stanza)))))) 132 | (with-stanza-output (xml-stream) ;; Send 133 | (make-instance 'sasl-response-element :identity-string response)) 134 | (with-stanza-input (xml-stream second-challenge-stanza nil) ;; Receive second 135 | (cond ((typep second-challenge-stanza 'sasl-challenge-element) 136 | (with-stanza-output (xml-stream) ;; Send second and last 137 | (make-instance 'sasl-response-element)) 138 | (with-stanza-input (xml-stream success-element nil) ;; Receive 139 | success-element)) 140 | ((typep second-challenge-stanza 'failure-element) (%sasl-fail% second-challenge-stanza)))))) 141 | ((typep first-challenge-stanza 'failure-element) (%sasl-fail% first-challenge-stanza))))) 142 | -------------------------------------------------------------------------------- /src/xeps/xep-0004.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xep-0004.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-xeps) 9 | 10 | (define-xep (data-forms :order "0004" 11 | :description "XEP 0004, Data Forms") 12 | 13 | ;; 14 | ;; Current XEP contains no 'stanzas', instead it contains regular xml-elements 15 | ;; with the same meaning as the `stream-element` "stanza" has. 16 | ;; 17 | ;; All elements presented here actually are building blocks for other "stanzas", 18 | ;; it means that they will never be a top-level element (child of ""). 19 | ;; 20 | ;; Also, in fact this code serializes/deserializes from/to XML and does nothing else 21 | ;; according to the given XML Schema -- http://xmpp.org/extensions/xep-0004.html#schema, 22 | ;; and I believe that the rest of XMPP also shouldn't contain additional logic, so my 23 | ;; idea is to generate such code using "XSD to S-exp" generator. 24 | ;; 25 | 26 | ((x-element (meta-element) 27 | ((xmlns "jabber:x:data") 28 | x-type 29 | title 30 | instructions 31 | fields 32 | reported 33 | items) 34 | 35 | (:methods 36 | ((xml-to-stanza ((stanza) dispatchers) 37 | (with-slots (xml-node) stanza 38 | (setf (x-type stanza) (dom:get-attribute xml-node "type") 39 | (title stanza) (get-element-data (get-element-by-name xml-node "title")) 40 | (intructions stanza) (mapcar #'get-element-data 41 | (get-elements-by-name xml-node "instructions")) 42 | (fields stanza) (mapcar #'(lambda (el) 43 | (xml-to-stanza (make-instance 'data-forms-field-element 44 | :xml-node el) 45 | dispatchers)) 46 | (get-elements-by-name xml-node "field")) 47 | (reported stanza) (let ((el get-element-by-name xml-node "reported")) 48 | (when el 49 | (xml-to-stanza (make-instance 'data-forms-reported-element 50 | :xml-node el) 51 | dispatchers))) 52 | (items stanza) (mapcar #'(lambda (el) 53 | (xml-to-stanza (make-instance 'data-forms-item-element 54 | :xml-node el) 55 | dispatchers)) 56 | (get-elements-by-name xml-node "item"))) 57 | stanza)) 58 | 59 | (stanza-to-xml ((stanza)) 60 | (with-slots (xmlns x-type title instructions fields reported items) stanza 61 | (cxml:with-element "x" 62 | (cxml:attribute "xmlns" xmlns) 63 | (cxml:attribute "type" x-type) 64 | (mapcar #'(lambda (i) (cxml:with-element "instructions" 65 | (cxml:text i))) 66 | instructions) 67 | (mapcar #'stanza-to-xml fields) 68 | (unless (null reported) 69 | (stanza-to-xml reported)) 70 | (mapcar #'stanza-to-xml items))))))) 71 | 72 | 73 | (field-element (meta-element) 74 | (desc required field-values options label var element-type) 75 | 76 | (:methods 77 | ((xml-to-stanza ((stanza) dispatchers) 78 | (with-slots (xml-node) stanza 79 | (setf (desc stanza) (get-element-data (get-element-by-name xml-node "desc")) 80 | (required stanza) (not (nullp (get-element-by-name xml-node "required"))) 81 | (field-values stanza) (mapcar #'get-element-data 82 | (get-elements-by-name xml-node "value")) 83 | (options stanza) (mapcar #'(lambda (el) 84 | (xml-to-stanza (make-instance 'data-forms-field-option-element :xml-node el) 85 | dispatchers)) 86 | (get-elements-by-name xml-node "option")) 87 | (label stanza) (dom:get-attribute xml-node "label") 88 | (var stanza) (dom:get-attribute xml-node "var") 89 | (element-type stanza) (dom:get-attribute xml-node "type")) 90 | stanza)) 91 | 92 | (stanza-to-xml ((stanza)) 93 | (with-slots (desc required values options label var element-type) stanza 94 | (cxml:with-element "field" 95 | (unless (null label) 96 | (cxml:attribute "label" label)) 97 | (unless (null var) 98 | (cxml:attribute "var" var)) 99 | (unless (null element-type) 100 | (cxml:attribute "type" element-type)) 101 | (unless (null desc) 102 | (cxml:with-element "desc" 103 | (cxml:text desc))) 104 | (unless (null required) 105 | (cxml:with-element "required")) 106 | (mapcar #'(lambda (v) (cxml:with-element "value" (cxml:text v))) field-values) 107 | (mapcar #'(lambda (o) (cxml:with-element "option" (cxml:text o))) options))))))) 108 | 109 | (field-option-element (meta-element) 110 | (option-values label) 111 | 112 | (:methods 113 | ((xml-to-stanza ((stanza) dispatchers) 114 | (with-slots (xml-node) stanza 115 | (setf (option-values stanza) (mapcar #'get-element-data 116 | (get-elements-by-name xml-node "value")) 117 | (label stanza) (dom:get-attribute xml-node "label")) 118 | stanza)) 119 | 120 | (stanza-to-xml ((stanza)) 121 | (with-slots (option-values label) stanza 122 | (cxml:with-element "option" 123 | (cxml:attribute "label" label) 124 | (mapcar #'(lambda (v) 125 | (cxml:with-element "value" 126 | (cxml:text v))) 127 | option-values))))))) 128 | 129 | (reported/item-element (meta-element) 130 | (fields) 131 | 132 | (:methods 133 | ((xml-to-stanza ((stanza) dispatchers) 134 | (with-slots (xml-node) stanza 135 | (setf (fields stanza) 136 | (mapcar #'(lambda (f) 137 | (xml-to-stanza (make-instance 'data-forms-field-element :xml-node f) 138 | dispatchers)) 139 | (get-elements-by-name xml-node "field"))) 140 | stanza)) 141 | 142 | (stanza-to-xml ((stanza)) 143 | (with-slots (fields) stanza 144 | (cxml:with-element "reported" 145 | (mapcar #'(lambda (f) (stanza-to-xml f)) fields))))))) 146 | 147 | (item-element (reported/item-element) ()) 148 | (reported-element (reported/item-element) ()))) 149 | 150 | 151 | -------------------------------------------------------------------------------- /src/xeps/xeps.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xeps.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-xeps) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; The List of (available) XEPs. 13 | ;; 14 | ;; Structure: 15 | ;; 16 | ;; '(:xep-name xep-class ...) 17 | ;; 18 | 19 | (eval-when (:compile-toplevel :load-toplevel :execute) 20 | (defvar *xeps-list* nil)) 21 | 22 | ;; Wrappers 23 | 24 | (defun get-xep (xep-name) 25 | (getf *xeps-list* (string-to-keyword xep-name))) 26 | 27 | (defun xep-available-p (xep-name) 28 | (get-xep xep-name)) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;; 32 | ;; Attention! 33 | ;; These two function affect global state, 34 | ;; because they change *stanzas-dispatchers*. 35 | ;; 36 | 37 | ;; (defun register-xeps (names) 38 | ;; (let ((xeps-list (if (null names) 39 | ;; (loop :for (k v) :on *xeps-list* :by #'cddr 40 | ;; :collect (string-downcase (symbol-name k))) 41 | ;; names))) 42 | ;; (setf *stanzas-dispatchers* (build-stanzas-dispatchers% xeps-list nil)))) 43 | 44 | ;; WTF??? 45 | ;; (defun stop-using-xeps (names) 46 | ;; (setf *stanzas-dispatchers* 47 | ;; (remove-if #'(lambda (disp-name) 48 | ;; (member (string-downcase (symbol-name disp-name)) 49 | ;; names 50 | ;; :test #'string=)) 51 | ;; *stanzas-dispatchers*))) 52 | 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;; 55 | ;; TODO: comments 56 | ;; 57 | 58 | (defun build-stanzas-dispatchers% (xeps-list dispatchers) 59 | (labels ((find-first-dep (deps-list xeps-list) 60 | (when deps-list 61 | (let ((dep (car deps-list))) 62 | (if (member dep xeps-list :test #'equalp) 63 | dep 64 | (find-first-dep (cdr deps-list) xeps-list))))) 65 | (mapcddr (fn lyst) 66 | (when lyst 67 | (cons (funcall fn (car lyst) (cadr lyst)) 68 | (mapcddr fn (cddr lyst)))))) 69 | (if (null xeps-list) 70 | dispatchers 71 | (let* ((xep (car xeps-list)) 72 | (xep-obj (get-xep xep)) 73 | (xep-deps (mapcar #'(lambda (d) (string-downcase (symbol-name d))) (depends-on xep-obj))) 74 | (xep-dispatchers (dispatchers xep-obj)) 75 | ;; TODO: find out a simpler way 76 | (ret-dispatchers 77 | (let* ((new-disps (reduce #'append 78 | (mapcddr #'(lambda (k v) 79 | (list k (append (getf dispatchers k) v))) 80 | xep-dispatchers))) 81 | (intersect-disps (reduce #'append 82 | (mapcddr #'(lambda (k v) 83 | (let ((member-of-new-p (getf new-disps k))) 84 | (unless member-of-new-p 85 | (list k v)))) 86 | dispatchers)))) 87 | (append intersect-disps new-disps))) 88 | (first-xep-dep (find-first-dep xep-deps (cdr xeps-list)))) 89 | (if (or (null xep-deps) (null first-xep-dep)) 90 | (build-stanzas-dispatchers% (cdr xeps-list) ret-dispatchers) 91 | (let ((reordered-xeps-list (cons first-xep-dep 92 | (remove-if #'(lambda (x) 93 | (equalp x first-xep-dep)) xeps-list)))) 94 | (build-stanzas-dispatchers% reordered-xeps-list dispatchers))))))) 95 | 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | ;; 98 | ;; TODO: comments 99 | ;; 100 | 101 | (defclass xep () 102 | ((name :accessor name :initarg :name :initform nil) 103 | (order :accessor order :initarg :order :initform nil) 104 | (description :accessor description :initarg :description :initform "") 105 | (depends-on :accessor depends-on :initarg :depends-on :initform nil) 106 | (dispatchers :accessor dispatchers :initarg :dispatchers :initform nil))) 107 | 108 | (defmethod print-object ((obj xep) stream) 109 | (print-unreadable-object (obj stream :type t :identity t) 110 | (format stream "name: ~A, order: ~A, description: ~A, depends-on: ~A" 111 | (name obj) (order obj) (description obj) (depends-on obj)))) 112 | 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 114 | ;; 115 | ;; DSL that helps you to define a entire XEP in terms of stanzas and methods over them. 116 | ;; You can find examples how to use it inside `src/core/xeps/` directory. 117 | ;; 118 | ;; TODO: verification and usefull errors messages. 119 | ;; 120 | 121 | (defmacro define-xep ((xep-name &key order description depends-on) &body body) 122 | `(let* ((xep-name-string (string-downcase (symbol-name ',xep-name))) 123 | (xep-obj (make-instance 'xep 124 | :name xep-name-string 125 | :order ,order 126 | :description ,description 127 | :depends-on ',depends-on))) 128 | (setf (getf *xeps-list* (string-to-keyword xep-name-string)) xep-obj) 129 | ,@(mapcar #'(lambda (stanza-definition) 130 | `(define-xep-stanza% (,xep-name) 131 | ,stanza-definition)) 132 | (car body)))) 133 | 134 | (defmacro define-xep-stanza% ((xep-name) &body body) 135 | (let* ((stanza-repr (first body)) 136 | (stanza-name (alexandria:symbolicate `,xep-name '- (car stanza-repr))) 137 | (super-classes (second stanza-repr)) 138 | (slots (third stanza-repr)) 139 | (helpers (cadddr stanza-repr)) 140 | (methods (getf helpers :methods)) 141 | ;;(wrapper (getf helpers :wrapper)) 142 | (dispatcher (getf helpers :dispatcher)) 143 | (definitions nil)) 144 | 145 | (push 146 | `(defstanza ,stanza-name (,@super-classes) ,slots ,@methods) 147 | definitions) 148 | 149 | ;; Dispatcher 150 | ;; 151 | ;; Here we're pushing dispatcher into a structure like: 152 | ;; (dispatchers ) => (:super-class-stanza-name ((stanza-name #'lambda) ...) ...) 153 | ;; 154 | ;; TODO: 155 | ;; use hashmap instead of plist 156 | (when dispatcher 157 | (let ((dispatcher-arg (car dispatcher)) 158 | (dispatcher-body (cdr dispatcher))) 159 | (push 160 | `(loop :for super-class :in '(,@super-classes) 161 | :do (push (list ',stanza-name #'(lambda (,@dispatcher-arg) ,@dispatcher-body)) 162 | (getf (dispatchers (getf *xeps-list* (string-to-keyword (symbol-name ',xep-name)))) 163 | (string-to-keyword (symbol-name super-class))))) 164 | definitions))) 165 | (setf definitions (reverse definitions)) 166 | `(progn ,@definitions))) 167 | 168 | -------------------------------------------------------------------------------- /tests/core/stanzas-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; stanzas-test.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-test) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | 12 | (defun string-to-xml-node (str) 13 | (cxml:parse str (cxml-dom:make-dom-builder))) 14 | 15 | (defun string-to-stanza (stanza-class str) 16 | (make-instance stanza-class :xml-node (string-to-xml-node str))) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;; 20 | ;; Basic suite 21 | ;; 22 | 23 | (deftestsuite stanzas-test (cl-ngxmpp-test) 24 | ()) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;; 28 | ;; Suite for defstanza macros 29 | ;; 30 | 31 | (deftestsuite stanzas-defstanza-test (stanzas-test) 32 | ()) 33 | 34 | (deftestsuite stanzas-defstanza-method%-test (stanzas-defstanza-test) 35 | ()) 36 | 37 | (addtest (stanzas-defstanza-method%-test) 38 | wrong-method-arguments-format 39 | (ensure-condition 'xmpp%:defstanza-method%-error 40 | (macroexpand-1 41 | '(xmpp%::defstanza-method% stanza xml-to-stanza ((o (b d e) c) a) (body))))) 42 | 43 | (addtest (stanzas-defstanza-method%-test) 44 | correct-auto-addition-of-stanza-class-name-to-arguments 45 | (let* ((args (third (macroexpand-1 46 | '(xmpp%::defstanza-method% stanza 47 | xml-to-stanza ((a (c d)) a) 48 | (body))))) 49 | (arg-a (first args))) 50 | (ensure-same (second arg-a) 'stanza))) 51 | 52 | (addtest (stanzas-defstanza-method%-test) 53 | simple-arg-is-still-simple 54 | (let* ((args (third (macroexpand-1 55 | '(xmpp%::defstanza-method% stanza 56 | xml-to-stanza ((a b) c) (body))))) 57 | (arg-c (third args))) 58 | (ensure-same arg-c 'c))) 59 | 60 | 61 | (deftestsuite stanzas-defstanza-class%-test (stanzas-defstanza-test) 62 | ()) 63 | 64 | (addtest (stanzas-defstanza-class%-test) 65 | wrong-slots-format 66 | (ensure-condition 'xmpp%:defstanza-class%-error 67 | (macroexpand-1 68 | '(xmpp%::defstanza-class% stanza-error (stanza) (a (b c) (d e f)))))) 69 | 70 | (addtest (stanzas-defstanza-class%-test) 71 | slots-are-in-correct-form 72 | (ensure-no-warning 73 | (macroexpand-1 74 | '(xmpp%::defstanza-class% stanza () (a (b "initval")))))) 75 | 76 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 | ;; 78 | ;; Utils 79 | ;; 80 | 81 | (deftestsuite stanzas-xml-utils-test (stanzas-test) 82 | ((xml-node (string-to-xml-node 83 | " 84 | dog 85 | 86 | 87 | scary 88 | 89 | 90 | cat 91 | 92 | ")))) 93 | 94 | (addtest (stanzas-xml-utils-test) 95 | get-element-by-name-does-not-exists 96 | (ensure-null (xmpp%::get-element-by-name (dom:first-child xml-node) "bar3"))) 97 | 98 | (addtest (stanzas-xml-utils-test) 99 | get-element-data-does-not-exists 100 | (ensure-same "" (xmpp%::get-element-data 101 | (xmpp%::get-element-by-name (dom:first-child xml-node) "bar")))) 102 | 103 | (addtest (stanzas-xml-utils-test) 104 | get-element-data-equals 105 | (ensure-same "scary" (xmpp%::get-element-data 106 | (xmpp%::get-element-by-name 107 | (xmpp%::get-element-by-name (dom:first-child xml-node) "baz") 108 | "cat")))) 109 | 110 | (addtest (stanzas-xml-utils-test) 111 | get-element-by-name-deep-search-fail 112 | (ensure-null (xmpp%::get-element-by-name (dom:first-child xml-node) "cat"))) 113 | 114 | (addtest (stanzas-xml-utils-test) 115 | get-elements-by-name-find-bar 116 | (ensure-same 2 (length (xmpp%::get-elements-by-name (dom:first-child xml-node) "bar")))) 117 | 118 | (addtest (stanzas-xml-utils-test) 119 | get-elements-by-name-find-there-is-more-then 120 | (ensure (not (= 3 (length (xmpp%::get-elements-by-name (dom:first-child xml-node) "bar2")))))) 121 | 122 | (addtest (stanzas-xml-utils-test) 123 | get-elements-by-name-nothing 124 | (ensure-null (xmpp%::get-elements-by-name (dom:first-child xml-node) "zero"))) 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | ;; 128 | ;; dispatch-stanza function 129 | ;; 130 | 131 | ;; (deftestsuite stanzas-dispatcher-test (stanzas-test) 132 | ;; ((xeps-list '("multi-user-chat" "delayed-delivery")) 133 | ;; (groupchat-stanza-delayed 134 | ;; (string-to-stanza 'xmpp%::multi-user-chat-message-groupchat-stanza 135 | ;; "test")) 136 | ;; (groupchat-stanza 137 | ;; (string-to-stanza 'xmpp%:message-stanza 138 | ;; "test")) 139 | ;; (message-stanza-delayed 140 | ;; (string-to-stanza 'xmpp%:message-stanza 141 | ;; "test")) 142 | ;; (unknown-stanza 143 | ;; (string-to-stanza 'xmpp%:unknown-stanza ""))) 144 | ;; (:setup (xmpp%:use-xeps xeps-list)) 145 | ;; (:teardown (setf xmpp%::*stanzas-dispatchers* nil)) 146 | ;; :equality-test #'typep) 147 | 148 | ;; (addtest (stanzas-dispatcher-test) 149 | ;; unknown-stanza 150 | ;; (ensure-same (xmpp%::dispatch-stanza unknown-stanza 'xmpp%:stanza) 151 | ;; 'xmpp%:unknown-stanza 152 | ;; :test #'typep)) 153 | 154 | ;; (addtest (stanzas-dispatcher-test) 155 | ;; correct-order-1 156 | ;; (ensure-same (xmpp%::dispatch-stanza groupchat-stanza-delayed 'xmpp%::multi-user-chat-message-groupchat-stanza) 157 | ;; 'xmpp%::delayed-delivery-message-groupchat-stanza)) 158 | 159 | ;; (addtest (stanzas-dispatcher-test) 160 | ;; correct-order-2 161 | ;; (ensure-same (xmpp%::dispatch-stanza groupchat-stanza 'xmpp%:message-stanza) 162 | ;; 'xmpp%::multi-user-chat-message-groupchat-stanza)) 163 | 164 | ;; (addtest (stanzas-dispatcher-test) 165 | ;; correct-order-3 166 | ;; (ensure-same (xmpp%::dispatch-stanza message-stanza-delayed 'xmpp%:message-stanza) 167 | ;; 'xmpp%::delayed-delivery-message-stanza)) 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | ;; 171 | ;; Stanzas 172 | ;; 173 | 174 | ;; 175 | ;; TODO: come up with a better solution for testing stanzas 176 | ;; 177 | 178 | (deftestsuite stream-element-stanzas-test (stanzas-test) 179 | ((features-stanza 180 | (string-to-stanza 'xmpp%::stream-features-element 181 | "zlibPLAINDIGEST-MD5SCRAM-SHA-1"))) 182 | (:equality-test #'typep)) 183 | 184 | (addtest (stream-element-stanzas-test) 185 | correct-stream-element 186 | (ensure-same (xmpp%::xml-to-stanza features-stanza nil) 187 | 'xmpp%::stream-element)) 188 | 189 | 190 | 191 | 192 | -------------------------------------------------------------------------------- /src/client/client.lisp: -------------------------------------------------------------------------------- 1 | ;;;; client.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp-client) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; The root class which represents a single client (in server-client terminology). 13 | ;; So, for example: if you're writing a xmpp client that supports multiple accounts, you might 14 | ;; want to make multiple `client` instances for each xmpp account. 15 | ;; 16 | 17 | (defclass client (xmpp%:debuggable xmpp%:statefull) 18 | ((username :accessor username :initarg :username :initform "") 19 | (password :accessor password :initarg :password :initform "") 20 | (resource :accessor resource :initarg :resource :initform "cl-ngxmpp") 21 | (server-hostname :accessor server-hostname :initarg :server-hostname :initform xmpp%:+default-hostname+) 22 | (server-port :accessor server-port :initarg :server-port :initform xmpp%:+default-port+) 23 | (xml-stream :accessor xml-stream :initarg :xml-stream :initform nil) 24 | (dispatchers :accessor dispatchers :initarg :dispatchers :initform nil))) 25 | 26 | (defmethod initialize-instance :after ((client client) &key) 27 | (setf (xmpp%::state client) 'disconnected)) 28 | 29 | (defmethod print-object ((obj client) stream) 30 | (print-unreadable-object (obj stream :type t :identity t) 31 | (format stream "~A " (jid obj)) 32 | (when (xml-stream obj) 33 | (print (xmpp%::connection (xml-stream obj)) stream)))) 34 | 35 | (defmethod jid ((client client)) 36 | "Returns full jid, i.e. username@server.com/resource." 37 | (with-slots (username server-hostname resource) client 38 | (concatenate 'string username "@" server-hostname "/" resource))) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;; 42 | ;; State predicates 43 | ;; 44 | 45 | (defmethod connectedp ((client client)) 46 | (with-accessors ((state xmpp%::state)) client 47 | (or (eq state 'connected) 48 | (eq state 'loggedin)))) 49 | 50 | (defmethod loggedinp ((client client)) 51 | (eq (xmpp%::state client) 'loggedin)) 52 | 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;; 55 | ;; Basic client's protocol: connect, disconnect, authorize 56 | ;; 57 | 58 | (defmethod connect-client ((client client) &key server-hostname (server-port xmpp%:+default-port+) (adapter 'xmpp%:usocket-adapter)) 59 | (let* ((adapter (make-instance adapter)) 60 | (connection (make-instance 'xmpp%:connection 61 | :adapter adapter 62 | :hostname server-hostname 63 | :port server-port))) 64 | (setf (server-hostname client) server-hostname 65 | (server-port client) server-port) 66 | (xmpp%:open-connection connection) 67 | (when (xmpp%:connectedp connection) 68 | (let ((xml-stream (make-instance 'xmpp%:xml-stream 69 | :connection connection 70 | :debuggable (xmpp%:debuggable client)))) 71 | (setf (xml-stream client) xml-stream) 72 | (xmpp%:open-stream xml-stream) 73 | (xmpp%:negotiate-tls xml-stream) 74 | (when (xmpp%:tls-negotiatedp xml-stream) 75 | (setf (xmpp%::state client) 'connected)))))) 76 | 77 | (defmethod disconnect-client ((client client)) 78 | (when (connectedp client) 79 | (with-slots (xml-stream) client 80 | (let ((connection (xmpp%::connection xml-stream))) 81 | (xmpp%:close-stream xml-stream) 82 | (xmpp%:close-connection connection) 83 | (setf (xmpp%::state client) 'disconnectedp))))) 84 | 85 | (defmethod login-client ((client client) &key username password mechanism) 86 | "SASL authorization over TLS connection, should be called after the connection 87 | is established. In case of error signals negotiate-sasl-condition which should be 88 | handled by the caller." 89 | (let ((xml-stream (xml-stream client))) 90 | (when (xmpp%:tls-negotiatedp xml-stream) 91 | (setf (username client) username 92 | (password client) password) 93 | ;; This hell is needed to supress errors. 94 | ;; Default xmpp%:handle-stanza signals a handle-stanza-error, 95 | ;; thus if client didn't define handle-stanza method for appropriate 96 | ;; type of stanza, authorization will fail. 97 | ;; There is another case about sasl negotiation, when authorization failed 98 | ;; and server sends stanza, but client didn't manage to define 99 | ;; handle-stanza for failure stanza. 100 | (handler-bind 101 | ((xmpp%:handle-stanza-error 102 | #'(lambda (c) 103 | (declare (ignore c)) 104 | (invoke-restart 'skip-handle-stanza)))) 105 | (macrolet ((with-restarts ((&rest restarts) &body steps) 106 | (let ((steps-restarts 107 | (mapcar 108 | #'(lambda (step) 109 | `(restart-case ,step ,@restarts)) 110 | steps))) 111 | `(progn ,@steps-restarts)))) 112 | (with-restarts ((skip-handle-stanza () nil)) 113 | (xmpp%:negotiate-sasl xml-stream 114 | :username username 115 | :password password 116 | :mechanism mechanism) 117 | (%bind% client) 118 | (%session% client) 119 | ;; TODO: 120 | ;; move this into session.lisp 121 | (send-stanza client 'xmpp%:presence-show-stanza :show "online") 122 | ;; TODO: hooks 123 | (receive-stanza client) 124 | (setf (xmpp%::state client) 'loggedin))))))) 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | ;; 128 | ;; TODO: 129 | ;; 130 | ;; replace proceed-stanza with something else, 131 | ;; because it seems like HANDLE-STANZA interface is deprecated now. 132 | ;; 133 | ;; See README.md for information about hooks, `proceed-stanza` will be replaced 134 | ;; by `run-hook` 135 | ;; 136 | 137 | (defmethod %bind% ((client client)) 138 | (with-slots (resource) client 139 | (send-stanza client 'xmpp%:iq-set-bind-stanza :id "bind" :resource resource) 140 | (receive-stanza client))) 141 | 142 | (defmethod %session% ((client client)) 143 | (with-slots (server-hostname) client 144 | (send-stanza client 'xmpp%:iq-set-session-stanza 145 | :to server-hostname 146 | :id "sess") 147 | (receive-stanza client))) 148 | 149 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | ;; 151 | ;; These methods are DEPRECATED, use cl-ngxmpp-client's high interface instead. 152 | ;; 153 | ;; Blocking I/O methods, usefull for bots. 154 | ;; These methods call `xmpp%:handle-stanza' callback 155 | ;; after receiving a message from network. 156 | ;; 157 | 158 | (defmethod proceed-stanza-loop ((client client)) 159 | (let ((xml-stream (xml-stream client))) 160 | (handler-case 161 | (loop 162 | :until (xmpp%:closedp xml-stream) 163 | :do (proceed-stanza client)) 164 | (xmpp%:handle-stanza-error (c) (format nil "~S" c))))) 165 | 166 | (defmethod proceed-stanza ((client client)) 167 | (xmpp%:handle-stanza (receive-stanza client))) 168 | 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | ;; 171 | ;; Methods: receive-stanza, send-stanza 172 | ;; 173 | 174 | (defmethod receive-stanza ((client client)) 175 | (with-slots (xml-stream dispatchers) client 176 | (xmpp%:with-stanza-input (xml-stream stanza dispatchers) 177 | stanza))) 178 | 179 | (defmethod send-stanza ((client client) stanza-name &rest args) 180 | (with-slots (xml-stream) client 181 | (xmpp%:with-stanza-output (xml-stream) 182 | (apply #'make-instance stanza-name args)))) 183 | 184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 185 | ;; 186 | ;; Methods to register/unregister XEPs 187 | ;; 188 | 189 | ;; 190 | ;; TODO: think about more flexible API (register-xep, unregister-xep, etc) 191 | ;; I'm not sure that it is necesseray at the moment. 192 | ;; 193 | (defmethod register-xeps ((client client) xeps) 194 | (let ((xeps-list (if (null xeps) 195 | (loop :for (k v) :on xmpp-xeps::*xeps-list* :by #'cddr 196 | :collect (string-downcase (symbol-name k))) 197 | xeps))) 198 | (setf (dispatchers client) (xmpp-xeps::build-stanzas-dispatchers% xeps-list nil)))) 199 | 200 | ;; (defun use-xeps (names) 201 | ;; (xmpp%:use-xeps names) 202 | ;; (loop 203 | ;; :for name :in names 204 | ;; :do (let ((xep-methods (getf *xeps-methods* (xmpp%:string-to-keyword name)))) 205 | ;; ;; TODO: throw error that xep doesn't exist 206 | ;; (when (and (xmpp%:xep-available-p name) xep-methods) 207 | ;; (loop 208 | ;; :for method-closure :in xep-methods 209 | ;; :do (funcall method-closure)))))) 210 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-ngxmpp 2 | 3 | 4 | [![Build Status](https://travis-ci.org/grouzen/cl-ngxmpp.svg?branch=development)](https://travis-ci.org/grouzen/cl-ngxmpp) 5 | 6 | The native Common Lisp library for XMPP RFCs. 7 | 8 | WARNING: This library is under heavy development. 9 | 10 | # Architecture Overview 11 | 12 | The XMPP basically constists of the core and XEP parts, the library tries to follow 13 | an idea of an extendable design incorporating several layers. 14 | 15 | ## The Layers 16 | 17 | ### Low-level 18 | 19 | The low-level code that is responsible for such things like: 20 | connecting to server through TCP socket, making the socket secure using TLS, 21 | SASL authentication, XML parsing, and the core set of stanzas; is in the `xmpp%` package. 22 | So, in fact, it implements the basic blocks for the Core part of the protocol, consequently, 23 | theoretically, it can be used to implement not only the client side but also the server side. 24 | 25 | ### High-level 26 | 27 | The high-level part is in the package `cl-ngxmpp-client` (there is `xmpp` alias for it) — the most 28 | interesting part for users of the library. It hides all low-level stuff under the hood, 29 | instead of that, it gives you well-bounded entities (futher I'll call them "domains") such as: 30 | roster, message chat, groupchat, file transfer, etc. The basic use-case suggests reacting on 31 | incoming events defining hooks available for particular entity. There is a simple EDSL which 32 | allows you to define your own XEPs easily. 33 | 34 | ## Diagram 35 | 36 | *This section is not finished yet...* 37 | 38 | To understand better what I mean I draw this diagram: 39 | 40 | 41 | ``` 42 | 43 | Global View 44 | 45 | +--------------------------------------------------------------------------------------+ 46 | | | 47 | | +-------------, Core (Low-level) | 48 | | | +-----------, | 49 | | | | +-----------, +--------------+ +--------------+ +----------------+ | 50 | | | | | | | XML-STREAM | | CONNECTION | | ADAPTER | | 51 | | `-| | XEPs | | | | | | | | 52 | | `-| | | connection @----->| adapter @-------->| socket-stream | | 53 | | +-----------+ +--------------+ +--------------+ +----------------+ | 54 | | ^ ^ | 55 | | | Client | (High-level) | 56 | | | | | 57 | | +-------------|---+ +-------------|----+ | 58 | | | SESSION | | | CLIENT | | | 59 | | | | | | | | | 60 | | | client @----|------->| xml-stream @` | | 61 | | | | | +------------------+ | 62 | | | xeps-list @-* | | 63 | | | | +-------------------, | 64 | | | domains @----------->| +-------------------, | 65 | | | | | | +------------------+ | 66 | | +-----------------+ | | | | | 67 | | | | | DOMAINs ---. | | 68 | | `-| | | | | 69 | | `-| | | | 70 | | +----------------|-+ | 71 | +-----------------------------------------------|--------------------------------------+ 72 | | 73 | V 74 | 75 | Domain View 76 | 77 | 78 | SESSION DOMAIN 79 | 80 | Network ------> route_stanza() user-defined-routes 81 | (dispathers over stanza's type) 82 | domains 83 | 84 | 85 | ``` 86 | 87 | # How To Use 88 | 89 | ## Low-level API 90 | 91 | You shouldn't use it, it's an internal API. 92 | 93 | ## Intermediate-level API 94 | 95 | Use this API for simple apps or as a foundation for your own extensions above the cl-ngxmpp library. 96 | 97 | The very basic example how to create a client, connect the client to a xmpp server, 98 | log in, send a message, and wait for a response: 99 | 100 | ``` lisp 101 | (ql:quickload :cl-ngxmpp-client) 102 | 103 | (let ((xmpp-client (make-instance 'xmpp:client :debuggable t))) 104 | (xmpp:connect-client xmpp-client :server-hostname "hostname") 105 | (when (xmpp:connectedp xmpp-client) 106 | (xmpp:login-client xmpp-client 107 | :username "username" 108 | :password "password" 109 | ;; Only PLAIN and DIGEST-MD5 mechanisms are available due to the lack 110 | ;; of support for others in the cl+ssl library 111 | :mechanism "PLAIN or DIGEST-MD5") 112 | (when (xmpp:loggedinp xmpp-client) 113 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza :to "to_jid" :body "message") 114 | (let ((response (xmpp:receive-stanza xmpp-client))) 115 | ;; Here you get the instance of one of the stanza classes (see src/core/stanzas.lisp file). 116 | ;; Do whatever you want with it. 117 | (do something with the response))))) 118 | ``` 119 | 120 | Another way to handle incoming stanzas, but I wouldn't recommend using it: 121 | 122 | ``` lisp 123 | (ql:quickload :cl-ngxmpp-client) 124 | 125 | ;; Define a method for handling stanzas of a type of 'message' 126 | (defmethod xmpp%:handle-stanza ((stanza xmpp%:message-stanza)) 127 | (print stanza)) 128 | 129 | (let ((xmpp-client (make-instance 'xmpp:client :debuggable t))) 130 | (xmpp:connect-client xmpp-client :server-hostname "hostname") 131 | (when (xmpp:connectedp xmpp-client) 132 | (xmpp:login-client xmpp-client 133 | :username "username" 134 | :password "password" 135 | :mechanism "PLAIN or DIGEST-MD5") 136 | (when (xmpp:loggedinp xmpp-client) 137 | (xmpp:send-stanza xmpp-client 'xmpp%:message-stanza :to "to_jid" :body "message") 138 | ;; It waits for an incoming stanza, then calls an appropriate handle-stanza method. 139 | ;; It's something like an asynchronous interface. See also xmpp:proceed-stanza-loop. 140 | (xmpp:proceed-stanza xmpp-client)))) 141 | 142 | ``` 143 | 144 | In case if you miss some functionality in the core XMPP protocol and need to use certain XEPs, 145 | you can easily turn on needed XEPs (see a list of available XEPs in src/xeps/ directory): 146 | 147 | ``` lisp 148 | (ql:quickload :cl-ngxmpp-client) 149 | 150 | (let ((xmpp-client (make-instance 'xmpp:client :debuggable t))) 151 | (xmpp:register-xeps xmpp-client '("multi-user-chat" 152 | "delayed-delivery")) 153 | ...) 154 | 155 | ;; Each xep provides its own list of stanzas, these stanzas are the same as usual stanzas 156 | ;; from the core (xmpp%) package. That means that you can use them the same 157 | ;; way as you did with core stanzas. 158 | ;; 159 | ;; Attention! The way to work with XEPs can be changed in the future! 160 | 161 | ``` 162 | 163 | # Examples: 164 | 165 | Notice! Current examples are deprecated! 166 | 167 | You can find the examples inside a `src/client/examples/` directory. 168 | First you need to load an 'examples' system: 169 | 170 | ``` lisp 171 | (ql:quickload :cl-ngxmpp-client.examples) 172 | ``` 173 | 174 | There is an `echo-bot.lisp` example, to run it type in REPL: 175 | 176 | ``` lisp 177 | (cl-ngxmpp-client.examples.echo-bot:run 178 | :server-hostname "" 179 | :username "" 180 | :password "" 181 | :to "" 182 | :message "") 183 | ``` 184 | 185 | after that the bot will send a message to your opponent, and then will be waiting 186 | for messages from him/her in an infinite loop. 187 | 188 | # ToDo: 189 | 190 | - [X] Migrate from cl-async to blackbird library 191 | - [X] Fix the Travis-CI build 192 | - [X] Develop a DSL to have a more concise way to define stanzas 193 | - [X] Re-use the brand new `define-stanza` in a definition of the `define-xep` macro 194 | - [X] Use short package nicknames instead of the long names 195 | - [X] Reorganize the structure of files and directories 196 | - [X] Be able to represent stanzas as XML-encoded strings 197 | - [X] Implement a generic `print-debug` function 198 | - [X] Make the README file more descriptive 199 | - [X] *CANCELLED* Move the `handle-stanza` generic method from the `xmpp%` package 200 | into the `xmpp` (since, it's not a part of the stanza protocol anymore) 201 | - [X] Get rid of the `send-*` methods/functions, substitute them with a `send-stanza` macro 202 | - [X] Re-think and (it would be better) rewrite/remove some code in the `client/xeps/xeps.lisp` 203 | - [X] Revisit the `core/xeps.lisp`. The `xmpp-xeps:register-xeps` function should work 204 | in the context of `client` objects. Currently, it affects the global context, so that if 205 | multiple `clients` are running in the same lisp image, they are writing/reading to/from a 206 | dynamic variable *stanzas-dispatchers* simultaneously, that's a race condition. 207 | - [ ] Implement an utility to generate a stanza id 208 | - [ ] Generate the make-stanza methods automatically by macro 209 | - [ ] Prepare the core version of the library for getting it into quicklisp repo 210 | - [X] Show usage examples 211 | - [ ] Merge the development and master branches to make a release 212 | - [ ] Write more XEPs (see next item) 213 | - [ ] *NOT FINISHED* 0045 Multi User Chat (MUC) 214 | - [X] 0203 Delayed Delivery 215 | - [X] 0004 Data Forms 216 | - [ ] *NOT FINISHED* 0077 In-Band Registration 217 | - [ ] Add the remaining stanzas of the core protocol 218 | - [ ] Figure out how to validate stanzas (xml schema is a good option I guess). 219 | Since there is no CL library for xmlschema, I can go further and try to develop one. It can be used for 220 | stanza validation/generation, and can avoid a manual work for these areas in the future. 221 | - [ ] Make a logging subsystem pluggable 222 | - [ ] Avoid creating a lot of object while dispatching through the stanzas hierarchy, 223 | because this can create an additional load on a GC. I might do a research how MOP can help 224 | me with this. 225 | - [ ] Develop a high-level interface (EPIC) 226 | - [ ] Rewrite the tests using mocks 227 | - [ ] Add more comments and code documentation 228 | - [ ] Think about adding hooks for the basic actions like: connecting, disconnecting, authenticating, etc. 229 | It could be represented as a set of well-defined wrappers over the `xmpp%:handle-stanza` method. 230 | There are some number of approaches to managable, user-defined, flexible hook systems: 231 | global hooks, e.g. `(add-hook 'some-hook #'(lambda () ...))`; per-session hooks. 232 | - [ ] Improve security (SSL, TLS) 233 | - [ ] Add the hostname verification against a SSL certificate ([https://tools.ietf.org/html/rfc6125#section-5](https://tools.ietf.org/html/rfc6125)) 234 | - [ ] Add a support for the modern cryptography mechanisms. There are limitations in cl+ssl library. 235 | - [ ] Develop a small tool for getting shell over xmpp. 236 | - [ ] Develop a simple MUC bot based on 'Markov chains' as an yet another example 237 | -------------------------------------------------------------------------------- /src/core/xml-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; xml-stream.lisp 2 | ;;;; 3 | ;;;; This file is part of the CL-NGXMPP library, released under Lisp-LGPL. 4 | ;;;; See file COPYING for details. 5 | ;;;; 6 | ;;;; Author: Michael Nedokushev 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; Helpers for processing I/O over XML-stream 13 | ;; 14 | 15 | (defmacro with-stream-xml-input ((xml-stream xml-input) &body body) 16 | `(let ((,xml-input (cxml:parse (read-from-stream ,xml-stream) (cxml-dom:make-dom-builder)))) 17 | ,@body)) 18 | 19 | (defmacro with-stream-xml-output ((xml-stream) &body body) 20 | (let ((xml (gensym "xml")) 21 | (xml-string (gensym "xml-string"))) 22 | `(let* ((,xml (cxml:with-xml-output 23 | (cxml:make-octet-vector-sink :canonical 1) 24 | ,@body)) 25 | (,xml-string (babel:octets-to-string ,xml))) 26 | (write-to-stream ,xml-stream ,xml-string)))) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;; 30 | ;; XML STREAM 31 | ;; 32 | 33 | (defclass xml-stream (debuggable statefull) 34 | ((connection :accessor connection :initarg :connection :initform nil) 35 | (id :accessor id :initarg :id :initform nil) 36 | (features :accessor features :initarg :features :initform nil))) 37 | 38 | (defmethod initialize-instance :after ((xml-stream xml-stream) &key) 39 | (setf (state xml-stream) 'closed)) 40 | 41 | (defmethod print-object ((obj xml-stream) stream) 42 | (print-unreadable-object (obj stream :type t :identity t) 43 | (format stream "~A ~A ~A" (id obj) (symbol-name (state obj)) (debuggable obj)))) 44 | 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | ;; 47 | ;; State-related predicates 48 | ;; 49 | 50 | (defmethod openedp ((xml-stream xml-stream)) 51 | (with-slots (state) xml-stream 52 | (or (eq state 'opened) 53 | (eq state 'tls-negotiated) 54 | (eq state 'sasl-negotiated)))) 55 | 56 | (defmethod closedp ((xml-stream xml-stream)) 57 | (eq (state xml-stream) 'closed)) 58 | 59 | (defmethod tls-negotiatedp ((xml-stream xml-stream)) 60 | (eq (state xml-stream) 'tls-negotiated)) 61 | 62 | (defmethod sasl-negotiatedp ((xml-stream xml-stream)) 63 | (eq (state xml-stream) 'sasl-negotiated)) 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | ;; 67 | ;; Basic operations over xml-stream: write, read, open, close, restart 68 | ;; 69 | 70 | (defmethod write-to-stream ((xml-stream xml-stream) string) 71 | (resolve-async-value (adapter-write-to-stream (adapter (connection xml-stream)) string)) 72 | (print-debug xml-stream "Sent: ~A" string)) 73 | 74 | (defmethod read-from-stream ((xml-stream xml-stream) &key (stanza-reader 'stanza-reader)) 75 | (let ((result (resolve-async-value (adapter-read-from-stream (adapter (connection xml-stream)) :stanza-reader stanza-reader)))) 76 | (print-debug xml-stream "Received: ~A" result) 77 | result)) 78 | 79 | (defmethod close-stream ((xml-stream xml-stream)) 80 | (with-stream-xml-output (xml-stream) 81 | (stanza-to-xml (make-instance 'stream-close-element))) 82 | (setf (state xml-stream) 'closed)) 83 | 84 | (defmethod restart-stream ((xml-stream xml-stream)) 85 | (setf (features xml-stream) nil) 86 | (setf (id xml-stream) nil) 87 | (open-stream xml-stream)) 88 | 89 | (defmethod open-stream ((xml-stream xml-stream)) 90 | ;; Send to initiate connection 91 | (write-to-stream xml-stream 92 | (format nil "" 93 | (hostname (connection xml-stream)))) 94 | ;; Read header 95 | (read-from-stream xml-stream :stanza-reader 'stanza-reader-header) 96 | ;; Read with features 97 | (let* ((features-result 98 | (format nil "~A" (read-from-stream xml-stream :stanza-reader 'stanza-reader-features))) 99 | (features-result-xml (cxml:parse features-result (cxml-dom:make-dom-builder))) 100 | (features-stanza (xml-to-stanza (make-instance 'meta-element :xml-node features-result-xml) nil))) 101 | (setf (state xml-stream) 'opened) 102 | (setf (features xml-stream) features-stanza) 103 | (print-debug xml-stream "Received stream: ~A" features-result))) 104 | 105 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | ;; 107 | ;; The smallest piece of data in XMPP is so called 'stanza', in fact it's just a string. 108 | ;; The reason why we need this code is that XMPP is a "streaming" protocol (there is no 109 | ;; delimiters between stanzas), thus we can't easily split a stream into separate XML pieces. 110 | ;; This is a classical task for FSM (explicit in this case). 111 | ;; 112 | ;; FSM for reading XML. 113 | ;; 114 | ;; Most of the code is taken and ported from: 115 | ;; https://github.com/dmatveev/shampoo-emacs/blob/8302cc4e14653980c2027c98d84f9aa3d1b59ebb/shampoo.el#L400 116 | ;; 117 | ;; Thanks, yoghurt! 118 | ;; 119 | 120 | (define-condition stanza-reader-error (proxy-error) 121 | ()) 122 | 123 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 | ;; 125 | ;; In some cases XMPP forces us to work with malformed XML, so there are 126 | ;; several stanza-reader implementations: 127 | ;; 128 | ;; * standard `stanza-reader` reads a valid XML 129 | ;; * `stanza-reader-header` reads XML header ''. 130 | ;; As far as you can see, the header actually is not a valid XML - tags are not balanced. 131 | ;; * `stanza-reader-features` reads XMPP's 'features' 132 | ;; 133 | 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | ;; 136 | ;; Default reader for valid XML 137 | ;; 138 | 139 | (defclass stanza-reader () 140 | ((stanza-stream :accessor stanza-stream :initarg :stanza-stream :initform nil) 141 | (state :accessor state :initarg :state :initform :init) 142 | (depth :accessor depth :initarg :depth :initform 0) 143 | (last-chars :accessor last-chars :initarg :last-chars :initform nil) 144 | (result :accessor result :initarg :result :initform 145 | (make-array 4096 :element-type 'character :fill-pointer 0 :adjustable t)))) 146 | 147 | (defmethod print-object ((obj stanza-reader) stream) 148 | (print-unreadable-object (obj stream :type t :identity t) 149 | (format stream "state: ~A, depth: ~D, result: ~A, last-chars: ~A" 150 | (state obj) (depth obj) (result obj) (last-chars obj)))) 151 | 152 | (defmethod stanza-reader-complete-p ((stanza-reader stanza-reader)) 153 | (let ((state (state stanza-reader)) 154 | (depth (depth stanza-reader))) 155 | (and (eq depth 0) 156 | (or (eq state :node-closed) 157 | (eq state :tag-closed))))) 158 | 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | ;; 161 | ;; Reader for XML header 162 | ;; 163 | 164 | (defclass stanza-reader-header (stanza-reader) ()) 165 | 166 | (defmethod stanza-reader-complete-p ((stanza-reader stanza-reader-header)) 167 | (let ((state (state stanza-reader)) 168 | (depth (depth stanza-reader))) 169 | (and (eq depth 1) 170 | (eq state :node-opened)))) 171 | 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | ;; 174 | ;; Reader for XMPP's 'feature' stanza 175 | ;; 176 | 177 | (defclass stanza-reader-features (stanza-reader) 178 | ((push-result 179 | :accessor push-result 180 | :initarg :push-result 181 | :initform nil))) 182 | 183 | (defmethod stanza-reader-complete-p ((stanza-reader stanza-reader-features)) 184 | (let ((state (state stanza-reader)) 185 | (depth (depth stanza-reader))) 186 | (and (eq depth 1) 187 | (eq state :node-closed)))) 188 | 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | ;; 191 | ;; FSM actions 192 | ;; 193 | 194 | (defmethod stanza-reader-switch ((stanza-reader stanza-reader) state) 195 | (let ((current-state (state stanza-reader))) 196 | (when (not (eq current-state state)) 197 | (setf (state stanza-reader) state) 198 | (incf (depth stanza-reader) 199 | (cond ((eq state :tag-opened) 1) 200 | ((eq state :tag-closed) -1) 201 | ((eq state :node-closed) -1) 202 | (t 0)))))) 203 | 204 | (defmethod stanza-reader-process ((stanza-reader stanza-reader)) 205 | (let* ((state (state stanza-reader)) 206 | (next-state 207 | (cond ((eq state :init) 208 | (when (stanza-reader-<-p stanza-reader) 209 | :tag-opened)) 210 | 211 | ((eq state :tag-opened) 212 | (cond ((stanza-reader->-p stanza-reader) :node-opened) 213 | ((stanza-reader-/>-p stanza-reader) :tag-closed))) 214 | 215 | ((eq state :tag-closed) 216 | (cond ((stanza-reader--p stanza-reader) 225 | :node-closed)) 226 | 227 | ((eq state :node-closed) 228 | (cond ((stanza-reader-<-p stanza-reader) :tag-opened) 229 | ((stanza-reader--p ((stanza-reader stanza-reader)) 276 | (stanza-reader-with-char (stanza-reader current-char) 277 | (eq current-char #\>))) 278 | 279 | (defmethod stanza-reader-/>-p ((stanza-reader stanza-reader)) 280 | (stanza-reader-with-char (stanza-reader current-char) 281 | (stanza-reader-with-char (stanza-reader next-char) 282 | (and (eq current-char #\/) 283 | (eq next-char #\>))))) 284 | 285 | (defmethod stanza-reader- 7 | 8 | (in-package #:cl-ngxmpp) 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; 12 | ;; Tbe macros for receiving/sending stanzas. 13 | ;; 14 | 15 | (defmacro with-stanza-output ((xml-stream) &body body) 16 | `(with-stream-xml-output (,xml-stream) 17 | (stanza-to-xml ,@body))) 18 | 19 | (defmacro with-stanza-input ((xml-stream stanza-input dispatchers) &body body) 20 | (let ((xml-input (gensym "xml-input"))) 21 | `(with-stream-xml-input (,xml-stream ,xml-input) 22 | (let ((,stanza-input (xml-to-stanza 23 | (make-instance 'meta-element :xml-node ,xml-input) 24 | ,dispatchers))) 25 | ,@body)))) 26 | 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; 29 | ;; CXML-related stuff 30 | ;; 31 | 32 | (defun get-elements-by-name (node el-name) 33 | (let ((elems nil)) 34 | (loop :for el :across (dom:child-nodes node) 35 | :do (when (equal (dom:node-name el) el-name) 36 | (push el elems))) 37 | elems)) 38 | 39 | (defun get-element-by-name (node el-name) 40 | (loop :for el :across (dom:child-nodes node) 41 | :do (when (equal (dom:node-name el) el-name) 42 | (return el)))) 43 | 44 | (defun get-element-data (node) 45 | (let ((child (dom:first-child node))) 46 | (if (null child) 47 | "" 48 | (dom:data child)))) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;; 52 | ;; The 'protocol' to define stanzas 53 | ;; 54 | 55 | ;; TODO: come up with a better name for this 56 | (defun get-stanza-xml-string (stanza) 57 | (babel:octets-to-string 58 | (cxml:with-xml-output (cxml:make-octet-vector-sink :canonical 1) 59 | (stanza-to-xml stanza)))) 60 | 61 | (defun dispatch-stanza (stanza super-stanza-class dispatchers) 62 | (let ((xep-disps (getf dispatchers 63 | (string-to-keyword (symbol-name super-stanza-class))))) 64 | (labels ((dispatch (disp-list) 65 | (if (null disp-list) 66 | (make-instance 'unknown-stanza :xml-node (xml-node stanza)) 67 | (let* ((current (car disp-list)) 68 | (target-stanza-class (first current)) 69 | (target-dispatcher (second current))) 70 | (if (funcall target-dispatcher stanza) 71 | (make-stanza stanza target-stanza-class) 72 | (dispatch (cdr disp-list))))))) 73 | (dispatch xep-disps)))) 74 | 75 | (defgeneric make-stanza (stanza class-name dispatchers) 76 | (:documentation 77 | "This method makes a new instance of `class-name' stanza, 78 | fills it with necessary fields taken from a parent, 79 | and calls `xml-to-stanza' method with the new instance. This method 80 | needs to be implemented only for parental classes")) 81 | 82 | (defgeneric xml-to-stanza (stanza dispatchers) 83 | (:documentation 84 | "Transforms xml to one of the children of STANZA class.")) 85 | 86 | (defgeneric stanza-to-xml (stanza) 87 | (:documentation 88 | "Transforms a particular stanza instance to an xml object which then will be converted to string.")) 89 | 90 | (defgeneric handle-stanza (stanza) 91 | (:documentation 92 | "This handler must be overrided on a client code.")) 93 | 94 | (define-condition handle-stanza-error (simple-condition) ()) 95 | 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | ;; 98 | ;; Use `defstanza` macro to define new stanzas 99 | ;; 100 | ;; Example of usage: 101 | ;; 102 | ;; (defstanza stanza () 103 | ;; (xml-node) 104 | ;; (handle-stanza ((stanza)) 105 | ;; (error 'handle-stanza-error 106 | ;; :format-control "Default stanza handler called. Please define handler for this type of stanza")) 107 | ;; 108 | ;; (make-stanza ((stanza) class-name) 109 | ;; (xml-to-stanza (make-instance class-name :xml-node (xml-node stanza)))) 110 | ;; 111 | ;; (cool-method ((obj (conrete-obj concrete-class)) args) 112 | ;; ...) 113 | ;; 114 | ;; (xml-to-stanza (stanza) 115 | ;; ...)) 116 | ;; 117 | 118 | ;; 119 | ;; Compile-time errors 120 | ;; 121 | 122 | (define-condition defstanza-method%-error (simple-condition) 123 | ((arg :reader arg :initarg :arg)) 124 | (:report (lambda (condition stream) 125 | (format stream 126 | "Argument ~A is neither a non-NIL symbol nor a list of form '(obj class)" 127 | (arg condition))))) 128 | 129 | (define-condition defstanza-class%-error (simple-condition) 130 | ((slot :reader slot :initarg :slot)) 131 | (:report (lambda (condition stream) 132 | (format stream 133 | "Slot ~A is neither a non-NIL symbol nor a list of form '(name initform)" 134 | (slot condition))))) 135 | 136 | (defmacro defstanza (stanza-name superclasses slots &rest methods) 137 | (let* ((slotz 138 | (mapcar #'(lambda (slot) 139 | (let ((ds (cond ((listp slot) 140 | (if (> (length slot) 2) 141 | (error 'defstanza-class%-error :slot slot) 142 | slot)) 143 | (t (list slot nil))))) 144 | (list (first ds) (second ds)))) 145 | slots)) 146 | (slotz-make-stanza 147 | (reduce #'append 148 | (mapcar #'(lambda (slot) 149 | (let* ((slot-name (first slot)) 150 | (initarg (alexandria:make-keyword slot-name)) 151 | (initval (list slot-name 'stanza))) 152 | (list initarg initval))) 153 | slotz)))) 154 | `(progn 155 | (defstanza-class% ,stanza-name ,superclasses ,slotz) 156 | (defstanza-methods% ,stanza-name ,methods) 157 | ;; Generate make-stanza method automatically 158 | (defstanza-method% ,stanza-name make-stanza ((stanza) class-name dispatchers) 159 | ;; I'm forced here by the lisp compiler to compute slots of superclasses in 160 | ;; run-time each time when the `make-stanza` method is called. I would be 161 | ;; glad to know a better solution. 162 | (let* ((superclasses-slotz 163 | (reduce #'append 164 | (mapcar 165 | #'(lambda (superclass) 166 | (reduce #'append 167 | (mapcar #'(lambda (slot-def) 168 | (let* ((slot-name (cl-mop:slot-definition-name slot-def)) 169 | (initarg (alexandria:make-keyword slot-name)) 170 | ;; TODO: 171 | ;; It has to be changed to be able to call accessors from 172 | ;; the xmpp-xeps package too. 173 | (initval (funcall (intern (symbol-name slot-name) :xmpp%) stanza))) 174 | (list initarg initval))) 175 | (cl-mop:class-slots (find-class superclass))))) 176 | ',superclasses))) 177 | (make-instance-args (append (list class-name) superclasses-slotz (list ,@slotz-make-stanza)))) 178 | (xml-to-stanza (apply #'make-instance make-instance-args) dispatchers)))))) 179 | 180 | (defmacro defstanza-class% (stanza-name superclasses slots) 181 | (let ((slotz (mapcar #'(lambda (slot) 182 | (let ((name (first slot)) 183 | (initform (second slot))) 184 | (list name 185 | :accessor name 186 | :initarg (alexandria:make-keyword name) 187 | :initform initform))) 188 | slots))) 189 | `(defclass ,stanza-name (,@superclasses) (,@slotz)))) 190 | 191 | (defmacro defstanza-methods% (stanza-name methods) 192 | `(progn ,@(mapcar #'(lambda (method) 193 | (if (eq (first method) :macro) 194 | `(defmacro ,@(cdr `,method)) 195 | (let ((name (first method)) 196 | (args (second method)) 197 | (body (cdr (cdr method)))) 198 | `(defstanza-method% ,stanza-name ,name ,args ,@body)))) 199 | methods))) 200 | 201 | (defmacro defstanza-method% (stanza-name method-name method-args &body method-body) 202 | (let ((obj-args (mapcar #'(lambda (arg) 203 | (cond ((listp arg) 204 | (if (> (length arg) 2) 205 | (error 'defstanza-method%-error :arg arg) 206 | arg)) 207 | (t (list arg stanza-name)))) 208 | (first method-args))) 209 | (rest-args (cdr method-args))) 210 | `(defmethod ,method-name (,@obj-args ,@rest-args) 211 | ,@method-body))) 212 | 213 | 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | ;; 216 | ;; Very meta-level stuff. 217 | ;; 218 | ;; The hierarchy: 219 | ;; 220 | ;; ,-----> id element----->stanza +----------------------+ 221 | ;; | | | | | 222 | ;; | V |--->message----->| | 223 | ;; | stream | stanza | | 224 | ;; | element | | | 225 | ;; | |--->iq---------->| | 226 | ;; | | stanza | XEPs | 227 | ;; | | | stanzas | 228 | ;; | `--->presence---->| and | 229 | ;; | stanza | elements | 230 | ;; | | | 231 | ;; meta | | 232 | ;; element-------------------------------------->| | 233 | ;; | | | 234 | ;; | +----------------------+ 235 | ;; |-----> sasl-challenge 236 | ;; | element 237 | ;; | 238 | ;; |-----> proceed 239 | ;; | element 240 | ;; | 241 | ;; |-----> success 242 | ;; | element 243 | ;; | 244 | ;; `-----> failure 245 | ;; element 246 | ;; | | 247 | ;; .--/ | 248 | ;; | | 249 | ;; V V 250 | ;; tls sasl 251 | ;; xmlns xmlns 252 | ;; 253 | (defstanza meta-element () 254 | (xml-node (xmlns "")) 255 | 256 | (:macro with-meta-element (stanza &body body) 257 | (`(cxml:attribute "xmlns" (xmlns ,stanza)) 258 | 259 | `(progn 260 | (with-element "message" 261 | (cxml:attribute "to" to) 262 | (cxml:with-element "body" 263 | (cxml:text (body ,message-stanza)))) 264 | (with-meta-element ,message-stanza) 265 | 266 | (xml-to-stanza ((stanza) dispatchers) 267 | (with-slots (xml-node) stanza 268 | (let* ((root-node (dom:first-child xml-node)) 269 | (qname (dom:node-name root-node)) 270 | (xmlns (dom:get-attribute root-node "xmlns"))) 271 | (setf (xmlns stanza) xmlns) 272 | (string-case qname 273 | ("failure" (make-stanza stanza 'failure-element dispatchers)) 274 | ("success" (make-stanza stanza 'success-element dispatchers)) 275 | ("proceed" (make-stanza stanza 'proceed-element dispatchers)) 276 | ("challenge" (make-stanza stanza 'sasl-challenge-element dispatchers)) 277 | (:default (make-stanza stanza 'id-element dispatchers))))))) 278 | 279 | (defstanza id-element (meta-element) 280 | ((id (uuid:make-v4-uuid))) 281 | 282 | (:macro with-id-element (stanza &body body) 283 | `(progn 284 | ,@body 285 | (cxml:attribute "id" (id stanza)))) 286 | 287 | (xml-to-stanza ((stanza) dispatchers) 288 | (with-slots (xml-node) stanza 289 | (let* ((root-node (dom:first-child xml-node)) 290 | (qname (dom:node-name root-node)) 291 | (id (dom:get-attribute root-node "id"))) 292 | (setf (id stanza) id) 293 | (string-case qname 294 | ("stream:stream" (make-stanza stanza 'stream-element dispatchers)) 295 | (:default (make-stanza stanza 'stanza dispatchers))))))) 296 | 297 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 298 | ;; 299 | ;; Basic stanza class. 300 | ;; 301 | ;; TODO: 302 | ;; - export children of stanza class from cl-ngxmpp package. 303 | ;; 304 | 305 | (defstanza stanza (id-element) 306 | ;; According to the definition of "stanza" -- an each type of stanza should have 307 | ;; at least 4 attributes in its root element: id, to, from, type 308 | (id to from stanza-type) 309 | 310 | (:macro with-stanza (stanza &body body) 311 | `(with-id-element (,stanza) 312 | (unless (null (from ,stanza)) 313 | (cxml:attribute "from" (from ,stanza))) 314 | (unless (null (to ,stanza)) 315 | (cxml:attribute "to" (to ,stanza))) 316 | (unless (null (stanza-type ,stanza)) 317 | (cxml:attribute "type" (stanza-type ,stanza)))) 318 | 319 | (handle-stanza ((stanza)) t) 320 | 321 | (xml-to-stanza ((stanza) dispatchers) 322 | (with-slots (xml-node) stanza 323 | (let* ((root-node (dom:first-child xml-node)) 324 | (qname (dom:node-name root-node)) 325 | (id (dom:get-attribute root-node "id")) 326 | (to (dom:get-attribute root-node "to")) 327 | (from (dom:get-attribute root-node "from")) 328 | (stype (dom:get-attribute root-node "type"))) 329 | (setf (id stanza) id 330 | (to stanza) to 331 | (from stanza) from 332 | (stanza-type stanza) stype) 333 | (string-case qname 334 | ("message" (make-stanza stanza 'message-stanza dispatchers)) 335 | ("iq" (make-stanza stanza 'iq-stanza dispatchers)) 336 | ("presence" (make-stanza stanza 'presence-stanza dispatchers)) 337 | (:default (dispatch-stanza stanza 'stanza dispatchers))))))) 338 | 339 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 340 | 341 | (defstanza unknown-stanza (stanza) 342 | () 343 | 344 | (print-object ((obj) stream) 345 | (print-unreadable-object (obj stream :type t :identity t) 346 | (format stream "Unknown type of stanza: ~A" (dom:node-name (dom:first-child (xml-node obj)))))) 347 | 348 | (xml-to-stanza ((stanza) dispatchers) 349 | stanza)) 350 | 351 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 352 | ;; 353 | ;; Stream elements 354 | ;; 355 | 356 | (defstanza stream-element (id-element) 357 | ((xml-lang "en") (xmlns "jabber:client") 358 | (xmlns-stream "http://etherx.jabber.org/streams") (version "1.0")) 359 | 360 | (print-object ((obj) stream) 361 | (print-unreadable-object (obj stream :type t :identity t) 362 | (format stream "to: ~A, from: ~A, id: ~A, xml-lang: ~A, xmlns: ~A, xmlns-stream: ~A, version: ~A" 363 | (to obj) (from obj) (id obj) (xml-lang obj) (xmlns obj) (xmlns-stream obj) (version obj)))) 364 | 365 | (xml-to-stanza ((stanza) dispatchers) 366 | (with-slots (xml-node) stanza 367 | (let* ((root-node (dom:first-child xml-node)) 368 | (child-qname (dom:node-name (dom:first-child root-node))) 369 | (xml-lang (dom:get-attribute root-node "xml:lang")) 370 | (xmlns-stream (dom:get-attribute root-node "xmlns:stream")) 371 | (version (dom:get-attribute root-node "version"))) 372 | (setf (xml-lang stanza) xml-lang 373 | (xmlns-stream stanza) xmlns-stream 374 | (version stanza) version) 375 | (string-case child-qname 376 | ("stream:features" (make-stanza stanza 'stream-features-element dispatchers)) 377 | ("stream:error" (make-stanza stanza 'stream-error-element dispatchers)) 378 | (:default (dispatch-stanza stanza 'stream-element dispatchers)))))) 379 | 380 | (stanza-to-xml ((stanza)) 381 | (cxml:with-element "stream:stream" 382 | (cxml:attribute "to" (to stanza)) 383 | (cxml:attribute "id" (id stanza)) 384 | (cxml:attribute "xmlns" (xmlns stanza)) 385 | (cxml:attribute "xmlns:stream" (xmlns-stream stanza)) 386 | (cxml:attribute "version" (version stanza))))) 387 | 388 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 389 | 390 | (defstanza stream-features-element (stream-element) 391 | (features) 392 | 393 | (print-object ((obj) stream) 394 | (print-unreadable-object (obj stream :type t :identity t) 395 | (mapcar #'(lambda (feature) 396 | (let ((feature-name (car feature)) 397 | (feature-required (cdr feature))) 398 | (format stream "{~A -> ~A} " feature-name 399 | (if feature-required 400 | "required" 401 | "not required")))) 402 | (features obj))) 403 | (call-next-method obj stream)) 404 | 405 | (xml-to-stanza ((stanza) dispatchers) 406 | (with-slots (xml-node features) stanza 407 | (dom:map-node-list 408 | #'(lambda (node) 409 | (let* ((feature-name (dom:node-name node)) 410 | (feature-required (string-case feature-name 411 | ("session" t) ;; TODO: implement required checking. 412 | ("mechanisms" t) ;; These four features are 413 | ("starttls" t) ;; mandatory-to-negitiate for 414 | ("bind" t) ;; client and server, see RFC 6120 and RFC 3921. 415 | (:default nil)))) ;; TODO: check on element 416 | (setf features (cons (cons feature-name feature-required) features)))) 417 | (dom:child-nodes (dom:first-child (dom:first-child xml-node)))) 418 | (setf (features stanza) features) 419 | stanza))) 420 | 421 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 422 | 423 | (defstanza stream-close-element (stream-element) 424 | () 425 | 426 | (xml-to-stanza ((stanza) dispatchers) 427 | stanza) 428 | 429 | (stanza-to-xml ((stanza)) 430 | (cxml:with-element "stream:stream"))) 431 | 432 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 433 | 434 | (defstanza stream-error-element (stream-element) 435 | (error-node)) 436 | 437 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 438 | ;; 439 | ;; Message stanzas 440 | ;; 441 | 442 | (defstanza message-stanza (stanza) 443 | (thread (body "")) 444 | 445 | (print-object ((obj) stream) 446 | (with-slots (from to body) obj 447 | (print-unreadable-object (obj stream :type t :identity t) 448 | (format stream "from: ~A, to: ~A, body: ~A" 449 | from to body)))) 450 | 451 | (:macro with-message-stanza (message-stanza &body body) 452 | `(cxml:with-element "message" 453 | (unless (null (from ,message-stanza)) 454 | (cxml:attribute "from" (from ,message-stanza))) 455 | (unless (null (to ,message-stanza)) 456 | (cxml:attribute "to" (to ,message-stanza))) 457 | (unless (null (stanza-type ,message-stanza)) 458 | (cxml:attribute "type" (stanza-type ,message-stanza))) 459 | (cxml:with-element "body" 460 | (cxml:text (body ,message-stanza))) 461 | ,@body)) 462 | 463 | (stanza-to-xml ((stanza)) 464 | (with-message-stanza stanza)) 465 | 466 | (xml-to-stanza ((stanza) dispatchers) 467 | (with-slots (xml-node) stanza 468 | (let* ((message-node (dom:first-child xml-node)) 469 | (body (get-element-data (get-element-by-name message-node "body"))) 470 | (disp (dispatch-stanza stanza 'message-stanza dispatchers))) 471 | (setf (body stanza) body) 472 | (if (typep disp 'unknown-stanza) 473 | stanza 474 | disp))))) 475 | 476 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 477 | 478 | (defstanza message-error-stanza (message-stanza) 479 | ()) 480 | 481 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 482 | ;; 483 | ;; Presence stanzas 484 | ;; 485 | 486 | (defstanza presence-stanza (stanza) 487 | () 488 | 489 | (:macro with-presence-stanza (presence-stanza &body body) 490 | `(cxml:with-element "presence" 491 | (unless (null (id ,presence-stanza)) 492 | (cxml:attribute "id" (id ,presence-stanza))) 493 | (unless (null (to ,presence-stanza)) 494 | (cxml:attribute "to" (to ,presence-stanza))) 495 | (unless (null (from ,presence-stanza)) 496 | (cxml:attribute "from" (from ,presence-stanza))) 497 | (unless (null (stanza-type ,presence-stanza)) 498 | (cxml:attribute "type" (stanza-type ,presence-stanza))) 499 | ,@body)) 500 | 501 | (stanza-to-xml ((stanza)) 502 | (with-presence-stanza stanza)) 503 | 504 | (xml-to-stanza ((stanza) dispatchers) 505 | (with-slots (xml-node stanza-type) stanza 506 | (let ((show (get-element-by-name (dom:first-child xml-node) "show"))) 507 | (setf (show xml-node) show) 508 | (string-case stanza-type 509 | ("subscribe" (make-stanza stanza 'presence-subscribe-stanza dispatchers)) 510 | ("error" (make-stanza stanza 'presence-error-stanza dispatchers)) 511 | (:default 512 | (if show 513 | (make-stanza stanza 'presence-show-stanza dispatchers) 514 | (dispatch-stanza stanza 'presence-stanza dispatchers)))))))) 515 | 516 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 517 | 518 | (defstanza presence-show-stanza (presence-stanza) 519 | ((show "")) 520 | 521 | (xml-to-stanza ((stanza) dispatchers) 522 | (let* ((xml-node (xml-node stanza)) 523 | (show (get-element-data (get-element-by-name (dom:first-child xml-node) "show")))) 524 | (setf (show stanza) show) 525 | stanza)) 526 | 527 | (stanza-to-xml ((stanza)) 528 | (with-presence-stanza stanza 529 | (cxml:with-element "show" 530 | (cxml:text (show stanza)))))) 531 | 532 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 533 | 534 | (defstanza presence-subscribe-stanza (presence-stanza) 535 | ((status "")) 536 | 537 | (xml-to-stanza ((stanza) dispatchers) 538 | (let* ((xml-node (xml-node stanza)) 539 | (status (get-element-data 540 | (get-element-by-name (dom:first-child xml-node) "status")))) 541 | (setf (status stanza) status) 542 | stanza)) 543 | 544 | (stanza-to-xml ((stanza)) 545 | (with-presence-stanza stanza 546 | (cxml:with-element "status" 547 | (cxml:text (status stanza)))))) 548 | 549 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 550 | 551 | (defstanza presence-error-stanza (presence-stanza) 552 | () 553 | 554 | (xml-to-stanza ((stanza) dispatchers) 555 | stanza)) 556 | 557 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 558 | ;; 559 | ;; IQ stanzas 560 | ;; 561 | 562 | (defstanza iq-stanza (stanza) 563 | ((stanza-type "get") to from) 564 | 565 | (:macro with-iq-stanza (iq-stanza &body body) 566 | `(cxml:with-element "iq" 567 | (cxml:attribute "id" (id ,iq-stanza)) 568 | (unless (null (to ,iq-stanza)) 569 | (cxml:attribute "to" (to ,iq-stanza))) 570 | (unless (null (from ,iq-stanza)) 571 | (cxml:attribute "from" (from ,iq-stanza))) 572 | ,@body)) 573 | 574 | ;; (make-stanza ((stanza) class-name dispatchers) 575 | ;; (let* ((xml-node (xml-node stanza)) 576 | ;; (iq-node (dom:first-child xml-node))) 577 | ;; (xml-to-stanza (make-instance class-name 578 | ;; :xml-node xml-node 579 | ;; :to (dom:get-attribute iq-node "to") 580 | ;; :from (dom:get-attribute iq-node "from") 581 | ;; :id (dom:get-attribute iq-node "id") 582 | ;; :stanza-type (dom:get-attribute iq-node "type")) 583 | ;; dispatchers))) 584 | 585 | (xml-to-stanza ((stanza) dispatchers) 586 | (let* ((xml-node (xml-node stanza)) 587 | (stanza-type (dom:get-attribute (dom:first-child xml-node) "type"))) 588 | (string-case stanza-type 589 | ("result" (make-stanza stanza 'iq-result-stanza dispatchers)) 590 | ("error" (make-stanza stanza 'iq-error-stanza dispatchers)) 591 | ("get" (make-stanza stanza 'iq-get-stanza dispatchers)) 592 | (:default (dispatch-stanza stanza 'iq-stanza dispatchers)))))) 593 | 594 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 595 | 596 | (defstanza iq-get-stanza (iq-stanza) 597 | () 598 | 599 | (xml-to-stanza ((stanza) dispatchers) 600 | ;; IQ's type is set to "get" by default 601 | stanza)) 602 | 603 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 604 | 605 | (defstanza iq-set-stanza (iq-stanza) 606 | () 607 | 608 | (:macro with-iq-set-stanza (iq-set-stanza &body body) 609 | `(with-iq-stanza ,iq-set-stanza 610 | (cxml:attribute "type" "set") 611 | ,@body))) 612 | 613 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 614 | 615 | (defstanza iq-set-bind-stanza (iq-set-stanza) 616 | (resource (xmlns "urn:ietf:params:xml:ns:xmpp-bind")) 617 | 618 | (stanza-to-xml ((stanza)) 619 | (with-iq-set-stanza stanza 620 | (cxml:with-element "bind" 621 | (cxml:attribute "xmlns" (xmlns stanza)) 622 | (unless (null (resource stanza)) 623 | (cxml:with-element "resource" 624 | (cxml:text (resource stanza)))))))) 625 | 626 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 627 | 628 | (defstanza iq-set-session-stanza (iq-set-stanza) 629 | ((xmlns "urn:ietf:params:xml:ns:xmpp-session")) 630 | 631 | (stanza-to-xml ((stanza)) 632 | (with-iq-set-stanza stanza 633 | (cxml:with-element "session" 634 | (cxml:attribute "xmlns" (xmlns stanza)))))) 635 | 636 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 637 | 638 | (defstanza iq-result-stanza (iq-stanza) 639 | () 640 | 641 | (xml-to-stanza ((stanza) dispatchers) 642 | stanza)) 643 | 644 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 645 | 646 | (defstanza iq-error-stanza (iq-stanza) 647 | () 648 | 649 | (xml-to-stanza ((stanza) dispatchers) 650 | stanza)) 651 | 652 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 653 | 654 | (defstanza failure-element (meta-element) 655 | () 656 | 657 | (print-object ((obj) stream) 658 | (print-unreadable-object (obj stream :type t :identity t) 659 | (format stream "xmlns: ~A" (xmlns obj)))) 660 | 661 | (xml-to-stanza ((stanza) dispatchers) 662 | (with-slots (xml-node xmlns) stanza 663 | (let ((node-xmlns (dom:get-attribute (dom:first-child xml-node) "xmlns"))) 664 | (string-case node-xmlns 665 | ("urn:ietf:params:xml:ns:xmpp-tls" (make-stanza stanza 'failure-tls-element dispatchers)) 666 | ("urn:ietf:params:xml:ns:xmpp-sasl" (make-stanza stanza 'failure-sasl-element dispatchers))))))) 667 | 668 | 669 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 670 | 671 | (defstanza success-element (meta-element) 672 | () 673 | 674 | (xml-to-stanza ((stanza) dispatchers) 675 | (with-slots (xmlns) stanza 676 | (setf xmlns (dom:get-attribute (dom:first-child (xml-node stanza)) "xmlns")) 677 | stanza)) 678 | 679 | (print-object ((obj) stream) 680 | (print-unreadable-object (obj stream :type t :identity t) 681 | (format stream "xmlns: ~A" (xmlns obj))))) 682 | 683 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 684 | --------------------------------------------------------------------------------