jabber-ahc.el

   1 ;; jabber-ahc.el - Ad-Hoc Commands by JEP-0050
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - 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 (require 'jabber-disco)
  23 (require 'jabber-widget)
  24 (require 'jabber-autoloads)
  25
  26 (defvar jabber-ahc-sessionid nil
  27   "session id of Ad-Hoc Command session")
  28
  29 (defvar jabber-ahc-node nil
  30   "node to send commands to")
  31
  32 (defvar jabber-ahc-commands nil
  33   "Commands provided
  34
  35 This is an alist, where the keys are node names as strings (which
  36 means that they must not conflict).  The values are plists having
  37 following properties:
  38
  39 acl     - function taking connection object and JID of requester,
  40           returning non-nil for access allowed.  No function means
  41           open for everyone.
  42 name    - name of command
  43 func    - function taking connection object and entire IQ stanza as
  44           arguments and returning a <command/> node
  45
  46 Use the function `jabber-ahc-add' to add a command to this list.")
  47
  48
  49 ;;; SERVER
  50 (add-to-list 'jabber-disco-info-nodes
  51              (list "http://jabber.org/protocol/commands"
  52                    '((identity ((category . "automation")
  53                                 (type . "command-list")
  54                                 (name . "Ad-Hoc Command list")))
  55                      (feature ((var . "http://jabber.org/protocol/commands")))
  56                      (feature ((var . "http://jabber.org/protocol/disco#items")))
  57                      (feature
  58                       ((var . "http://jabber.org/protocol/disco#info"))))))
  59
  60 (defun jabber-ahc-add (node name func acl)
  61   "Add a command to internal lists.
  62 NODE is the node name to be used.  It must be unique.
  63 NAME is the natural-language name of the command.
  64 FUNC is a function taking the entire IQ stanza as single argument when
  65 this command is invoked, and returns a <command/> node.
  66 ACL is a function taking JID as single argument, returning non-nil for
  67 access allowed.  nil means open for everyone."
  68   (add-to-list 'jabber-ahc-commands (cons node (list 'name name
  69                                                      'func func
  70                                                      'acl acl)))
  71   (add-to-list 'jabber-disco-info-nodes
  72                (list node `((identity ((category . "automation")
  73                                        (type . "command-node")
  74                                        (name . ,name)))
  75                             (feature ((var . "http://jabber.org/protocol/commands")))
  76                             (feature ((var . "http://jabber.org/protocol/disco#info")))
  77                             (feature ((var . "jabber:x:data")))))))
  78
  79 (add-to-list 'jabber-advertised-features "http://jabber.org/protocol/commands")
  80 (add-to-list 'jabber-disco-items-nodes
  81              (list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil))
  82 (defun jabber-ahc-disco-items (jc xml-data)
  83   "Return commands in response to disco#items request"
  84   (let ((jid (jabber-xml-get-attribute xml-data 'from)))
  85     (mapcar (function
  86              (lambda (command)
  87                (let ((node (car command))
  88                      (plist (cdr command)))
  89                  (let ((acl (plist-get plist 'acl))
  90                        (name (plist-get plist 'name))
  91                        (func (plist-get plist 'func)))
  92                    (when (or (not (functionp acl))
  93                              (funcall acl jc jid))
  94                      `(item ((name . ,name)
  95                              (jid . ,(jabber-connection-jid jc))
  96                              (node . ,node))))))))
  97             jabber-ahc-commands)))
  98
  99 (add-to-list 'jabber-iq-set-xmlns-alist
 100              (cons "http://jabber.org/protocol/commands" 'jabber-ahc-process))
 101 (defun jabber-ahc-process (jc xml-data)
 102
 103   (let ((to (jabber-xml-get-attribute xml-data 'from))
 104         (id (jabber-xml-get-attribute xml-data 'id))
 105         (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node)))
 106     ;; find command
 107     (let* ((plist (cdr (assoc node jabber-ahc-commands)))
 108            (acl (plist-get plist 'acl))
 109            (func (plist-get plist 'func)))
 110       (if plist
 111           ;; found
 112           (if (or (not (functionp acl))
 113                   (funcall acl jc to))
 114               ;; access control passed
 115               (jabber-send-iq jc to "result"
 116                               (funcall func jc xml-data)
 117                               nil nil nil nil id)
 118             ;; ...or failed
 119             (jabber-signal-error "cancel" 'not-allowed))
 120         ;; No such node
 121         (jabber-signal-error "cancel" 'item-not-found)))))
 122
 123 ;;; CLIENT
 124 (add-to-list 'jabber-jid-service-menu
 125              (cons "Request command list" 'jabber-ahc-get-list))
 126 (defun jabber-ahc-get-list (jc to)
 127   "Request list of ad-hoc commands.  (JEP-0050)"
 128   (interactive (list (jabber-read-account)
 129                      (jabber-read-jid-completing "Request command list from: ")))
 130   (jabber-get-disco-items jc to "http://jabber.org/protocol/commands"))
 131
 132 (add-to-list 'jabber-jid-service-menu
 133              (cons "Execute command" 'jabber-ahc-execute-command))
 134 (defun jabber-ahc-execute-command (jc to node)
 135   "Execute ad-hoc command.  (JEP-0050)"
 136   (interactive (list (jabber-read-account)
 137                      (jabber-read-jid-completing "Execute command of: ")
 138                      (jabber-read-node "Node of command: ")))
 139   (jabber-send-iq jc to
 140                   "set"
 141                   `(command ((xmlns . "http://jabber.org/protocol/commands")
 142                              (node . ,node)
 143                              (action . "execute")))
 144                   #'jabber-process-data #'jabber-ahc-display
 145                   #'jabber-process-data "Command execution failed"))
 146
 147 (defun jabber-ahc-display (jc xml-data)
 148   (let* ((from (jabber-xml-get-attribute xml-data 'from))
 149          (query (jabber-iq-query xml-data))
 150          (node (jabber-xml-get-attribute query 'node))
 151          (notes (jabber-xml-get-children query 'note))
 152          (sessionid (jabber-xml-get-attribute query 'sessionid))
 153          (status (jabber-xml-get-attribute query 'status))
 154          (actions (car (jabber-xml-get-children query 'actions)))
 155          xdata
 156          (inhibit-read-only t))
 157
 158     (make-local-variable 'jabber-ahc-sessionid)
 159     (setq jabber-ahc-sessionid sessionid)
 160     (make-local-variable 'jabber-ahc-node)
 161     (setq jabber-ahc-node node)
 162     (make-local-variable 'jabber-buffer-connection)
 163     (setq jabber-buffer-connection jc)
 164
 165     (dolist (x (jabber-xml-get-children query 'x))
 166       (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")
 167         (setq xdata x)))
 168
 169     (cond
 170      ((string= status "executing")
 171       (insert "Executing command\n\n"))
 172      ((string= status "completed")
 173       (insert "Command completed\n\n"))
 174      ((string= status "canceled")
 175       (insert "Command canceled\n\n")))
 176
 177     (dolist (note notes)
 178       (let ((note-type (jabber-xml-get-attribute note 'type)))
 179         (cond
 180          ((string= note-type "warn")
 181           (insert "Warning: "))
 182          ((string= note-type "error")
 183           (insert "Error: ")))
 184         (insert (car (jabber-xml-node-children note)) "\n")))
 185     (insert "\n")
 186
 187     (when xdata
 188       (jabber-init-widget-buffer from)
 189
 190       (let ((formtype (jabber-xml-get-attribute xdata 'type)))
 191         (if (string= formtype "result")
 192             (jabber-render-xdata-search-results xdata)
 193           (jabber-render-xdata-form xdata)
 194
 195           (when (string= status "executing")
 196             (let ((button-titles
 197                    (cond
 198                     ((null actions)
 199                      '(complete cancel))
 200                     (t
 201                      (let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions)))
 202                            (default-action (jabber-xml-get-attribute actions 'execute)))
 203                        (if (or (null default-action) (memq (intern default-action) children))
 204                            children
 205                          (cons (intern default-action) children)))))))
 206               (dolist (button-title button-titles)
 207                 (widget-create 'push-button :notify `(lambda (&rest ignore) (jabber-ahc-submit (quote ,button-title))) (symbol-name button-title))
 208                 (widget-insert "\t")))
 209             (widget-insert "\n"))))
 210
 211       (widget-setup)
 212       (widget-minor-mode 1))))
 213
 214 (defun jabber-ahc-submit (action)
 215   "Submit Ad-Hoc Command."
 216
 217   (jabber-send-iq jabber-buffer-connection jabber-submit-to
 218                   "set"
 219                   `(command ((xmlns . "http://jabber.org/protocol/commands")
 220                              (sessionid . ,jabber-ahc-sessionid)
 221                              (node . ,jabber-ahc-node)
 222                              (action . ,(symbol-name action)))
 223                             ,(if (and (not (eq action 'cancel))
 224                                       (eq jabber-form-type 'xdata))
 225                                  (jabber-parse-xdata-form)))
 226
 227                   #'jabber-process-data #'jabber-ahc-display
 228                   #'jabber-process-data "Command execution failed"))
 229
 230 (provide 'jabber-ahc)
 231
 232 ;;; arch-tag: c0d5ed8c-50cb-44e1-8e0f-4058b79ee353