;; jabber-iq.el - infoquery functions -*- lexical-binding: t; -*- ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net ;; This file is a part of jabber.el. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (require 'jabber-core) (require 'jabber-util) (require 'jabber-keymap) (defvar *jabber-open-info-queries* nil "Alist of open query id and their callback functions.") (defvar jabber-iq-get-xmlns-alist nil "Mapping from XML namespace to handler for IQ GET requests.") (defvar jabber-iq-set-xmlns-alist nil "Mapping from XML namespace to handler for IQ SET requests.") (defvar jabber-browse-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map jabber-common-keymap) (define-key map [mouse-2] 'jabber-popup-combined-menu) map)) (defcustom jabber-browse-mode-hook nil "Hook run when entering Browse mode." :group 'jabber :type 'hook) (defgroup jabber-browse nil "browse display options" :group 'jabber) (defcustom jabber-browse-buffer-format "*-jabber-browse:-%n-*" "The format specification for the name of browse buffers. These fields are available at this moment: %n JID to browse" :type 'string :group 'jabber-browse) (defun jabber-browse-mode () "Jabber browse mode. \\{jabber-browse-mode-map}" (kill-all-local-variables) (setq major-mode 'jabber-browse-mode mode-name "jabber-browse") (use-local-map jabber-browse-mode-map) (setq buffer-read-only t) (if (fboundp 'run-mode-hooks) (run-mode-hooks 'jabber-browse-mode-hook) (run-hooks 'jabber-browse-mode-hook))) (put 'jabber-browse-mode 'mode-class 'special) (add-to-list 'jabber-iq-chain 'jabber-process-iq) (defun jabber-process-iq (jc xml-data) "Process an incoming iq stanza. JC is the Jabber Connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let* ((id (jabber-xml-get-attribute xml-data 'id)) (type (jabber-xml-get-attribute xml-data 'type)) (from (jabber-xml-get-attribute xml-data 'from)) (query (jabber-iq-query xml-data)) (callback (assoc id *jabber-open-info-queries*))) (cond ;; if type is "result" or "error", this is a response to a query we sent. ((or (string= type "result") (string= type "error")) (let ((callback-cons (nth (cdr (assoc type '(("result" . 0) ("error" . 1)))) (cdr callback)))) (if (consp callback-cons) (funcall (car callback-cons) jc xml-data (cdr callback-cons)))) (setq *jabber-open-info-queries* (delq callback *jabber-open-info-queries*))) ;; if type is "get" or "set", correct action depends on namespace of request. ((and (listp query) (or (string= type "get") (string= type "set"))) (let* ((which-alist (eval (cdr (assoc type (list (cons "get" 'jabber-iq-get-xmlns-alist) (cons "set" 'jabber-iq-set-xmlns-alist)))))) (handler (cdr (assoc (jabber-xml-get-attribute query 'xmlns) which-alist)))) (if handler (condition-case error-var (funcall handler jc xml-data) (jabber-error (apply 'jabber-send-iq-error jc from id query (cdr error-var))) (error (jabber-send-iq-error jc from id query "wait" 'internal-server-error (error-message-string error-var)))) (jabber-send-iq-error jc from id query "cancel" 'feature-not-implemented))))))) (defun jabber-send-iq (jc to type query success-callback success-closure-data error-callback error-closure-data &optional result-id) "Send an iq stanza to the specified entity, and optionally set up a callback. JC is the Jabber connection. TO is the addressee. TYPE is one of \"get\", \"set\", \"result\" or \"error\". QUERY is a list containing the child of the iq node in the format `jabber-sexp2xml' accepts. SUCCESS-CALLBACK is the function to be called when a successful result arrives. SUCCESS-CLOSURE-DATA is an extra argument to SUCCESS-CALLBACK. ERROR-CALLBACK is the function to be called when an error arrives. ERROR-CLOSURE-DATA is an extra argument to ERROR-CALLBACK. RESULT-ID is the id to be used for a response to a received iq message. `jabber-report-success' and `jabber-process-data' are common callbacks. The callback functions are called like this: \(funcall CALLBACK JC XML-DATA CLOSURE-DATA) with XML-DATA being the IQ stanza received in response." (let ((id (or result-id (apply 'format "emacs-iq-%d.%d.%d" (current-time))))) (if (or success-callback error-callback) (setq *jabber-open-info-queries* (cons (list id (cons success-callback success-closure-data) (cons error-callback error-closure-data)) *jabber-open-info-queries*))) (jabber-send-sexp jc (list 'iq (append (if to (list (cons 'to to))) (list (cons 'type type)) (list (cons 'id id))) query)))) (defun jabber-send-iq-error (jc to id original-query error-type condition &optional text app-specific) "Send an error iq stanza in response to a previously sent iq stanza. Send an error iq stanza to the specified entity in response to a previously sent iq stanza. TO is the addressee. ID is the id of the iq stanza that caused the error. ORIGINAL-QUERY is the original query, which should be included in the error, or nil. ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\" and \"wait\". CONDITION is a symbol denoting a defined XMPP condition. TEXT is a string to be sent in the error message, or nil for no text. APP-SPECIFIC is a list of extra XML tags. JC is the Jabber connection. See section 9.3 of XMPP Core." (jabber-send-sexp jc `(iq (,@(when to `((to . ,to))) (type . "error") (id . ,(or id ""))) ,original-query (error ((type . ,error-type)) (,condition ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas"))) ,(if text `(text ((xmlns . "urn:ietf:params:xml:ns:xmpp-stanzas")) ,text)) ,@app-specific)))) (defun jabber-process-data (jc xml-data closure-data) "Process random results from various requests. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((from (or (jabber-xml-get-attribute xml-data 'from) (plist-get (fsm-get-state-data jc) :server))) (xmlns (jabber-iq-xmlns xml-data)) (type (jabber-xml-get-attribute xml-data 'type))) (with-current-buffer (get-buffer-create (format-spec jabber-browse-buffer-format (list (cons ?n from)))) (if (not (eq major-mode 'jabber-browse-mode)) (jabber-browse-mode)) (setq buffer-read-only nil) (goto-char (point-max)) (insert (jabber-propertize from 'face 'jabber-title-large) "\n\n") ;; Put point at beginning of data (save-excursion ;; If closure-data is a function, call it. If it is a string, ;; output it along with a description of the error. For other ;; values (e.g. nil), just dump the XML. (cond ((functionp closure-data) (funcall closure-data jc xml-data)) ((stringp closure-data) (insert closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)) "\n\n")) (t (insert (format "%S\n\n" xml-data)))) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse (current-buffer) (funcall jabber-alert-info-message-function 'browse (current-buffer)))))))) (defun jabber-silent-process-data (jc xml-data closure-data) "Process random results from various requests to only alert hooks. JC is the Jabber connection. XML-DATA is the parsed tree data from the stream (stanzas) obtained from `xml-parse-region'." (let ((text (cond ((functionp closure-data) (funcall closure-data jc xml-data)) ((stringp closure-data) (concat closure-data ": " (jabber-parse-error (jabber-iq-error xml-data)))) (t (format "%S" xml-data))))) (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) (run-hook-with-args hook 'browse (current-buffer) text)))) (provide 'jabber-iq) ;;; arch-tag: 5585dfa3-b59a-42ee-9292-803652c85e26