djavu-asus/elpa/jabber-20230715.456/jabber-ahc.el

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