jabber-disco.el

   1 ;; jabber-disco.el - service discovery functions
   2
   3 ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22
  23 ;;; All the client part should be seriously rewritten, or at least
  24 ;;; reconsidered.  I'm imagining a separation between backend and
  25 ;;; frontend, so that various functions can perform disco queries for
  26 ;;; their own purposes, and maybe some caching with that.
  27
  28 (require 'jabber-iq)
  29 (require 'jabber-xml)
  30 (require 'jabber-menu)
  31
  32 ;; Advertise your features here.  Add the namespace to this list.
  33 (defvar jabber-advertised-features
  34   (list "http://jabber.org/protocol/disco#info")
  35   "Features advertised on service discovery requests")
  36
  37 (defvar jabber-disco-items-nodes
  38   (list
  39    (list "" nil nil))
  40   "Alist of node names and information about returning disco item data.
  41 Key is node name as a string, or \"\" for no node specified.  Value is
  42 a list of two items.
  43
  44 First item is data to return.  If it is a function, that function is
  45 called and its return value is used; if it is a list, that list is
  46 used.  The list should be the XML data to be returned inside the
  47 <query/> element, like this:
  48
  49 \((item ((name . \"Name of first item\")
  50         (jid . \"first.item\")
  51         (node . \"node\"))))
  52
  53 Second item is access control function.  That function is passed the
  54 JID, and returns non-nil if access is granted.  If the second item is
  55 nil, access is always granted.")
  56
  57 (defvar jabber-disco-info-nodes
  58   (list
  59    (list "" #'jabber-disco-return-client-info nil))
  60   "Alist of node names and information returning disco info data.
  61 Key is node name as a string, or \"\" for no node specified.  Value is
  62 a list of two items.
  63
  64 First item is data to return.  If it is a function, that function is
  65 called and its return value is used; if it is a list, that list is
  66 used.  The list should be the XML data to be returned inside the
  67 <query/> element, like this:
  68
  69 \((identity ((category . \"client\")
  70             (type . \"pc\")
  71             (name . \"Jabber client\")))
  72  (feature ((var . \"some-feature\"))))
  73
  74 Second item is access control function.  That function is passed the
  75 JID, and returns non-nil if access is granted.  If the second item is
  76 nil, access is always granted.")
  77
  78 (defun jabber-process-disco-info (jc xml-data)
  79   "Handle results from info disco requests."
  80
  81   (let ((beginning (point)))
  82     (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data)))
  83       (cond
  84        ((eq (jabber-xml-node-name x) 'identity)
  85         (let ((name (jabber-xml-get-attribute x 'name))
  86               (category (jabber-xml-get-attribute x 'category))
  87               (type (jabber-xml-get-attribute x 'type)))
  88           (insert (jabber-propertize (if name
  89                                          name
  90                                        "Unnamed")
  91                                      'face 'jabber-title-medium)
  92                   "\n\nCategory:\t" category "\n")
  93           (if type
  94               (insert "Type:\t\t" type "\n"))
  95           (insert "\n")))
  96        ((eq (jabber-xml-node-name x) 'feature)
  97         (let ((var (jabber-xml-get-attribute x 'var)))
  98           (insert "Feature:\t" var "\n")))))
  99     (put-text-property beginning (point)
 100                        'jabber-jid (jabber-xml-get-attribute xml-data 'from))
 101     (put-text-property beginning (point)
 102                        'jabber-account jc)))
 103
 104 (defun jabber-process-disco-items (jc xml-data)
 105   "Handle results from items disco requests."
 106
 107   (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))
 108     (if items
 109         (dolist (item items)
 110           (let ((jid (jabber-xml-get-attribute item 'jid))
 111                 (name (jabber-xml-get-attribute item 'name))
 112                 (node (jabber-xml-get-attribute item 'node)))
 113             (insert
 114              (jabber-propertize
 115               (concat
 116                (jabber-propertize
 117                 (concat jid "\n" (if node (format "Node: %s\n" node)))
 118                 'face 'jabber-title-medium)
 119                name "\n\n")
 120               'jabber-jid jid
 121               'jabber-account jc
 122               'jabber-node node))))
 123       (insert "No items found.\n"))))
 124
 125 (add-to-list 'jabber-iq-get-xmlns-alist
 126              (cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info))
 127 (add-to-list 'jabber-iq-get-xmlns-alist
 128              (cons "http://jabber.org/protocol/disco#items" 'jabber-return-disco-info))
 129 (defun jabber-return-disco-info (jc xml-data)
 130   "Respond to a service discovery request.
 131 See JEP-0030."
 132   (let* ((to (jabber-xml-get-attribute xml-data 'from))
 133          (id (jabber-xml-get-attribute xml-data 'id))
 134          (xmlns (jabber-iq-xmlns xml-data))
 135          (which-alist (eval (cdr (assoc xmlns
 136                                         (list
 137                                          (cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes)
 138                                          (cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes))))))
 139          (node (or
 140                 (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)
 141                 ""))
 142          (return-list (cdr (assoc node which-alist)))
 143          (func (nth 0 return-list))
 144          (access-control (nth 1 return-list)))
 145     (if return-list
 146         (if (and (functionp access-control)
 147                  (not (funcall access-control to)))
 148             (jabber-signal-error "cancel" 'not-allowed)
 149           ;; Access control passed
 150           (let ((result (if (functionp func)
 151                             (funcall func jc xml-data)
 152                           func)))
 153             (jabber-send-iq jc to "result"
 154                             `(query ((xmlns . ,xmlns)
 155                                      ,@(when node
 156                                          (list (cons 'node node))))
 157                                     ,@result)
 158                             nil nil nil nil id)))
 159
 160       ;; No such node
 161       (jabber-signal-error "cancel" 'item-not-found))))
 162
 163 (defun jabber-disco-return-client-info (jc xml-data)
 164   `(
 165     ;; If running under a window system, this is
 166     ;; a GUI client.  If not, it is a console client.
 167     (identity ((category . "client")
 168                (name . "Emacs Jabber client")
 169                (type . ,(if (memq window-system
 170                                   '(x w32 mac))
 171                             "pc"
 172                           "console"))))
 173     ,@(mapcar
 174        #'(lambda (featurename)
 175            `(feature ((var . ,featurename))))
 176        jabber-advertised-features)))
 177
 178 (add-to-list 'jabber-jid-info-menu
 179              (cons "Send items disco query" 'jabber-get-disco-items))
 180 (defun jabber-get-disco-items (jc to &optional node)
 181   "Send a service discovery request for items"
 182   (interactive (list (jabber-read-account)
 183                      (jabber-read-jid-completing "Send items disco request to: ")
 184                      (jabber-read-node "Node (or leave empty): ")))
 185   (jabber-send-iq jc to
 186                   "get"
 187                   (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items"))
 188                                        (if (> (length node) 0)
 189                                            (list (cons 'node node)))))
 190                   #'jabber-process-data #'jabber-process-disco-items
 191                   #'jabber-process-data "Item discovery failed"))
 192
 193 (add-to-list 'jabber-jid-info-menu
 194              (cons "Send info disco query" 'jabber-get-disco-info))
 195 (defun jabber-get-disco-info (jc to &optional node)
 196   "Send a service discovery request for info"
 197   (interactive (list (jabber-read-account)
 198                      (jabber-read-jid-completing "Send info disco request to: ")
 199                      (jabber-read-node "Node (or leave empty): ")))
 200   (jabber-send-iq jc to
 201                   "get"
 202                   (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info"))
 203                                        (if (> (length node) 0)
 204                                            (list (cons 'node node)))))
 205                   #'jabber-process-data #'jabber-process-disco-info
 206                   #'jabber-process-data "Info discovery failed"))
 207
 208 (provide 'jabber-disco)
 209
 210 ;;; arch-tag: 71f5c76f-2956-4ed2-b871-9f5fe198092d