diff --git a/jabber.el b/jabber.el index f596a85..f045c4c 100644 --- a/jabber.el +++ b/jabber.el @@ -32,12527 +32,10 @@ ;;; Code: -(require 'goto-addr) +(require 'literate-elisp) -(require 'xml) -(eval-when-compile - (require 'cl)) - -(defun jabber-escape-xml (str) - "Escape strings for XML. -STR the string to escape." - (if (stringp str) - (let ((newstr (concat str))) - ;; Form feeds might appear in code you copy, etc. Nevertheless, - ;; it's invalid XML. - (setq newstr (jabber-replace-in-string newstr "\f" "\n")) - ;; Other control characters are also illegal, except for - ;; tab, CR, and LF. - (setq newstr (jabber-replace-in-string newstr "[\000-\010\013\014\016-\037]" " ")) - (setq newstr (jabber-replace-in-string newstr "&" "&")) - (setq newstr (jabber-replace-in-string newstr "<" "<")) - (setq newstr (jabber-replace-in-string newstr ">" ">")) - (setq newstr (jabber-replace-in-string newstr "'" "'")) - (setq newstr (jabber-replace-in-string newstr "\"" """)) - newstr) - str)) - -(defun jabber-unescape-xml (str) - "Unescape xml strings. -STR the string to remove escaped characters." - ;; Eventually this can be done with `xml-substitute-special', but the - ;; version in xml.el of GNU Emacs 21.3 is buggy. - (if (stringp str) - (let ((newstr str)) - (setq newstr (jabber-replace-in-string newstr """ "\"")) - (setq newstr (jabber-replace-in-string newstr "'" "'")) - (setq newstr (jabber-replace-in-string newstr ">" ">")) - (setq newstr (jabber-replace-in-string newstr "<" "<")) - (setq newstr (jabber-replace-in-string newstr "&" "&")) - newstr) - str)) - -(defun jabber-sexp2xml (sexp) - "Return SEXP as well-formatted XML. -SEXP should be in the form (tagname ((attribute-name . attribute-value)...) children...)" - (cond - ((stringp sexp) - (jabber-escape-xml sexp)) - ((listp (car sexp)) - (let ((xml "")) - (dolist (tag sexp) - (setq xml (concat xml (jabber-sexp2xml tag)))) - xml)) - ;; work around bug in old versions of xml.el, where ("") can appear - ;; as children of a node - ((and (consp sexp) - (stringp (car sexp)) - (zerop (length (car sexp)))) - "") - (t - (let ((xml "")) - (setq xml (concat "<" - (symbol-name (car sexp)))) - (dolist (attr (cadr sexp)) - (if (consp attr) - (setq xml (concat xml - (format " %s='%s'" - (symbol-name (car attr)) - (jabber-escape-xml (cdr attr))))))) - (if (cddr sexp) - (progn - (setq xml (concat xml ">")) - (dolist (child (cddr sexp)) - (setq xml (concat xml - (jabber-sexp2xml child)))) - (setq xml (concat xml - ""))) - (setq xml (concat xml - "/>"))) - xml)))) - -(defun jabber-xml-skip-tag-forward (&optional dont-recurse-into-stream) - "Skip to end of tag or matching closing tag if present. -Return t iff after a closing tag, otherwise throws an 'unfinished -tag with value nil. -If DONT-RECURSE-INTO-STREAM is non-nil, stop after an opening - tag. - -The version of `sgml-skip-tag-forward' in Emacs 21 isn't good -enough for us." - (skip-chars-forward "^<") - (cond - ((looking-at "" nil t) - (goto-char (match-end 0)) - (throw 'unfinished nil))) - ((looking-at "<\\([^[:space:]/>]+\\)\\([[:space:]]+[^=>]+=[[:space:]]*'[^']*'\\|[[:space:]]+[^=>]+=[[:space:]]*\"[^\"]*\"\\)*") - (let ((node-name (match-string 1))) - (goto-char (match-end 0)) - (skip-syntax-forward "\s-") ; Skip over trailing white space. - (cond - ((looking-at "/>") - (goto-char (match-end 0)) - t) - ((looking-at ">") - (goto-char (match-end 0)) - (unless (and dont-recurse-into-stream (equal node-name "stream:stream")) - (loop - do (skip-chars-forward "^<") - until (looking-at (regexp-quote (concat ""))) - do (jabber-xml-skip-tag-forward)) - (goto-char (match-end 0))) - t) - (t - (throw 'unfinished nil))))) - (t - (throw 'unfinished nil)))) - -(defun jabber-xml-parse-next-stanza () - "Parse the first XML stanza in the current buffer. -Parse and return the first complete XML element in the buffer, -leaving point at the end of it. If there is no complete XML -element, return nil." - (and (catch 'unfinished - (goto-char (point-min)) - (jabber-xml-skip-tag-forward) - (> (point) (point-min))) - (xml-parse-region (point-min) (point)))) - -(defsubst jabber-xml-node-name (node) - "Return the tag associated with NODE. -The tag is a lower-case symbol." - (if (listp node) (car node))) - -(defsubst jabber-xml-node-attributes (node) - "Return the list of attributes of NODE. -The list can be nil." - (if (listp node) (nth 1 node))) - -(defsubst jabber-xml-node-children (node) - "Return the list of children of NODE. -This is a list of nodes, and it can be nil." - (let ((children (cddr node))) - ;; Work around a bug in early versions of xml.el - (if (equal children '((""))) - nil - children))) - -(defun jabber-xml-get-children (node child-name) - "Return the children of NODE whose tag is CHILD-NAME. -CHILD-NAME should be a lower case symbol." - (let ((match ())) - (dolist (child (jabber-xml-node-children node)) - (if child - (if (equal (jabber-xml-node-name child) child-name) - (push child match)))) - (nreverse match))) - -(defsubst jabber-xml-get-attribute (node attribute) - "Get from NODE the value of ATTRIBUTE. -Return nil if the attribute was not found." - (when (consp node) - (xml-get-attribute-or-nil node attribute))) - -(defsubst jabber-xml-get-xmlns (node) - "Get \"xmlns\" attribute of NODE, or nil if not present." - (jabber-xml-get-attribute node 'xmlns)) - -(defun jabber-xml-path (xml-data path) - "Find sub-node of XML-DATA according to PATH. -PATH is a vaguely XPath-inspired list. Each element can be: - -a symbol go to first child node with this node name -cons cell car is string containing namespace URI, - cdr is string containing node name. Find - first matching child node. -any string character data of this node." - (let ((node xml-data)) - (while (and path node) - (let ((step (car path))) - (cond - ((symbolp step) - (setq node (car (jabber-xml-get-children node step)))) - ((consp step) - ;; This will be easier with namespace-aware use - ;; of xml.el. It will also be more correct. - ;; Now, it only matches explicit namespace declarations. - (setq node - (dolist (x (jabber-xml-get-children node (intern (cdr step)))) - (when (string= (jabber-xml-get-attribute x 'xmlns) - (car step)) - (return x))))) - ((stringp step) - (setq node (car (jabber-xml-node-children node))) - (unless (stringp node) - (setq node nil))) - (t - (error "Unknown path step: %s" step)))) - (setq path (cdr path))) - node)) - -(defmacro jabber-xml-let-attributes (attributes xml-data &rest body) - "Bind variables to the same-name attribute values in XML-DATA. -ATTRIBUTES is a list of attribute names." - `(let ,(mapcar #'(lambda (attr) - (list attr `(jabber-xml-get-attribute ,xml-data ',attr))) - attributes) - ,@body)) -(put 'jabber-xml-let-attributes 'lisp-indent-function 2) - -(defun jabber-xml-resolve-namespace-prefixes (xml-data &optional default-ns prefixes) - (let ((node-name (jabber-xml-node-name xml-data)) - (attrs (jabber-xml-node-attributes xml-data))) - (setq prefixes (jabber-xml-merge-namespace-declarations attrs prefixes)) - - ;; If there is an xmlns attribute, it is the new default - ;; namespace. - (let ((xmlns (jabber-xml-get-xmlns xml-data))) - (when xmlns - (setq default-ns xmlns))) - ;; Now, if the node name has a prefix, replace it and add an - ;; "xmlns" attribute. Slightly ugly, but avoids the need to - ;; change all the rest of jabber.el at once. - (let ((node-name-string (symbol-name node-name))) - (when (string-match "\\(.*\\):\\(.*\\)" node-name-string) - (let* ((prefix (match-string 1 node-name-string)) - (unprefixed (match-string 2 node-name-string)) - (ns (assoc prefix prefixes))) - (if (null ns) - ;; This is not supposed to happen... - (message "jabber-xml-resolve-namespace-prefixes: Unknown prefix in %s" node-name-string) - (setf (car xml-data) (intern unprefixed)) - (setf (cadr xml-data) (cons (cons 'xmlns (cdr ns)) (delq 'xmlns attrs))))))) - ;; And iterate through all child elements. - (mapc (lambda (x) - (when (listp x) - (jabber-xml-resolve-namespace-prefixes x default-ns prefixes))) - (jabber-xml-node-children xml-data)) - xml-data)) - -(defun jabber-xml-merge-namespace-declarations (attrs prefixes) - ;; First find any xmlns:foo attributes.. - (dolist (attr attrs) - (let ((attr-name (symbol-name (car attr)))) - (when (string-match "xmlns:" attr-name) - (let ((prefix (substring attr-name (match-end 0))) - (ns-uri (cdr attr))) - ;; A slightly complicated dance to never change the - ;; original value of prefixes (since the caller depends on - ;; it), but also to avoid excessive copying (which remove - ;; always does). Might need to profile and tweak this for - ;; performance. - (setq prefixes - (cons (cons prefix ns-uri) - (if (assoc prefix prefixes) - (remove (assoc prefix prefixes) prefixes) - prefixes))))))) - prefixes) - -(require 'cl) -(require 'password-cache) -(condition-case nil - (require 'auth-source) - (error nil)) - -(defvar jabber-jid-history nil - "History of entered JIDs.") - -(defsubst jabber-replace-in-string (str regexp newtext) - (replace-regexp-in-string regexp newtext str t t)) - -(defalias 'jabber-propertize 'propertize) - -(unless (fboundp 'bound-and-true-p) - (defmacro bound-and-true-p (var) - "Return the value of symbol VAR if it is bound, else nil." - `(and (boundp (quote ,var)) ,var))) - -(defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value) - (read-string prompt initial-contents history default-value t)) - -(unless (fboundp 'delete-and-extract-region) - (defsubst delete-and-extract-region (start end) - (prog1 - (buffer-substring start end) - (delete-region start end)))) - -(unless (fboundp 'access-file) - (defsubst access-file (filename error-message) - (unless (file-readable-p filename) - (error error-message)))) - - (defalias 'jabber-float-time 'float-time) - -(defalias 'jabber-cancel-timer 'cancel-timer) - -(defun jabber-concat-rosters () - "Concatenate the rosters of all connected accounts." - (apply #'append - (mapcar - (lambda (jc) - (plist-get (fsm-get-state-data jc) :roster)) - jabber-connections))) - -(defun jabber-concat-rosters-full () - "Concatenate the rosters of all connected accounts. -Show full JIDs, with resources." - (let ((jids (apply #'append - (mapcar - (lambda (jc) - (plist-get (fsm-get-state-data jc) :roster)) - jabber-connections)))) - (apply #'append - (mapcar (lambda (jid) - (mapcar (lambda (res) (intern (format "%s/%s" jid (car res)))) - (get (jabber-jid-symbol jid) 'resources))) - jids)))) - -(defun jabber-connection-jid (jc) - "Return the full JID of connection JC." - (let ((sd (fsm-get-state-data jc))) - (concat (plist-get sd :username) "@" - (plist-get sd :server) "/" - (plist-get sd :resource)))) - -(defun jabber-connection-bare-jid (jc) - "Return the bare JID of connection JC." - (let ((sd (fsm-get-state-data jc))) - (concat (plist-get sd :username) "@" - (plist-get sd :server)))) - -(defun jabber-connection-original-jid (jc) - "Return the original JID of connection JC. -The \"original JID\" is the JID we authenticated with. The -server might subsequently assign us a different JID at resource -binding." - (plist-get (fsm-get-state-data jc) :original-jid)) - -(defun jabber-find-connection (bare-jid) - "Find the connection to the account named by BARE-JID. -Return nil if none found." - (dolist (jc jabber-connections) - (when (string= bare-jid (jabber-connection-bare-jid jc)) - (return jc)))) - -(defun jabber-find-active-connection (dead-jc) - "Find an active connection for dead connection DEAD-JC. -Return nil if none found." - (let ((jid (jabber-connection-bare-jid dead-jc))) - (jabber-find-connection jid))) - -(defun jabber-jid-username (jid) - "Return the username portion of JID, or nil if none found. -JID must be a string." - (when (string-match "\\(.*\\)@.*\\(/.*\\)?" jid) - (match-string 1 jid))) - -(defun jabber-jid-user (jid) - "Return the user portion (username@server) of JID. -JID must be a string." - ;;transports don't have @, so don't require it - ;;(string-match ".*@[^/]*" jid) - (string-match "[^/]*" jid) - (match-string 0 jid)) - -(defun jabber-jid-server (jid) - "Return the server portion of JID." - (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" jid) - (match-string 2 jid)) - -(defun jabber-jid-rostername (string) - "Return the name of the user from STRING as in roster, else nil." - (let ((user (jabber-jid-symbol string))) - (if (> (length (get user 'name)) 0) - (get user 'name)))) - -(defun jabber-jid-displayname (string) - "Return the name of the user from STRING as in roster, else username@server." - (or (jabber-jid-rostername string) - (jabber-jid-user (if (symbolp string) - (symbol-name string) - string)))) - -(defun jabber-jid-bookmarkname (string) - "Return from STRING the conference name from boomarks or displayname. -Use the name according to roster or else the JID if none set." - (or (loop for conference in (first (loop for value being the hash-values of jabber-bookmarks - collect value)) - do (let ((ls (cadr conference))) - (if (string= (cdr (assoc 'jid ls)) string) - (return (cdr (assoc 'name ls)))))) - (jabber-jid-displayname string))) - -(defun jabber-jid-resource (jid) - "Return the resource portion of a JID, or nil if there is none. -JID must be a string." - (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" jid) - (match-string 3 jid))) - -(defun jabber-jid-symbol (jid) - "Return the symbol for the given JID. -JID must be a string." - ;; If it's already a symbol, just return it. - (if (symbolp jid) - jid - ;; XXX: "downcase" is poor man's nodeprep. See XMPP CORE. - (intern (downcase (jabber-jid-user jid)) jabber-jid-obarray))) - -(defun jabber-my-jid-p (jc jid) - "Return non-nil if the specified JID is in the `jabber-account-list'. -Comment: (modulo resource). -Also return non-nil if JID matches JC, modulo resource." - (or - (equal (jabber-jid-user jid) - (jabber-connection-bare-jid jc)) - (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list)))) - -(defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids) - "Read a jid out of the current roster from the minibuffer. -If SUBSET is non-nil, it should be a list of symbols from which -the JID is to be selected, instead of using the entire roster. -If REQUIRE-MATCH is non-nil, the JID must be in the list used. -If DEFAULT is non-nil, it's used as the default value, otherwise -the default is inferred from context. -RESOURCE is one of the following: - -nil Accept full or bare JID, as entered -full Turn bare JIDs to full ones with highest-priority resource -bare-or-muc Turn full JIDs to bare ones, except for in MUC - -If FULLJIDS is non-nil, complete jids with resources." - (let ((jid-at-point (or - (and default - ;; default can be either a symbol or a string - (if (symbolp default) - (symbol-name default) - default)) - (let* ((jid (get-text-property (point) 'jabber-jid)) - (res (get (jabber-jid-symbol jid) 'resource))) - (when jid - (if (and fulljids res (not (jabber-jid-resource jid))) - (format "%s/%s" jid res) - jid))) - (bound-and-true-p jabber-chatting-with) - (bound-and-true-p jabber-group))) - (completion-ignore-case t) - (jid-completion-table (mapcar #'(lambda (item) - (cons (symbol-name item) item)) - (or subset (funcall (if fulljids - 'jabber-concat-rosters-full - 'jabber-concat-rosters))))) - chosen) - (dolist (item (or subset (jabber-concat-rosters))) - (if (get item 'name) - (push (cons (get item 'name) item) jid-completion-table))) - ;; if the default is not in the allowed subset, it's not a good default - (if (and subset (not (assoc jid-at-point jid-completion-table))) - (setq jid-at-point nil)) - (let ((input - (completing-read (concat prompt - (if jid-at-point - (format "(default %s) " jid-at-point))) - jid-completion-table - nil require-match nil 'jabber-jid-history jid-at-point))) - (setq chosen - (if (and input (assoc-string input jid-completion-table t)) - (symbol-name (cdr (assoc-string input jid-completion-table t))) - (and (not (zerop (length input))) - input)))) - - (when chosen - (case resource - (full - ;; If JID is bare, add the highest-priority resource. - (if (jabber-jid-resource chosen) - chosen - (let ((highest-resource (get (jabber-jid-symbol chosen) 'resource))) - (if highest-resource - (concat chosen "/" highest-resource) - chosen)))) - (bare-or-muc - ;; If JID is full and non-MUC, remove resource. - (if (null (jabber-jid-resource chosen)) - chosen - (let ((bare (jabber-jid-user chosen))) - (if (assoc bare *jabber-active-groupchats*) - chosen - bare)))) - (t - chosen))))) - -(defun jabber-read-node (prompt) - "Read node name, taking default from disco item at point." - (let ((node-at-point (get-text-property (point) 'jabber-node))) - (read-string (concat prompt - (if node-at-point - (format "(default %s) " node-at-point))) - node-at-point))) - -(defun jabber-password-key (bare-jid) - "Construct key for `password' library from BARE-JID." - (concat "xmpp:" bare-jid)) - -(defun jabber-read-password (bare-jid) - "Read Jabber password from minibuffer." - (let ((found - (and (fboundp 'auth-source-search) - (nth 0 (auth-source-search - :user (jabber-jid-username bare-jid) - :host (jabber-jid-server bare-jid) - :port "xmpp" - :max 1 - :require '(:secret)))))) - (if found - (let ((secret (plist-get found :secret))) - (copy-sequence - (if (functionp secret) - (funcall secret) - secret))) - (let ((prompt (format "Jabber password for %s: " bare-jid))) - ;; Need to copy the password, as sasl.el wants to erase it. - (copy-sequence - (password-read prompt (jabber-password-key bare-jid))))))) - -(defun jabber-cache-password (bare-jid password) - "Cache PASSWORD for BARE-JID." - (password-cache-add (jabber-password-key bare-jid) password)) - -(defun jabber-uncache-password (bare-jid) - "Uncache cached password for BARE-JID. -Useful if the password proved to be wrong." - (interactive (list (jabber-jid-user - (completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history)))) - (password-cache-remove (jabber-password-key bare-jid))) - -(defun jabber-read-account (&optional always-ask contact-hint) - "Ask for which connected account to use. -If ALWAYS-ASK is nil and there is only one account, return that -account. -If CONTACT-HINT is a string or a JID symbol, default to an account -that has that contact in its roster." - (let ((completions - (mapcar (lambda (c) - (cons - (jabber-connection-bare-jid c) - c)) - jabber-connections))) - (cond - ((null jabber-connections) - (error "Not connected to Jabber")) - ((and (null (cdr jabber-connections)) (not always-ask)) - ;; only one account - (car jabber-connections)) - (t - (or - ;; if there is a jabber-account property at point, - ;; present it as default value - (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account))) - (when (and at-point - (memq at-point jabber-connections)) - (jabber-connection-bare-jid at-point))) completions)) - (let* ((default - (or - (and contact-hint - (setq contact-hint (jabber-jid-symbol contact-hint)) - (let ((matching - (find-if - (lambda (jc) - (memq contact-hint (plist-get (fsm-get-state-data jc) :roster))) - jabber-connections))) - (when matching - (jabber-connection-bare-jid matching)))) - ;; if the buffer is associated with a connection, use it - (when (and jabber-buffer-connection - (jabber-find-active-connection jabber-buffer-connection)) - (jabber-connection-bare-jid jabber-buffer-connection)) - ;; else, use the first connection in the list - (caar completions))) - (input (completing-read - (concat "Select Jabber account (default " - default - "): ") - completions nil t nil 'jabber-account-history - default))) - (cdr (assoc input completions)))))))) - -(defun jabber-iq-query (xml-data) - "Return the query part of an IQ stanza. -An IQ stanza may have zero or one query child, and zero or one child. -The query child is often but not always . - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let (query) - (dolist (x (jabber-xml-node-children xml-data)) - (if (and - (listp x) - (not (eq (jabber-xml-node-name x) 'error))) - (setq query x))) - query)) - -(defun jabber-iq-error (xml-data) - "Return the part of an IQ stanza, if any. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (car (jabber-xml-get-children xml-data 'error))) - -(defun jabber-iq-xmlns (xml-data) - "Return the namespace of an IQ stanza, i.e. the namespace of its query part. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns)) - -(defun jabber-message-timestamp (xml-data) - "Given a element, return its timestamp, or nil if none. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (jabber-x-delay - (or - (jabber-xml-path xml-data '(("urn:xmpp:delay" . "delay"))) - (jabber-xml-path xml-data '(("jabber:x:delay" . "x")))))) - -(defun jabber-x-delay (xml-data) - "Return timestamp given a delayed delivery element. -This can be either a tag in namespace urn:xmpp:delay (XEP-0203), or -a tag in namespace jabber:x:delay (XEP-0091). -Return nil if no such data available. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (cond - ((and (eq (jabber-xml-node-name xml-data) 'x) - (string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay")) - (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) - (if (and (stringp stamp) - (= (length stamp) 17)) - (jabber-parse-legacy-time stamp)))) - ((and (eq (jabber-xml-node-name xml-data) 'delay) - (string= (jabber-xml-get-attribute xml-data 'xmlns) "urn:xmpp:delay")) - (let ((stamp (jabber-xml-get-attribute xml-data 'stamp))) - (when (stringp stamp) - (jabber-parse-time stamp)))))) - -(defun jabber-parse-legacy-time (timestamp) - "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value." - (let ((year (string-to-number (substring timestamp 0 4))) - (month (string-to-number (substring timestamp 4 6))) - (day (string-to-number (substring timestamp 6 8))) - (hour (string-to-number (substring timestamp 9 11))) - (minute (string-to-number (substring timestamp 12 14))) - (second (string-to-number (substring timestamp 15 17)))) - (encode-time second minute hour day month year 0))) - -(defun jabber-encode-legacy-time (timestamp) - "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)." - (if (featurep 'xemacs) - ;; XEmacs doesn't have `universal' argument to format-time-string, - ;; so we have to do it ourselves. - (format-time-string "%Y%m%dT%H:%M:%S" - (time-subtract timestamp - (list 0 (car (current-time-zone))))) - (format-time-string "%Y%m%dT%H:%M:%S" timestamp t))) - -(defun jabber-encode-time (time) - "Convert TIME to a string by XEP-0082. -TIME is in a format accepted by `format-time-string'." - (format-time-string "%Y-%m-%dT%H:%M:%SZ" time t)) - -(defun jabber-encode-timezone () - (let ((time-zone-offset (nth 0 (current-time-zone)))) - (if (null time-zone-offset) - "Z" - (let* ((positivep (>= time-zone-offset 0)) - (hours (/ (abs time-zone-offset) 3600)) - (minutes (/ (% (abs time-zone-offset) 3600) 60))) - (format "%s%02d:%02d"(if positivep "+" "-") hours minutes))))) - -(defun jabber-parse-time (raw-time) - "Parse the DateTime encoded in TIME according to XEP-0082." - (let* ((time (if (string= (substring raw-time 4 5) "-") - raw-time - (concat - (substring raw-time 0 4) "-" - (substring raw-time 4 6) "-" - (substring raw-time 6 (length raw-time))))) - (year (string-to-number (substring time 0 4))) - (month (string-to-number (substring time 5 7))) - (day (string-to-number (substring time 8 10))) - (hour (string-to-number (substring time 11 13))) - (minute (string-to-number (substring time 14 16))) - (second (string-to-number (substring time 17 19))) - (timezone (if (eq (aref time 19) ?.) - ;; fractions are optional - (let ((timezone (cadr - (split-string (substring time 20) - "[-+Z]")))) - (if (string= "" timezone) - "Z" - timezone)) - (substring time 19)))) - ;; timezone is either Z (UTC) or [+-]HH:MM - (let ((timezone-seconds - (if (string= timezone "Z") - 0 - (* (if (eq (aref timezone 0) ?+) 1 -1) - (* 60 (+ (* 60 (string-to-number (substring timezone 1 3))) - (string-to-number (substring timezone 4 6)))))))) - (encode-time second minute hour day month year timezone-seconds)))) - -(defun jabber-report-success (jc xml-data context) - "IQ callback reporting success or failure of the operation. -CONTEXT is a string describing the action. -\"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in -the echo area. -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((type (jabber-xml-get-attribute xml-data 'type))) - (message (concat context - (if (string= type "result") - " succeeded" - (concat - " failed: " - (let ((the-error (jabber-iq-error xml-data))) - (if the-error - (jabber-parse-error the-error) - "No error message given")))))))) - -(defconst jabber-error-messages - (list - (cons 'bad-request "Bad request") - (cons 'conflict "Conflict") - (cons 'feature-not-implemented "Feature not implemented") - (cons 'forbidden "Forbidden") - (cons 'gone "Gone") - (cons 'internal-server-error "Internal server error") - (cons 'item-not-found "Item not found") - (cons 'jid-malformed "JID malformed") - (cons 'not-acceptable "Not acceptable") - (cons 'not-allowed "Not allowed") - (cons 'not-authorized "Not authorized") - (cons 'payment-required "Payment required") - (cons 'recipient-unavailable "Recipient unavailable") - (cons 'redirect "Redirect") - (cons 'registration-required "Registration required") - (cons 'remote-server-not-found "Remote server not found") - (cons 'remote-server-timeout "Remote server timeout") - (cons 'resource-constraint "Resource constraint") - (cons 'service-unavailable "Service unavailable") - (cons 'subscription-required "Subscription required") - (cons 'undefined-condition "Undefined condition") - (cons 'unexpected-request "Unexpected request")) - "String descriptions of XMPP stanza errors.") - -(defconst jabber-legacy-error-messages - (list - (cons 302 "Redirect") - (cons 400 "Bad request") - (cons 401 "Unauthorized") - (cons 402 "Payment required") - (cons 403 "Forbidden") - (cons 404 "Not found") - (cons 405 "Not allowed") - (cons 406 "Not acceptable") - (cons 407 "Registration required") - (cons 408 "Request timeout") - (cons 409 "Conflict") - (cons 500 "Internal server error") - (cons 501 "Not implemented") - (cons 502 "Remote server error") - (cons 503 "Service unavailable") - (cons 504 "Remote server timeout") - (cons 510 "Disconnected")) - "String descriptions of legacy errors (XEP-0086).") - -(defun jabber-parse-error (error-xml) - "Parse the given tag and return a string fit for human consumption. -See secton 9.3, Stanza Errors, of XMPP Core, and XEP-0086, Legacy Errors." - (let ((error-type (jabber-xml-get-attribute error-xml 'type)) - (error-code (jabber-xml-get-attribute error-xml 'code)) - condition text) - (if error-type - ;; If the tag has a type element, it is new-school. - (dolist (child (jabber-xml-node-children error-xml)) - (when (string= - (jabber-xml-get-attribute child 'xmlns) - "urn:ietf:params:xml:ns:xmpp-stanzas") - (if (eq (jabber-xml-node-name child) 'text) - (setq text (car (jabber-xml-node-children child))) - (setq condition - (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages)) - (symbol-name (jabber-xml-node-name child))))))) - (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages)) - error-code)) - (setq text (car (jabber-xml-node-children error-xml)))) - (concat condition - (if text (format ": %s" text))))) - -(defun jabber-error-condition (error-xml) - "Parse the given tag and return the condition symbol." - (catch 'condition - (dolist (child (jabber-xml-node-children error-xml)) - (when (string= - (jabber-xml-get-attribute child 'xmlns) - "urn:ietf:params:xml:ns:xmpp-stanzas") - (throw 'condition (jabber-xml-node-name child)))))) - -(defvar jabber-stream-error-messages - (list - (cons 'bad-format "Bad XML format") - (cons 'bad-namespace-prefix "Bad namespace prefix") - (cons 'conflict "Conflict") - (cons 'connection-timeout "Connection timeout") - (cons 'host-gone "Host gone") - (cons 'host-unknown "Host unknown") - (cons 'improper-addressing "Improper addressing") ; actually only s2s - (cons 'internal-server-error "Internal server error") - (cons 'invalid-from "Invalid from") - (cons 'invalid-id "Invalid id") - (cons 'invalid-namespace "Invalid namespace") - (cons 'invalid-xml "Invalid XML") - (cons 'not-authorized "Not authorized") - (cons 'policy-violation "Policy violation") - (cons 'remote-connection-failed "Remote connection failed") - (cons 'resource-constraint "Resource constraint") - (cons 'restricted-xml "Restricted XML") - (cons 'see-other-host "See other host") - (cons 'system-shutdown "System shutdown") - (cons 'undefined-condition "Undefined condition") - (cons 'unsupported-encoding "Unsupported encoding") - (cons 'unsupported-stanza-type "Unsupported stanza type") - (cons 'unsupported-version "Unsupported version") - (cons 'xml-not-well-formed "XML not well formed")) - "String descriptions of XMPP stream errors.") - -(defun jabber-stream-error-condition (error-xml) - "Return the condition of a tag." - ;; as we don't know the node name of the condition, we have to - ;; search for it. - (dolist (node (jabber-xml-node-children error-xml)) - (when (and (string= (jabber-xml-get-attribute node 'xmlns) - "urn:ietf:params:xml:ns:xmpp-streams") - (assq (jabber-xml-node-name node) - jabber-stream-error-messages)) - (return (jabber-xml-node-name node))))) - -(defun jabber-parse-stream-error (error-xml) - "Parse the given tag and return a sting fit for human consumption." - (let ((text-node (car (jabber-xml-get-children error-xml 'text))) - (condition (jabber-stream-error-condition error-xml))) - (concat (if condition (cdr (assq condition jabber-stream-error-messages)) - "Unknown stream error") - (if (and text-node (stringp (car (jabber-xml-node-children text-node)))) - (concat ": " (car (jabber-xml-node-children text-node))))))) - -(put 'jabber-error - 'error-conditions - '(error jabber-error)) -(put 'jabber-error - 'error-message - "Jabber error") - -(defun jabber-signal-error (error-type condition &optional text app-specific) - "Signal an error to be sent by Jabber. -ERROR-TYPE is one of \"Cancel\", \"Continue\", \"Mmodify\", \"Auth\" -and \"Wait\" (lowercase versions make `checkdoc' to throw errors). -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. - -See section 9.3 of XMPP Core (RFC 3920). -See section 8.3 of XMPP Core (RFC 6120)." - (signal 'jabber-error - (list (downcase error-type) condition text app-specific))) - -(defun jabber-unhex (string) - "Convert a hex-encoded UTF-8 string to Emacs representation. -For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes -\"jiři@čechy.example/v Praze\"." - (decode-coding-string (url-unhex-string string) 'utf-8)) - -(defun jabber-handle-uri (uri &rest ignored-args) - "Handle XMPP links according to draft-saintandre-xmpp-iri-04. -See Info node `(jabber)XMPP URIs'." - (interactive "sEnter XMPP URI: ") - - (when (string-match "//" uri) - (error "URIs with authority part are not supported")) - - ;; This regexp handles three cases: - ;; xmpp:romeo@montague.net - ;; xmpp:romeo@montague.net?roster - ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers - (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri) - (error "Invalid XMPP URI '%s'" uri)) - - ;; We start by raising the Emacs frame. - (raise-frame) - - (let ((jid (jabber-unhex (match-string 1 uri))) - (method (match-string 3 uri)) - (args (let ((text (match-string 5 uri))) - ;; If there are arguments... - (when text - ;; ...split the pairs by ';'... - (let ((pairs (split-string text ";"))) - (mapcar (lambda (pair) - ;; ...and split keys from values by '='. - (destructuring-bind (key value) - (split-string pair "=") - ;; Values can be hex-coded. - (cons key (jabber-unhex value)))) - pairs)))))) - ;; The full list of methods is at - ;; . - (cond - ;; Join an MUC. - ((string= method "join") - (let ((account (jabber-read-account))) - (jabber-muc-join - account jid (jabber-muc-read-my-nickname account jid) t))) - ;; Register with a service. - ((string= method "register") - (jabber-get-register (jabber-read-account) jid)) - ;; Run an ad-hoc command - ((string= method "command") - ;; XXX: does the 'action' attribute make sense? - (jabber-ahc-execute-command - (jabber-read-account) jid (cdr (assoc "node" args)))) - ;; Everything else: open a chat buffer. - (t - (jabber-chat-with (jabber-read-account) jid))))) - -(defun url-xmpp (url) - "Handle XMPP URLs from internal Emacs functions." - ;; XXX: This parsing roundtrip is redundant, and the parser of the - ;; url package might lose information. - (jabber-handle-uri (url-recreate-url url))) - -(defun string>-numerical (s1 s2) - "Return t if first arg string is more than second in numerical order." - (cond ((string= s1 s2) nil) - ((> (length s1) (length s2)) t) - ((< (length s1) (length s2)) nil) - ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil) - ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t) - (t (string>-numerical (substring s1 1) (substring s2 1))))) - -(defun jabber-append-string-to-file (string file &optional func &rest args) - "Append STRING (may be nil) to FILE. Create FILE if needed. -If FUNC is non-nil, then call FUNC with ARGS at beginning of -temporaly buffer _before_ inserting STRING." - (when (or (stringp string) (functionp func)) - (with-temp-buffer - (when (functionp func) (apply func args)) - (when (stringp string) (insert string)) - (write-region (point-min) (point-max) file t (list t))))) - -(defun jabber-tree-map (fn tree) - "Apply FN to all nodes in the TREE starting with root. -FN is applied to the node and not to the data itself." - (let ((result (cons nil nil))) - (do ((tail tree (cdr tail)) - (prev result end) - (end result (let* ((x (car tail)) - (val (if (atom x) - (funcall fn x) - (jabber-tree-map fn x)))) - (setf (car end) val (cdr end) (cons nil - nil))))) - ((atom tail) - (progn - (setf (cdr prev) (if tail (funcall fn tail) nil)) - result))))) - -(eval-when-compile (require 'cl)) - -;;;###autoload -(defvar jabber-menu - (let ((map (make-sparse-keymap "jabber-menu"))) - (define-key-after map - [jabber-menu-connect] - '("Connect" . jabber-connect-all)) - - (define-key-after map - [jabber-menu-disconnect] - '(menu-item "Disconnect" jabber-disconnect - :enable (bound-and-true-p jabber-connections))) - - (define-key-after map - [jabber-menu-status] - `(menu-item "Set Status" ,(make-sparse-keymap "set-status") - :enable (bound-and-true-p jabber-connections))) - - (define-key map - [jabber-menu-status jabber-menu-status-chat] - '(menu-item - "Chatty" - (lambda () - (interactive) - (jabber-send-presence "chat" - (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) - *jabber-current-priority*)) - :button (:radio . (and (boundp '*jabber-current-show*) - (equal *jabber-current-show* "chat"))))) - (define-key map - [jabber-menu-status jabber-menu-status-dnd] - '(menu-item - "Do not Disturb" - (lambda () - (interactive) - (jabber-send-presence "dnd" - (jabber-read-with-input-method "status message: " *jabber-current-status* '*jabber-status-history*) - *jabber-current-priority*)) - :button (:radio . (and (boundp '*jabber-current-show*) - (equal *jabber-current-show* "dnd"))))) - (define-key map - [jabber-menu-status jabber-menu-status-xa] - '(menu-item "Extended Away" jabber-send-xa-presence - :button (:radio . (and (boundp '*jabber-current-show*) - (equal *jabber-current-show* "xa"))))) - (define-key map - [jabber-menu-status jabber-menu-status-away] - '(menu-item "Away" jabber-send-away-presence - :button (:radio . (and (boundp '*jabber-current-show*) - (equal *jabber-current-show* "away"))))) - (define-key map - [jabber-menu-status jabber-menu-status-online] - '(menu-item "Online" jabber-send-default-presence - :button (:radio . (and (boundp '*jabber-current-show*) - (equal *jabber-current-show* ""))))) - - (define-key-after map - [separator] - '(menu-item "--")) - - (define-key-after map - [jabber-menu-chat-with] - '(menu-item "Chat with..." jabber-chat-with - :enable (bound-and-true-p jabber-connections))) - - (define-key-after map - [jabber-menu-nextmsg] - '(menu-item "Next unread message" jabber-activity-switch-to - :enable (bound-and-true-p jabber-activity-jids))) - - (define-key-after map - [jabber-menu-send-subscription-request] - '(menu-item "Send subscription request" jabber-send-subscription-request - :enable (bound-and-true-p jabber-connections))) - - (define-key-after map - [jabber-menu-roster] - '("Switch to roster" . jabber-switch-to-roster-buffer)) - - (define-key-after map - [separator2] - '(menu-item "--")) - - - (define-key-after map - [jabber-menu-customize] - '("Customize" . jabber-customize)) - - (define-key-after map - [jabber-menu-info] - '("Help" . jabber-info)) - - map)) - -;;;###autoload -(defcustom jabber-display-menu 'maybe - "Decide whether the \"Jabber\" menu is displayed in the menu bar. -If t, always display. -If nil, never display. -If maybe, display if jabber.el is installed under `package-user-dir', or -if any of `jabber-account-list' or `jabber-connections' is non-nil." - :group 'jabber - :type '(choice (const :tag "Never" nil) - (const :tag "Always" t) - (const :tag "When installed by user, or when any accounts have been configured or connected" maybe))) - -(defun jabber-menu (&optional remove) - "Put \"Jabber\" menu on menubar. -With prefix argument, remove it." - (interactive "P") - (setq jabber-display-menu (if remove nil t)) - (force-mode-line-update)) -(make-obsolete 'jabber-menu "set the variable `jabber-display-menu' instead.") - -;;;###autoload -(define-key-after (lookup-key global-map [menu-bar]) - [jabber-menu] - (list 'menu-item "Jabber" jabber-menu - :visible - '(or (eq jabber-display-menu t) - (and (eq jabber-display-menu 'maybe) - (or (bound-and-true-p jabber-account-list) - (bound-and-true-p jabber-connections)))))) - -(defvar jabber-jid-chat-menu nil - "Menu items for chat menu.") - -(defvar jabber-jid-info-menu nil - "Menu item for info menu.") - -(defvar jabber-jid-roster-menu nil - "Menu items for roster menu.") - -(defvar jabber-jid-muc-menu nil - "Menu items for MUC menu.") - -(defvar jabber-jid-service-menu nil - "Menu items for service menu.") - -(defun jabber-popup-menu (which-menu) - "Popup specified menu." - (let* ((mouse-event (and (listp last-input-event) last-input-event)) - (choice (widget-choose "Actions" which-menu mouse-event))) - (if mouse-event - (mouse-set-point mouse-event)) - (if choice - (call-interactively choice)))) - -(defun jabber-popup-chat-menu () - "Popup chat menu." - (interactive) - (jabber-popup-menu jabber-jid-chat-menu)) - -(defun jabber-popup-info-menu () - "Popup info menu." - (interactive) - (jabber-popup-menu jabber-jid-info-menu)) - -(defun jabber-popup-roster-menu () - "Popup roster menu." - (interactive) - (jabber-popup-menu jabber-jid-roster-menu)) - -(defun jabber-popup-muc-menu () - "Popup MUC menu." - (interactive) - (jabber-popup-menu jabber-jid-muc-menu)) - -(defun jabber-popup-service-menu () - "Popup service menu." - (interactive) - (jabber-popup-menu jabber-jid-service-menu)) - -(defun jabber-popup-combined-menu () - "Popup combined menu." - (interactive) - (jabber-popup-menu (append jabber-jid-chat-menu jabber-jid-info-menu jabber-jid-roster-menu jabber-jid-muc-menu))) - -(eval-when-compile (require 'cl)) - -;; Emacs 24 can be linked with GnuTLS -(ignore-errors (require 'gnutls)) - -;; Try two different TLS/SSL libraries, but don't fail if none available. -(or (ignore-errors (require 'tls)) - (ignore-errors (require 'ssl))) - -(ignore-errors (require 'starttls)) - -(eval-and-compile - (or (ignore-errors (require 'srv)) - (ignore-errors - (let ((load-path (cons (expand-file-name - "jabber-fallback-lib" - (file-name-directory (locate-library "jabber"))) - load-path))) - (require 'srv))) - (error - "The srv library was not found in `load-path' or jabber-fallback-lib/ directory"))) - -(defgroup jabber-conn nil "Jabber Connection Settings." - :group 'jabber) - -(defun jabber-have-starttls () - "Return non-nil if we can use STARTTLS." - (or (and (fboundp 'gnutls-available-p) - (gnutls-available-p)) - (and (featurep 'starttls) - (or (and (bound-and-true-p starttls-gnutls-program) - (executable-find starttls-gnutls-program)) - (and (bound-and-true-p starttls-program) - (executable-find starttls-program)))))) - -(defconst jabber-default-connection-type - (cond - ;; Use STARTTLS if we can... - ((jabber-have-starttls) - 'starttls) - ;; ...else default to unencrypted connection. - (t - 'network)) - "Default connection type. -See `jabber-connect-methods'.") - -(defcustom jabber-connection-ssl-program nil - "Program used for SSL/TLS connections. -nil means prefer gnutls but fall back to openssl. -'gnutls' means use gnutls (through `open-tls-stream'). -'openssl means use openssl (through `open-ssl-stream')." - :type '(choice (const :tag "Prefer gnutls, fall back to openssl" nil) - (const :tag "Use gnutls" gnutls) - (const :tag "Use openssl" openssl)) - :group 'jabber-conn) - -(defcustom jabber-invalid-certificate-servers () - "Jabber servers for which we accept invalid TLS certificates. -This is a list of server names, each matching the hostname part -of your JID. - -This option has effect only when using native GnuTLS in Emacs 24 -or later." - :type '(repeat string) - :group 'jabber-conn) - -(defvar jabber-connect-methods - `((network jabber-network-connect jabber-network-send) - (starttls - ,(if (and (fboundp 'gnutls-available-p) - (gnutls-available-p)) - ;; With "native" TLS, we can use a normal connection. - 'jabber-network-connect - 'jabber-starttls-connect) - jabber-network-send) - (ssl jabber-ssl-connect jabber-ssl-send) - (virtual jabber-virtual-connect jabber-virtual-send)) - "Alist of connection methods and functions. -First item is the symbol naming the method. -Second item is the connect function. -Third item is the send function.") - -(defun jabber-get-connect-function (type) - "Get the connect function associated with TYPE. -TYPE is a symbol; see `jabber-connection-type'." - (let ((entry (assq type jabber-connect-methods))) - (nth 1 entry))) - -(defun jabber-get-send-function (type) - "Get the send function associated with TYPE. -TYPE is a symbol; see `jabber-connection-type'." - (let ((entry (assq type jabber-connect-methods))) - (nth 2 entry))) - -(defun jabber-srv-targets (server network-server port) - "Find host and port to connect to. -If NETWORK-SERVER and/or PORT are specified, use them. -If we can't find SRV records, use standard defaults." - ;; If the user has specified a host or a port, obey that. - (if (or network-server port) - (list (cons (or network-server server) - (or port 5222))) - (or (condition-case nil - (srv-lookup (concat "_xmpp-client._tcp." server)) - (error nil)) - (list (cons server 5222))))) - -;; Plain TCP/IP connection -(defun jabber-network-connect (fsm server network-server port) - "Connect to a Jabber server with a plain network connection. -Send a message of the form (:connected CONNECTION) to FSM if -connection succeeds. Send a message (:connection-failed ERRORS) if -connection fails." - (cond - ((featurep 'make-network-process '(:nowait t)) - ;; We can connect asynchronously! - (jabber-network-connect-async fsm server network-server port)) - (t - ;; Connecting to the server will block Emacs. - (jabber-network-connect-sync fsm server network-server port)))) - -(defun jabber-network-connect-async (fsm server network-server port) - ;; Get all potential targets... - (lexical-let ((targets (jabber-srv-targets server network-server port)) - errors - (fsm fsm)) - ;; ...and connect to them one after another, asynchronously, until - ;; connection succeeds. - (labels - ((connect - (target remaining-targets) - (lexical-let ((target target) (remaining-targets remaining-targets)) - (labels ((connection-successful - (c) - ;; This mustn't be `fsm-send-sync', because the FSM - ;; needs to change the sentinel, which cannot be done - ;; from inside the sentinel. - (fsm-send fsm (list :connected c))) - (connection-failed - (c status) - (when (and (> (length status) 0) - (eq (aref status (1- (length status))) ?\n)) - (setq status (substring status 0 -1))) - (let ((err - (format "Couldn't connect to %s:%s: %s" - (car target) (cdr target) status))) - (message "%s" err) - (push err errors)) - (when c (delete-process c)) - (if remaining-targets - (progn - (message - "Connecting to %s:%s..." - (caar remaining-targets) (cdar remaining-targets)) - (connect (car remaining-targets) (cdr remaining-targets))) - (fsm-send fsm (list :connection-failed (nreverse errors)))))) - (condition-case e - (make-network-process - :name "jabber" - :buffer (generate-new-buffer jabber-process-buffer) - :host (car target) :service (cdr target) - :coding 'utf-8 - :nowait t - :sentinel - (lexical-let ((target target) (remaining-targets remaining-targets)) - (lambda (connection status) - (cond - ((string-match "^open" status) - (connection-successful connection)) - ((string-match "^failed" status) - (connection-failed connection status)) - ((string-match "^deleted" status) - ;; This happens when we delete a process in the - ;; "failed" case above. - nil) - (t - (message "Unknown sentinel status `%s'" status)))))) - (file-error - ;; A file-error has the error message in the third list - ;; element. - (connection-failed nil (car (cddr e)))) - (error - ;; Not sure if we ever get anything but file-errors, - ;; but let's make sure we report them: - (connection-failed nil (error-message-string e)))))))) - (message "Connecting to %s:%s..." (caar targets) (cdar targets)) - (connect (car targets) (cdr targets))))) - -(defun jabber-network-connect-sync (fsm server network-server port) - ;; This code will AFAIK only be used on Windows. Apologies in - ;; advance for any bit rot... - (let ((coding-system-for-read 'utf-8) - (coding-system-for-write 'utf-8) - (targets (jabber-srv-targets server network-server port)) - errors) - (catch 'connected - (dolist (target targets) - (condition-case e - (let ((process-buffer (generate-new-buffer jabber-process-buffer)) - connection) - (unwind-protect - (setq connection (open-network-stream - "jabber" - process-buffer - (car target) - (cdr target))) - - (unless (or connection jabber-debug-keep-process-buffers) - (kill-buffer process-buffer))) - - (when connection - (fsm-send fsm (list :connected connection)) - (throw 'connected connection))) - (file-error - ;; A file-error has the error message in the third list - ;; element. - (let ((err (format "Couldn't connect to %s:%s: %s" - (car target) (cdr target) - (car (cddr e))))) - (message "%s" err) - (push err errors))) - (error - ;; Not sure if we ever get anything but file-errors, - ;; but let's make sure we report them: - (let ((err (format "Couldn't connect to %s:%s: %s" - (car target) (cdr target) - (error-message-string e)))) - (message "%s" err) - (push err errors))))) - (fsm-send fsm (list :connection-failed (nreverse errors)))))) - -(defun jabber-network-send (connection string) - "Send a string via a plain TCP/IP connection to the Jabber Server." - (process-send-string connection string)) - -;; SSL connection, we use openssl's s_client function for encryption -;; of the link -;; TODO: make this configurable -(defun jabber-ssl-connect (fsm server network-server port) - "Connect via OpenSSL or GnuTLS to a Jabber Server. -Send a message of the form (:connected CONNECTION) to FSM if -connection succeeds. Send a message (:connection-failed ERRORS) if -connection fails." - (let ((coding-system-for-read 'utf-8) - (coding-system-for-write 'utf-8) - (connect-function - (cond - ((and (memq jabber-connection-ssl-program '(nil gnutls)) - (fboundp 'open-tls-stream)) - 'open-tls-stream) - ((and (memq jabber-connection-ssl-program '(nil openssl)) - (fboundp 'open-ssl-stream)) - 'open-ssl-stream) - (t - (error "Neither TLS nor SSL connect functions available")))) - error-msg) - (let ((process-buffer (generate-new-buffer jabber-process-buffer)) - connection) - (setq network-server (or network-server server)) - (setq port (or port 5223)) - (condition-case e - (setq connection (funcall connect-function - "jabber" - process-buffer - network-server - port)) - (error - (setq error-msg - (format "Couldn't connect to %s:%d: %s" network-server port - (error-message-string e))) - (message "%s" error-msg))) - (unless (or connection jabber-debug-keep-process-buffers) - (kill-buffer process-buffer)) - (if connection - (fsm-send fsm (list :connected connection)) - (fsm-send fsm (list :connection-failed - (when error-msg (list error-msg)))))))) - -(defun jabber-ssl-send (connection string) - "Send a string via an SSL-encrypted connection to the Jabber Server." - ;; It seems we need to send a linefeed afterwards. - (process-send-string connection string) - (process-send-string connection "\n")) - -(defun jabber-starttls-connect (fsm server network-server port) - "Connect via an external GnuTLS process to a Jabber Server. -Send a message of the form (:connected CONNECTION) to FSM if -connection succeeds. Send a message (:connection-failed ERRORS) if -connection fails." - (let ((coding-system-for-read 'utf-8) - (coding-system-for-write 'utf-8) - (targets (jabber-srv-targets server network-server port)) - errors) - (unless (fboundp 'starttls-open-stream) - (error "The starttls.el library is not available")) - (catch 'connected - (dolist (target targets) - (condition-case e - (let ((process-buffer (generate-new-buffer jabber-process-buffer)) - connection) - (unwind-protect - (setq connection - (starttls-open-stream - "jabber" - process-buffer - (car target) - (cdr target))) - (unless (or connection jabber-debug-keep-process-buffers) - (kill-buffer process-buffer))) - (if (null connection) - ;; It seems we don't actually get an error if we - ;; can't connect. Let's try to convey some useful - ;; information to the user at least. - (let ((err (format "Couldn't connect to %s:%s" - (car target) (cdr target)))) - (message "%s" err) - (push err errors)) - (fsm-send fsm (list :connected connection)) - (throw 'connected connection))) - (error - (let ((err (format "Couldn't connect to %s: %s" target - (error-message-string e)))) - (message "%s" err) - (push err errors))))) - (fsm-send fsm (list :connection-failed (nreverse errors)))))) - -(defun jabber-starttls-initiate (fsm) - "Initiate a starttls connection." - (jabber-send-sexp fsm - '(starttls ((xmlns . "urn:ietf:params:xml:ns:xmpp-tls"))))) - -(defun jabber-starttls-process-input (fsm xml-data) - "Process result of starttls request. -On failure, signal error. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (cond - ((eq (car xml-data) 'proceed) - (let* ((state-data (fsm-get-state-data fsm)) - (connection (plist-get state-data :connection))) - ;; Did we use open-network-stream or starttls-open-stream? We - ;; can tell by process-type. - (case (process-type connection) - (network - (let* ((hostname (plist-get state-data :server)) - (verifyp (not (member hostname jabber-invalid-certificate-servers)))) - ;; gnutls-negotiate might signal an error, which is caught - ;; by our caller - (gnutls-negotiate - :process connection - ;; This is the hostname that the certificate should be valid for: - :hostname hostname - :verify-hostname-error verifyp - :verify-error verifyp))) - (real - (or - (starttls-negotiate connection) - (error "Negotiation failure")))))) - ((eq (car xml-data) 'failure) - (error "Command rejected by server")))) - -(defvar *jabber-virtual-server-function* nil - "Function to use for sending stanzas on a virtual connection. -The function should accept two arguments, the connection object -and a string that the connection wants to send.") - -(defun jabber-virtual-connect (fsm server network-server port) - "Connect to a virtual \"server\". -Use `*jabber-virtual-server-function*' as send function." - (unless (functionp *jabber-virtual-server-function*) - (error "No virtual server function specified")) - ;; We pass the fsm itself as "connection object", as that is what a - ;; virtual server needs to send stanzas. - (fsm-send fsm (list :connected fsm))) - -(defun jabber-virtual-send (connection string) - (funcall *jabber-virtual-server-function* connection string)) - -(require 'cl) - -;;; This file uses sasl.el from FLIM or Gnus. If it can't be found, -;;; jabber-core.el won't use the SASL functions. -(eval-and-compile - (condition-case nil - (require 'sasl) - (error nil))) - -;;; Alternatives to FLIM would be the command line utility of GNU SASL, -;;; or anything the Gnus people decide to use. - -;;; See XMPP-CORE and XMPP-IM for details about the protocol. -(defun jabber-sasl-start-auth (jc stream-features) -"Start the SASL authentication mechanism. -JC is The Jabber Connection. -STREAM-FEATURES the XML parsed \"stream features\" answer (it is used -with `jabber-xml-get-chidlren')." - ;; Find a suitable common mechanism. - (let* ((mechanism-elements (car (jabber-xml-get-children stream-features 'mechanisms))) - (mechanisms (mapcar - (lambda (tag) - (car (jabber-xml-node-children tag))) - (jabber-xml-get-children mechanism-elements 'mechanism))) - (mechanism - (if (and (member "ANONYMOUS" mechanisms) - (or jabber-silent-mode (yes-or-no-p "Use anonymous authentication? "))) - (sasl-find-mechanism '("ANONYMOUS")) - (sasl-find-mechanism mechanisms)))) - - ;; No suitable mechanism? - (if (null mechanism) - ;; Maybe we can use legacy authentication - (let ((iq-auth (find "http://jabber.org/features/iq-auth" - (jabber-xml-get-children stream-features 'auth) - :key #'jabber-xml-get-xmlns - :test #'string=)) - ;; Or maybe we have to use STARTTLS, but can't - (starttls (find "urn:ietf:params:xml:ns:xmpp-tls" - (jabber-xml-get-children stream-features 'starttls) - :key #'jabber-xml-get-xmlns - :test #'string=))) - (cond - (iq-auth - (fsm-send jc :use-legacy-auth-instead)) - (starttls - (message "STARTTLS encryption required, but disabled/non-functional at our end") - (fsm-send jc :authentication-failure)) - (t - (message "Authentication failure: no suitable SASL mechanism found") - (fsm-send jc :authentication-failure)))) - - ;; Watch for plaintext logins over unencrypted connections - (if (and (not (plist-get (fsm-get-state-data jc) :encrypted)) - (member (sasl-mechanism-name mechanism) - '("PLAIN" "LOGIN")) - (not (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? "))) - (fsm-send jc :authentication-failure) - - ;; Start authentication. - (let* (passphrase - (client (sasl-make-client mechanism - (plist-get (fsm-get-state-data jc) :username) - "xmpp" - (plist-get (fsm-get-state-data jc) :server))) - (sasl-read-passphrase (jabber-sasl-read-passphrase-closure - jc - (lambda (p) (setq passphrase (copy-sequence p)) p))) - (step (sasl-next-step client nil))) - (jabber-send-sexp - jc - `(auth ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl") - (mechanism . ,(sasl-mechanism-name mechanism))) - ,(when (sasl-step-data step) - (base64-encode-string (sasl-step-data step) t)))) - (list client step passphrase)))))) - -(defun jabber-sasl-read-passphrase-closure (jc remember) - "Return a lambda function suitable for `sasl-read-passphrase' for JC. -Call REMEMBER with the password. REMEMBER is expected to return it as well." - (lexical-let ((password (plist-get (fsm-get-state-data jc) :password)) - (bare-jid (jabber-connection-bare-jid jc)) - (remember remember)) - (if password - (lambda (prompt) (funcall remember (copy-sequence password))) - (lambda (prompt) (funcall remember (jabber-read-password bare-jid)))))) - -(defun jabber-sasl-process-input (jc xml-data sasl-data) -"SASL protocol input processing. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((client (first sasl-data)) - (step (second sasl-data)) - (passphrase (third sasl-data)) - (sasl-read-passphrase (jabber-sasl-read-passphrase-closure - jc - (lambda (p) (setq passphrase (copy-sequence p)) p)))) - (cond - ((eq (car xml-data) 'challenge) - (sasl-step-set-data step (base64-decode-string (car (jabber-xml-node-children xml-data)))) - (setq step (sasl-next-step client step)) - (jabber-send-sexp - jc - `(response ((xmlns . "urn:ietf:params:xml:ns:xmpp-sasl")) - ,(when (sasl-step-data step) - (base64-encode-string (sasl-step-data step) t))))) - - ((eq (car xml-data) 'failure) - (message "%s: authentication failure: %s" - (jabber-connection-bare-jid jc) - (jabber-xml-node-name (car (jabber-xml-node-children xml-data)))) - (fsm-send jc :authentication-failure)) - - ((eq (car xml-data) 'success) - ;; The server might, depending on the mechanism, send - ;; "additional data" (see RFC 4422) with the element. - ;; Since some SASL mechanisms perform mutual authentication, we - ;; need to pass this data to sasl.el - we're not necessarily - ;; done just because the server says we're done. - (let* ((data (car (jabber-xml-node-children xml-data))) - (decoded (if data - (base64-decode-string data) - ""))) - (sasl-step-set-data step decoded) - (condition-case e - (progn - ;; Check that sasl-next-step doesn't signal an error. - ;; TODO: once sasl.el allows it, check that all steps have - ;; been completed. - (sasl-next-step client step) - (message "Authentication succeeded for %s" (jabber-connection-bare-jid jc)) - (fsm-send jc (cons :authentication-success passphrase))) - (sasl-error - (message "%s: authentication failure: %s" - (jabber-connection-bare-jid jc) - (error-message-string e)) - (fsm-send jc :authentication-failure)))))) - (list client step passphrase))) - -;; button.el was introduced in Emacs 22 -(condition-case e - (require 'button) - (error nil)) - -(defvar jabber-common-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'jabber-popup-chat-menu) - (define-key map "\C-c\C-r" 'jabber-popup-roster-menu) - (define-key map "\C-c\C-i" 'jabber-popup-info-menu) - (define-key map "\C-c\C-m" 'jabber-popup-muc-menu) - (define-key map "\C-c\C-s" 'jabber-popup-service-menu) - ;; note that {forward,backward}-button are not autoloaded. - ;; thus the `require' above. - (when (fboundp 'forward-button) - (define-key map [?\t] 'forward-button) - (define-key map [backtab] 'backward-button)) - map)) - -;;;###autoload -(defvar jabber-global-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\C-c" 'jabber-connect-all) - (define-key map "\C-d" 'jabber-disconnect) - (define-key map "\C-r" 'jabber-switch-to-roster-buffer) - (define-key map "\C-j" 'jabber-chat-with) - (define-key map "\C-l" 'jabber-activity-switch-to) - (define-key map "\C-a" 'jabber-send-away-presence) - (define-key map "\C-o" 'jabber-send-default-presence) - (define-key map "\C-x" 'jabber-send-xa-presence) - (define-key map "\C-p" 'jabber-send-presence) - map) - "Global Jabber keymap (usually under C-x C-j).") - -;;;###autoload -(define-key ctl-x-map "\C-j" jabber-global-keymap) - -(require 'ewoc) -(require 'sgml-mode) ;we base on this mode to hightlight XML -(defcustom jabber-console-name-format "*-jabber-console-%s-*" - "Format for console buffer name. %s mean connection jid." - :type 'string - :group 'jabber-debug) - -(defcustom jabber-console-truncate-lines 3000 - "Maximum number of lines in console buffer. -Not truncate if set to 0." - :type 'integer - :group 'jabber-debug) - -(defvar jabber-point-insert nil - "Position where the message being composed starts.") - -(defvar jabber-send-function nil - "Function for sending a message from a chat buffer.") - -(defvar jabber-console-mode-hook nil - "Hook called at the end of `jabber-console-mode'. -Note that functions in this hook have no way of knowing -what kind of chat buffer is being created.") - -(defvar jabber-console-ewoc nil - "The ewoc showing the XML elements of this stream buffer.") - -(defvar jabber-console-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map jabber-common-keymap) - (define-key map "\r" 'jabber-chat-buffer-send) - map)) - -(defun jabber-console-create-buffer (jc) - (with-current-buffer - (get-buffer-create (format jabber-console-name-format (jabber-connection-bare-jid jc))) - (unless (eq major-mode 'jabber-console-mode) - (jabber-console-mode)) - ;; Make sure the connection variable is up to date. - (setq jabber-buffer-connection jc) - (current-buffer))) - -(defun jabber-console-send (jc data) - ;; Put manual string into buffers ewoc - (jabber-process-console jc "raw" data) - ;; ...than sent it to server - (jabber-send-string jc data)) - -(defun jabber-console-comment (str) - "Insert comment into console buffer." - (let ((string (concat - comment-start str "@" (jabber-encode-time (current-time)) ":" - comment-end "\n"))) - (when (stringp jabber-debug-log-xml) - (jabber-append-string-to-file string jabber-debug-log-xml)) - (insert string))) - -(defun jabber-console-pp (data) - "Pretty Printer for XML-sexp and raw data." - (let ((direction (car data)) - (xml-list (cdr data)) - (raw (cadr data))) - (jabber-console-comment direction) - (if (stringp raw) - ;; raw code input - (progn - (insert raw) - (when (stringp jabber-debug-log-xml) - (jabber-append-string-to-file raw jabber-debug-log-xml))) - ;; receive/sending - (progn - (xml-print xml-list) - (when (stringp jabber-debug-log-xml) - (jabber-append-string-to-file - "\n" jabber-debug-log-xml 'xml-print xml-list)))))) - -(define-derived-mode jabber-console-mode sgml-mode "Jabber Console" - "Major mode for debug XMPP protocol." - ;; Make sure to set this variable somewhere - (make-local-variable 'jabber-send-function) - (make-local-variable 'jabber-point-insert) - (make-local-variable 'jabber-console-ewoc) - - (setq jabber-send-function 'jabber-console-send) - - (unless jabber-console-ewoc - (setq jabber-console-ewoc - (ewoc-create #'jabber-console-pp nil "")) - (goto-char (point-max)) - (put-text-property (point-min) (point) 'read-only t) - (let ((inhibit-read-only t)) - (put-text-property (point-min) (point) 'front-sticky t) - (put-text-property (point-min) (point) 'rear-nonsticky t)) - (setq jabber-point-insert (point-marker)))) - -(put 'jabber-console-mode 'mode-class 'special) - -(defun jabber-console-sanitize (xml-data) - "Sanitize XML-DATA for `jabber-process-console'." - (if (listp xml-data) - (jabber-tree-map (lambda (x) (if (numberp x) (format "%s" x) x)) xml-data) - xml-data)) - -;;;###autoload -(defun jabber-process-console (jc direction xml-data) - "Log XML-DATA i/o as XML in \"*-jabber-console-JID-*\" buffer." - (let ((buffer (get-buffer-create (jabber-console-create-buffer jc)))) - (with-current-buffer buffer - (progn - (ewoc-enter-last jabber-console-ewoc (list direction (jabber-console-sanitize xml-data))) - (when (< 1 jabber-console-truncate-lines) - (let ((jabber-log-lines-to-keep jabber-console-truncate-lines)) - (jabber-truncate-top buffer jabber-console-ewoc))))))) - -(require 'cl) - -(eval-and-compile - (or (ignore-errors (require 'fsm)) - (ignore-errors - (let ((load-path (cons (expand-file-name - "jabber-fallback-lib" - (file-name-directory (locate-library "jabber"))) - load-path))) - (require 'fsm))) - (error - "The fsm library was not found in `load-path' or jabber-fallback-lib/ directory"))) - -(defvar jabber-connections nil - "List of jabber-connection FSMs.") - -(defvar *jabber-roster* nil - "The roster list.") - -(defvar jabber-jid-obarray (make-vector 127 0) - "Obarray for keeping JIDs.") - -(defvar *jabber-disconnecting* nil - "Boolean - are we in the process of disconnecting by free will.") - -(defvar jabber-message-chain nil - "Incoming messages are sent to these functions, in order.") - -(defvar jabber-iq-chain nil - "Incoming infoqueries are sent to these functions, in order.") - -(defvar jabber-presence-chain nil - "Incoming presence notifications are sent to these functions, in order.") - -(defvar jabber-namespace-prefixes nil - "XML namespace prefixes used for the current connection.") -(make-variable-buffer-local 'jabber-namespace-prefixes) - -(defgroup jabber-core nil "customize core functionality." - :group 'jabber) - -(defcustom jabber-post-connect-hooks '(jabber-send-current-presence - jabber-muc-autojoin - jabber-whitespace-ping-start - jabber-vcard-avatars-find-current) - "*Hooks run after successful connection and authentication. -The functions should accept one argument, the connection object." - :type 'hook - :options '(jabber-send-current-presence - jabber-muc-autojoin - jabber-whitespace-ping-start - jabber-keepalive-start - jabber-vcard-avatars-find-current - jabber-autoaway-start) - :group 'jabber-core) - -(defcustom jabber-pre-disconnect-hook nil - "*Hooks run just before voluntary disconnection. -This might be due to failed authentication." - :type 'hook - :group 'jabber-core) - -(defcustom jabber-lost-connection-hooks nil - "*Hooks run after involuntary disconnection. -The functions are called with one argument: the connection object." - :type 'hook - :group 'jabber-core) - -(defcustom jabber-post-disconnect-hook nil - "*Hooks run after disconnection." - :type 'hook - :group 'jabber-core) - -(defcustom jabber-auto-reconnect nil - "Reconnect automatically after losing connection? -This will be of limited use unless you have the password library -installed, and have configured it to cache your password -indefinitely. See `password-cache' and `password-cache-expiry'." - :type 'boolean - :group 'jabber-core) - -(defcustom jabber-reconnect-delay 5 - "Seconds to wait before reconnecting." - :type 'integer - :group 'jabber-core) - -(defcustom jabber-roster-buffer "*-jabber-roster-*" - "The name of the roster buffer." - :type 'string - :group 'jabber-core) - -(defvar jabber-process-buffer " *-jabber-process-*" - "The name of the process buffer.") - -(defcustom jabber-use-sasl t - "If non-nil, use SASL if possible. -SASL will still not be used if the library for it is missing or -if the server doesn't support it. - -Disabling this shouldn't be necessary, but it may solve certain -problems." - :type 'boolean - :group 'jabber-core) - -(defsubst jabber-have-sasl-p () - "Return non-nil if SASL functions are available." - (featurep 'sasl)) - -(defvar jabber-account-history () - "Keeps track of previously used jabber accounts.") - -(defvar jabber-connection-type-history () - "Keeps track of previously used connection types.") - -;;;###autoload (autoload 'jabber-connect-all "jabber" "Connect to all configured Jabber accounts.\nSee `jabber-account-list'.\nIf no accounts are configured (or ARG supplied), call `jabber-connect' interactively." t) -(defun jabber-connect-all (&optional arg) - "Connect to all configured Jabber accounts. -See `jabber-account-list'. -If no accounts are configured (or with prefix argument), call `jabber-connect' -interactively. -With many prefix arguments, one less is passed to `jabber-connect'." - (interactive "P") - (let ((accounts - (remove-if (lambda (account) - (cdr (assq :disabled (cdr account)))) - jabber-account-list))) - (if (or (null accounts) arg) - (let ((current-prefix-arg - (cond - ;; A number of C-u's; remove one, so to speak. - ((consp arg) - (if (> (car arg) 4) - (list (/ (car arg) 4)) - nil)) - ;; Otherwise, we just don't care. - (t - arg)))) - (call-interactively 'jabber-connect)) - ;; Only connect those accounts that are not yet connected. - (let ((already-connected (mapcar #'jabber-connection-original-jid jabber-connections)) - (connected-one nil)) - (dolist (account accounts) - (unless (member (jabber-jid-user (car account)) already-connected) - (let* ((jid (car account)) - (alist (cdr account)) - (password (cdr (assq :password alist))) - (network-server (cdr (assq :network-server alist))) - (port (cdr (assq :port alist))) - (connection-type (cdr (assq :connection-type alist)))) - (jabber-connect - (jabber-jid-username jid) - (jabber-jid-server jid) - (jabber-jid-resource jid) - nil password network-server - port connection-type) - (setq connected-one t)))) - (unless connected-one - (message "All configured Jabber accounts are already connected")))))) - -;;;###autoload (autoload 'jabber-connect "jabber" "Connect to the Jabber server and start a Jabber XML stream.\nWith prefix argument, register a new account.\nWith double prefix argument, specify more connection details." t) -(defun jabber-connect (username server resource &optional - registerp password network-server - port connection-type) - "Connect to the Jabber server and start a Jabber XML stream. -With prefix argument, register a new account. -With double prefix argument, specify more connection details." - (interactive - (let* ((jid (completing-read "Enter your JID: " jabber-account-list nil nil nil 'jabber-account-history)) - (entry (assoc jid jabber-account-list)) - (alist (cdr entry)) - password network-server port connection-type registerp) - (when (zerop (length jid)) - (error "No JID specified")) - (unless (jabber-jid-username jid) - (error "Missing username part in JID")) - (when entry - ;; If the user entered the JID of one of the preconfigured - ;; accounts, use that data. - (setq password (cdr (assq :password alist))) - (setq network-server (cdr (assq :network-server alist))) - (setq port (cdr (assq :port alist))) - (setq connection-type (cdr (assq :connection-type alist)))) - (when (equal current-prefix-arg '(16)) - ;; Double prefix arg: ask about everything. - ;; (except password, which is asked about later anyway) - (setq password nil) - (setq network-server - (read-string (format "Network server: (default `%s') " network-server) - nil nil network-server)) - (when (zerop (length network-server)) - (setq network-server nil)) - (setq port - (car - (read-from-string - (read-string (format "Port: (default `%s') " port) - nil nil (if port (number-to-string port) "nil"))))) - (setq connection-type - (car - (read-from-string - (let ((default (symbol-name (or connection-type jabber-default-connection-type)))) - (completing-read - (format "Connection type: (default `%s') " default) - (mapcar (lambda (type) - (cons (symbol-name (car type)) nil)) - jabber-connect-methods) - nil t nil 'jabber-connection-type-history default))))) - (setq registerp (or jabber-silent-mode (yes-or-no-p "Register new account? ")))) - (when (equal current-prefix-arg '(4)) - (setq registerp t)) - - (list (jabber-jid-username jid) - (jabber-jid-server jid) - (jabber-jid-resource jid) - registerp password network-server port connection-type))) - - (if (member (list username - server) - (mapcar - (lambda (c) - (let ((data (fsm-get-state-data c))) - (list (plist-get data :username) - (plist-get data :server)))) - jabber-connections)) - (message "Already connected to %s@%s" - username server) - ;;(jabber-clear-roster) - - (push (start-jabber-connection username server resource - registerp password - network-server port connection-type) - jabber-connections))) - -(define-state-machine jabber-connection - :start ((username server resource registerp password network-server port connection-type) - "Start a Jabber connection." - (let* ((connection-type - (or connection-type jabber-default-connection-type)) - (send-function - (jabber-get-send-function connection-type))) - - (list :connecting - (list :send-function send-function - ;; Save the JID we originally connected with. - :original-jid (concat username "@" server) - :username username - :server server - :resource resource - :password password - :registerp registerp - :connection-type connection-type - :encrypted (eq connection-type 'ssl) - :network-server network-server - :port port))))) - -(define-enter-state jabber-connection nil - (fsm state-data) - ;; `nil' is the error state. - - ;; Close the network connection. - (let ((connection (plist-get state-data :connection))) - (when (processp connection) - (let ((process-buffer (process-buffer connection))) - (delete-process connection) - (when (and (bufferp process-buffer) - (not jabber-debug-keep-process-buffers)) - (kill-buffer process-buffer))))) - (setq state-data (plist-put state-data :connection nil)) - ;; Clear MUC data - (jabber-muc-connection-closed (jabber-connection-bare-jid fsm)) - ;; Remove lost connections from the roster buffer. - (jabber-display-roster) - (let ((expected (plist-get state-data :disconnection-expected)) - (reason (plist-get state-data :disconnection-reason)) - (ever-session-established (plist-get state-data :ever-session-established))) - (unless expected - (run-hook-with-args 'jabber-lost-connection-hooks fsm) - (message "%s@%s%s: connection lost: `%s'" - (plist-get state-data :username) - (plist-get state-data :server) - (if (plist-get state-data :resource) - (concat "/" (plist-get state-data :resource)) - "") - reason)) - - (if (and jabber-auto-reconnect (not expected) ever-session-established) - ;; Reconnect after a short delay? - (list state-data jabber-reconnect-delay) - ;; Else the connection is really dead. Remove it from the list - ;; of connections. - (setq jabber-connections - (delq fsm jabber-connections)) - (when jabber-mode-line-mode - (jabber-mode-line-presence-update)) - (jabber-display-roster) - ;; And let the FSM sleep... - (list state-data nil)))) - -(define-state jabber-connection nil - (fsm state-data event callback) - ;; In the `nil' state, the connection is dead. We wait for a - ;; :timeout message, meaning to reconnect, or :do-disconnect, - ;; meaning to cancel reconnection. - (case event - (:timeout - (list :connecting state-data)) - (:do-disconnect - (setq jabber-connections - (delq fsm jabber-connections)) - (list nil state-data nil)))) - -(define-enter-state jabber-connection :connecting - (fsm state-data) - (let* ((connection-type (plist-get state-data :connection-type)) - (connect-function (jabber-get-connect-function connection-type)) - (server (plist-get state-data :server)) - (network-server (plist-get state-data :network-server)) - (port (plist-get state-data :port))) - (funcall connect-function fsm server network-server port)) - (list state-data nil)) - -(define-state jabber-connection :connecting - (fsm state-data event callback) - (case (or (car-safe event) event) - (:connected - (let ((connection (cadr event)) - (registerp (plist-get state-data :registerp))) - - (setq state-data (plist-put state-data :connection connection)) - - (when (processp connection) - ;; TLS connections leave data in the process buffer, which - ;; the XML parser will choke on. - (with-current-buffer (process-buffer connection) - (erase-buffer)) - - (set-process-filter connection (fsm-make-filter fsm)) - (set-process-sentinel connection (fsm-make-sentinel fsm))) - - (list :connected state-data))) - - (:connection-failed - (message "Jabber connection failed") - (plist-put state-data :disconnection-reason - (mapconcat #'identity (cadr event) "; ")) - (list nil state-data)) - - (:do-disconnect - ;; We don't have the connection object, so defer the disconnection. - :defer))) - -(defsubst jabber-fsm-handle-sentinel (state-data event) - "Handle sentinel event for jabber fsm." - ;; We do the same thing for every state, so avoid code duplication. - (let* ((string (car (cddr event))) - ;; The event string sometimes (always?) has a trailing - ;; newline, that we don't care for. - (trimmed-string - (if (eq ?\n (aref string (1- (length string)))) - (substring string 0 -1) - string)) - (new-state-data - ;; If we already know the reason (e.g. a stream error), don't - ;; overwrite it. - (if (plist-get state-data :disconnection-reason) - state-data - (plist-put state-data :disconnection-reason trimmed-string)))) - (list nil new-state-data))) - -(define-enter-state jabber-connection :connected - (fsm state-data) - - (jabber-send-stream-header fsm) - - ;; Next thing happening is the server sending its own start tag. - - (list state-data nil)) - -(define-state jabber-connection :connected - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :connected state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stream-start - (let ((session-id (cadr event)) - (stream-version (car (cddr event)))) - (setq state-data - (plist-put state-data :session-id session-id)) - ;; the stream feature is only sent if the initiating entity has - ;; sent 1.0 in the stream header. if sasl is not supported then - ;; we don't send 1.0 in the header and therefore we shouldn't wait - ;; even if 1.0 is present in the receiving stream. - (cond - ;; Wait for stream features? - ((and stream-version - (>= (string-to-number stream-version) 1.0) - jabber-use-sasl - (jabber-have-sasl-p)) - ;; Stay in same state... - (list :connected state-data)) - ;; Register account? - ((plist-get state-data :registerp) - ;; XXX: require encryption for registration? - (list :register-account state-data)) - ;; Legacy authentication? - (t - (list :legacy-auth state-data))))) - - (:stanza - (let ((stanza (cadr event))) - (cond - ;; At this stage, we only expect a stream:features stanza. - ((not (eq (jabber-xml-node-name stanza) 'features)) - (list nil (plist-put state-data - :disconnection-reason - (format "Unexpected stanza %s" stanza)))) - ((and (jabber-xml-get-children stanza 'starttls) - (eq (plist-get state-data :connection-type) 'starttls)) - (list :starttls state-data)) - ;; XXX: require encryption for registration? - ((plist-get state-data :registerp) - ;; We could check for the element in stream - ;; features, but as a client we would only lose by doing - ;; that. - (list :register-account state-data)) - (t - (list :sasl-auth (plist-put state-data :stream-features stanza)))))) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :starttls - (fsm state-data) - (jabber-starttls-initiate fsm) - (list state-data nil)) - -(define-state jabber-connection :starttls - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :starttls state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stanza - (condition-case e - (progn - (jabber-starttls-process-input fsm (cadr event)) - ;; Connection is encrypted. Send a stream tag again. - (list :connected (plist-put state-data :encrypted t))) - (error - (let* ((msg (concat "STARTTLS negotiation failed: " - (error-message-string e))) - (new-state-data (plist-put state-data :disconnection-reason msg))) - (list nil new-state-data))))) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :register-account - (fsm state-data) - (jabber-get-register fsm nil) - (list state-data nil)) - -(define-state jabber-connection :register-account - (fsm state-data event callback) - ;; The connection will be closed in jabber-register - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :register-account state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stanza - (or - (jabber-process-stream-error (cadr event) state-data) - (progn - (jabber-process-input fsm (cadr event)) - (list :register-account state-data)))) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :legacy-auth - (fsm state-data) - (jabber-get-auth fsm (plist-get state-data :server) - (plist-get state-data :session-id)) - (list state-data nil)) - -(define-state jabber-connection :legacy-auth - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :legacy-auth state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stanza - (or - (jabber-process-stream-error (cadr event) state-data) - (progn - (jabber-process-input fsm (cadr event)) - (list :legacy-auth state-data)))) - - (:authentication-success - (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) - (list :session-established state-data)) - - (:authentication-failure - (jabber-uncache-password (jabber-connection-bare-jid fsm)) - ;; jabber-logon has already displayed a message - (list nil (plist-put state-data - :disconnection-expected t))) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :sasl-auth - (fsm state-data) - (let ((new-state-data - (plist-put state-data - :sasl-data - (jabber-sasl-start-auth - fsm - (plist-get state-data - :stream-features))))) - (list new-state-data nil))) - -(define-state jabber-connection :sasl-auth - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :sasl-auth state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stanza - (let ((new-sasl-data - (jabber-sasl-process-input - fsm (cadr event) - (plist-get state-data :sasl-data)))) - (list :sasl-auth (plist-put state-data :sasl-data new-sasl-data)))) - - (:use-legacy-auth-instead - (list :legacy-auth (plist-put state-data :sasl-data nil))) - - (:authentication-success - (jabber-cache-password (jabber-connection-bare-jid fsm) (cdr event)) - (list :bind (plist-put state-data :sasl-data nil))) - - (:authentication-failure - (jabber-uncache-password (jabber-connection-bare-jid fsm)) - ;; jabber-sasl has already displayed a message - (list nil (plist-put state-data - :disconnection-expected t))) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :bind - (fsm state-data) - (jabber-send-stream-header fsm) - (list state-data nil)) - -(define-state jabber-connection :bind - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :bind state-data))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stream-start - ;; we wait for stream features... - (list :bind state-data)) - - (:stanza - (let ((stanza (cadr event))) - (cond - ((eq (jabber-xml-node-name stanza) 'features) - ;; Record stream features, discarding earlier data: - (setq state-data (plist-put state-data :stream-features stanza)) - (if (jabber-xml-get-children stanza 'bind) - (let ((handle-bind - (lambda (jc xml-data success) - (fsm-send jc (list - (if success :bind-success :bind-failure) - xml-data)))) - ;; So let's bind a resource. We can either pick a resource ourselves, - ;; or have the server pick one for us. - (resource (plist-get state-data :resource))) - (jabber-send-iq fsm nil "set" - `(bind ((xmlns . "urn:ietf:params:xml:ns:xmpp-bind")) - ,@(when resource - `((resource () ,resource)))) - handle-bind t - handle-bind nil) - (list :bind state-data)) - (message "Server doesn't permit resource binding") - (list nil state-data))) - (t - (or - (jabber-process-stream-error (cadr event) state-data) - (progn - (jabber-process-input fsm (cadr event)) - (list :bind state-data))))))) - - (:bind-success - (let ((jid (jabber-xml-path (cadr event) '(bind jid "")))) - ;; Maybe this isn't the JID we asked for. - (plist-put state-data :username (jabber-jid-username jid)) - (plist-put state-data :server (jabber-jid-server jid)) - (plist-put state-data :resource (jabber-jid-resource jid))) - - ;; If the server follows the older RFCs 3920 and 3921, it may - ;; offer session initiation here. If it follows RFCs 6120 and - ;; 6121, it might not offer it, and we should just skip it. - (if (jabber-xml-get-children (plist-get state-data :stream-features) 'session) - (let ((handle-session - (lambda (jc xml-data success) - (fsm-send jc (list - (if success :session-success :session-failure) - xml-data))))) - (jabber-send-iq fsm nil "set" - '(session ((xmlns . "urn:ietf:params:xml:ns:xmpp-session"))) - handle-session t - handle-session nil) - (list :bind state-data)) - ;; Session establishment not offered - assume not necessary. - (list :session-established state-data))) - - (:session-success - ;; We have a session - (list :session-established state-data)) - - (:bind-failure - (message "Resource binding failed: %s" - (jabber-parse-error - (jabber-iq-error (cadr event)))) - (list nil state-data)) - - (:session-failure - (message "Session establishing failed: %s" - (jabber-parse-error - (jabber-iq-error (cadr event)))) - (list nil state-data)) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(define-enter-state jabber-connection :session-established - (fsm state-data) - (jabber-send-iq fsm nil - "get" - '(query ((xmlns . "jabber:iq:roster"))) - #'jabber-process-roster 'initial - #'jabber-initial-roster-failure nil) - (list (plist-put state-data :ever-session-established t) nil)) - -(defvar jabber-pending-presence-timeout 0.5 - "Wait this long before doing presence packet batch processing.") - -(define-state jabber-connection :session-established - (fsm state-data event callback) - (case (or (car-safe event) event) - (:filter - (let ((process (cadr event)) - (string (car (cddr event)))) - (jabber-pre-filter process string fsm) - (list :session-established state-data :keep))) - - (:sentinel - (jabber-fsm-handle-sentinel state-data event)) - - (:stanza - (or - (jabber-process-stream-error (cadr event) state-data) - (progn - (jabber-process-input fsm (cadr event)) - (list :session-established state-data :keep)))) - - (:roster-update - ;; Batch up roster updates - (let* ((jid-symbol-to-update (cdr event)) - (pending-updates (plist-get state-data :roster-pending-updates))) - ;; If there are pending updates, there is a timer running - ;; already; just add the new symbol and wait. - (if pending-updates - (progn - (unless (memq jid-symbol-to-update pending-updates) - (nconc pending-updates (list jid-symbol-to-update))) - (list :session-established state-data :keep)) - ;; Otherwise, we need to create the list and start the timer. - (setq state-data - (plist-put state-data - :roster-pending-updates - (list jid-symbol-to-update))) - (list :session-established state-data jabber-pending-presence-timeout)))) - - (:timeout - ;; Update roster - (let ((pending-updates (plist-get state-data :roster-pending-updates))) - (setq state-data (plist-put state-data :roster-pending-updates nil)) - (jabber-roster-update fsm nil pending-updates nil) - (list :session-established state-data))) - - (:send-if-connected - ;; This is the only state in which we respond to such messages. - ;; This is to make sure we don't send anything inappropriate - ;; during authentication etc. - (jabber-send-sexp fsm (cdr event)) - (list :session-established state-data :keep)) - - (:do-disconnect - (jabber-send-string fsm "") - (list nil (plist-put state-data - :disconnection-expected t))))) - -(defun jabber-disconnect (&optional arg) - "Disconnect from all Jabber servers. If ARG supplied, disconnect one account." - (interactive "P") - (if arg - (jabber-disconnect-one (jabber-read-account)) - (unless *jabber-disconnecting* ; avoid reentry - (let ((*jabber-disconnecting* t)) - (if (null jabber-connections) - (message "Already disconnected") - (run-hooks 'jabber-pre-disconnect-hook) - (dolist (c jabber-connections) - (jabber-disconnect-one c t)) - (setq jabber-connections nil) - - (jabber-disconnected) - (when (called-interactively-p 'interactive) - (message "Disconnected from Jabber server(s)"))))))) - -(defun jabber-disconnect-one (jc &optional dont-redisplay) - "Disconnect from one Jabber server. -If DONT-REDISPLAY is non-nil, don't update roster buffer. -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (fsm-send-sync jc :do-disconnect) - (when (called-interactively-p 'interactive) - (message "Disconnected from %s" - (jabber-connection-jid jc))) - (unless dont-redisplay - (jabber-display-roster))) - -(defun jabber-disconnected () - "Re-initialise jabber package variables. -Call this function after disconnection." - (when (get-buffer jabber-roster-buffer) - (with-current-buffer (get-buffer jabber-roster-buffer) - (let ((inhibit-read-only t)) - (erase-buffer)))) - - (jabber-clear-roster) - (run-hooks 'jabber-post-disconnect-hook)) - -(defun jabber-log-xml (fsm direction data) - "Print DATA to XML console (and, optionally, in file). -If `jabber-debug-log-xml' is nil, do nothing. -FSM is the connection that is sending/receiving. -DIRECTION is a string, either \"sending\" or \"receive\". -DATA is any sexp." - (when jabber-debug-log-xml - (jabber-process-console fsm direction data))) - -(defun jabber-pre-filter (process string fsm) - (with-current-buffer (process-buffer process) - ;; Append new data - (goto-char (point-max)) - (insert string) - - (unless (boundp 'jabber-filtering) - (let (jabber-filtering) - (jabber-filter process fsm))))) - -(defun jabber-filter (process fsm) - "The filter function for the jabber process." - (with-current-buffer (process-buffer process) - ;; Start from the beginning - (goto-char (point-min)) - (let (xml-data) - (loop - do - ;; Skip whitespace - (unless (zerop (skip-chars-forward " \t\r\n")) - (delete-region (point-min) (point))) - ;; Skip processing directive - (when (looking-at "<\\?xml[^?]*\\?>") - (delete-region (match-beginning 0) (match-end 0))) - - ;; Stream end? - (when (looking-at "") - (return (fsm-send fsm :stream-end))) - - ;; Stream header? - (when (looking-at "]*\\(>\\)") - ;; Let's pretend that the stream header is a closed tag, - ;; and parse it as such. - (replace-match "/>" t t nil 1) - (let* ((ending-at (point)) - (stream-header (car (xml-parse-region (point-min) ending-at))) - (session-id (jabber-xml-get-attribute stream-header 'id)) - (stream-version (jabber-xml-get-attribute stream-header 'version))) - - ;; Need to keep any namespace attributes on the stream - ;; header, as they can affect any stanza in the - ;; stream... - (setq jabber-namespace-prefixes - (jabber-xml-merge-namespace-declarations - (jabber-xml-node-attributes stream-header) - nil)) - (jabber-log-xml fsm "receive" stream-header) - (fsm-send fsm (list :stream-start session-id stream-version)) - (delete-region (point-min) ending-at))) - - ;; Normal tag - - ;; XXX: do these checks make sense? If so, reinstate them. - ;;(if (active-minibuffer-window) - ;; (run-with-idle-timer 0.01 nil #'jabber-filter process string) - - ;; This check is needed for xml.el of Emacs 21, as it chokes on - ;; empty attribute values. - (save-excursion - (while (search-forward-regexp " \\w+=''" nil t) - (replace-match ""))) - - (setq xml-data (jabber-xml-parse-next-stanza)) - - while xml-data - do - ;; If there's a problem with writing the XML log, - ;; make sure the stanza is delivered, at least. - (condition-case e - (jabber-log-xml fsm "receive" (car xml-data)) - (error - (ding) - (message "Couldn't write XML log: %s" (error-message-string e)) - (sit-for 2))) - (delete-region (point-min) (point)) - - (fsm-send fsm (list :stanza - (jabber-xml-resolve-namespace-prefixes - (car xml-data) nil jabber-namespace-prefixes))) - ;; XXX: move this logic elsewhere - ;; We explicitly don't catch errors in jabber-process-input, - ;; to facilitate debugging. - ;; (jabber-process-input (car xml-data)) - )))) - -(defun jabber-process-input (jc xml-data) - "Process an incoming parsed tag. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((tag (jabber-xml-node-name xml-data)) - (functions (eval (cdr (assq tag '((iq . jabber-iq-chain) - (presence . jabber-presence-chain) - (message . jabber-message-chain))))))) - (dolist (f functions) - (condition-case e - (funcall f jc xml-data) - ((debug error) - (fsm-debug-output "Error %S while processing %S with function %s" e xml-data f)))))) - -(defun jabber-process-stream-error (xml-data state-data) - "Process an incoming stream error. -Return nil if XML-DATA is not a stream:error stanza. -Return an fsm result list if it is." - (when (and (eq (jabber-xml-node-name xml-data) 'error) - (equal (jabber-xml-get-xmlns xml-data) "http://etherx.jabber.org/streams")) - (let ((condition (jabber-stream-error-condition xml-data)) - (text (jabber-parse-stream-error xml-data))) - (setq state-data (plist-put state-data :disconnection-reason - (format "Stream error: %s" text))) - ;; Special case: when the error is `conflict', we have been - ;; forcibly disconnected by the same user. Don't reconnect - ;; automatically. - (when (eq condition 'conflict) - (setq state-data (plist-put state-data :disconnection-expected t))) - (list nil state-data)))) - -;; XXX: This function should probably die. The roster is stored -;; inside the connection plists, and the obarray shouldn't be so big -;; that we need to clean it. -(defun jabber-clear-roster () - "Clean up the roster." - ;; This is made complicated by the fact that the JIDs are symbols with properties. - (mapatoms #'(lambda (x) - (unintern x jabber-jid-obarray)) - jabber-jid-obarray) - (setq *jabber-roster* nil)) - -(defun jabber-send-sexp (jc sexp) - "Send the xml corresponding to SEXP to connection JC." - (condition-case e - (jabber-log-xml jc "sending" sexp) - (error - (ding) - (message "Couldn't write XML log: %s" (error-message-string e)) - (sit-for 2))) - (jabber-send-string jc (jabber-sexp2xml sexp))) - -(defun jabber-send-sexp-if-connected (jc sexp) - "Send the stanza SEXP only if JC has established a session." - (fsm-send-sync jc (cons :send-if-connected sexp))) - -(defun jabber-send-stream-header (jc) - "Send stream header to connection JC." - (let ((stream-header - (concat " -"))) - (jabber-log-xml jc "sending" stream-header) - (jabber-send-string jc stream-header))) - -(defun jabber-send-string (jc string) - "Send STRING through the connection JC." - (let* ((state-data (fsm-get-state-data jc)) - (connection (plist-get state-data :connection)) - (send-function (plist-get state-data :send-function))) - (unless connection - (error "%s has no connection" (jabber-connection-jid jc))) - (funcall send-function connection string))) - -(unless (fboundp 'sha1) - (require 'sha1)) - -(defun jabber-get-auth (jc to session-id) - "Send IQ get request in namespace \"jabber:iq:auth\". -JC is the Jabber connection." - (jabber-send-iq jc to - "get" - `(query ((xmlns . "jabber:iq:auth")) - (username () ,(plist-get (fsm-get-state-data jc) :username))) - #'jabber-do-logon session-id - #'jabber-report-success "Impossible error - auth field request")) - -(defun jabber-do-logon (jc xml-data session-id) - "Send username and password in logon attempt. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((digest-allowed (jabber-xml-get-children (jabber-iq-query xml-data) 'digest)) - (passwd (when - (or digest-allowed - (plist-get (fsm-get-state-data jc) :encrypted) - (yes-or-no-p "Jabber server only allows cleartext password transmission! Continue? ")) - (or (plist-get (fsm-get-state-data jc) :password) - (jabber-read-password (jabber-connection-bare-jid jc))))) - auth) - (if (null passwd) - (fsm-send jc :authentication-failure) - (if digest-allowed - (setq auth `(digest () ,(sha1 (concat session-id passwd)))) - (setq auth `(password () ,passwd))) - - ;; For legacy authentication we must specify a resource. - (unless (plist-get (fsm-get-state-data jc) :resource) - ;; Yes, this is ugly. Where is my encapsulation? - (plist-put (fsm-get-state-data jc) :resource "emacs-jabber")) - - (jabber-send-iq jc (plist-get (fsm-get-state-data jc) :server) - "set" - `(query ((xmlns . "jabber:iq:auth")) - (username () ,(plist-get (fsm-get-state-data jc) :username)) - ,auth - (resource () ,(plist-get (fsm-get-state-data jc) :resource))) - #'jabber-process-logon passwd - #'jabber-process-logon nil)))) - -(defun jabber-process-logon (jc xml-data closure-data) - "Receive login success or failure, and request roster. -CLOSURE-DATA should be the password on success and nil on failure. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (if closure-data - ;; Logon success - (fsm-send jc (cons :authentication-success closure-data)) - - ;; Logon failure - (jabber-report-success jc xml-data "Logon") - (fsm-send jc :authentication-failure))) - -(require 'format-spec) -(require 'cl) ;for `find' -(defgroup jabber-roster nil "roster display options" - :group 'jabber) - -(defcustom jabber-roster-line-format " %a %c %-25n %u %-8s %S" - "The format specification of the lines in the roster display. - -These fields are available: - -%a Avatar, if any -%c \"*\" if the contact is connected, or \" \" if not -%u sUbscription state - see below -%n Nickname of contact, or JID if no nickname -%j Bare JID of contact (without resource) -%r Highest-priority resource of contact -%s Availability of contact as string (\"Online\", \"Away\" etc) -%S Status string specified by contact - -%u is replaced by one of the strings given by -`jabber-roster-subscription-display'." - :type 'string - :group 'jabber-roster) - -(defcustom jabber-roster-subscription-display '(("none" . " ") - ("from" . "< ") - ("to" . " >") - ("both" . "<->")) - "Strings used for indicating subscription status of contacts. -\"none\" means that there is no subscription between you and the -contact. -\"from\" means that the contact has a subscription to you, but you -have no subscription to the contact. -\"to\" means that you have a subscription to the contact, but the -contact has no subscription to you. -\"both\" means a mutual subscription. - -Having a \"presence subscription\" means being able to see the -other person's presence. - -Some fancy arrows you might want to use, if your system can -display them: ← → ⇄ ↔." - :type '(list (cons :format "%v" (const :format "" "none") (string :tag "None")) - (cons :format "%v" (const :format "" "from") (string :tag "From")) - (cons :format "%v" (const :format "" "to") (string :tag "To")) - (cons :format "%v" (const :format "" "both") (string :tag "Both"))) - :group 'jabber-roster) - -(defcustom jabber-resource-line-format " %r - %s (%S), priority %p" - "The format specification of resource lines in the roster display. -These are displayed when `jabber-show-resources' permits it. - -These fields are available: - -%c \"*\" if the contact is connected, or \" \" if not -%n Nickname of contact, or JID if no nickname -%j Bare JID of contact (without resource) -%p Priority of this resource -%r Name of this resource -%s Availability of resource as string (\"Online\", \"Away\" etc) -%S Status string specified by resource." - :type 'string - :group 'jabber-roster) - -(defcustom jabber-roster-sort-functions - '(jabber-roster-sort-by-status jabber-roster-sort-by-displayname) - "Sort roster according to these criteria. - -These functions should take two roster items A and B, and return: -<0 if A < B -0 if A = B ->0 if A > B." - :type 'hook - :options '(jabber-roster-sort-by-status - jabber-roster-sort-by-displayname - jabber-roster-sort-by-group) - :group 'jabber-roster) - -(defcustom jabber-sort-order '("chat" "" "away" "dnd" "xa") - "Sort by status in this order. Anything not in list goes last. -Offline is represented as nil." - :type '(repeat (restricted-sexp :match-alternatives (stringp nil))) - :group 'jabber-roster) - -(defcustom jabber-show-resources 'sometimes - "Show contacts' resources in roster? -This can be one of the following symbols: - -nil Never show resources -sometimes Show resources when there are more than one -always Always show resources." - :type '(radio (const :tag "Never" nil) - (const :tag "When more than one connected resource" sometimes) - (const :tag "Always" always)) - :group 'jabber-roster) - -(defcustom jabber-show-offline-contacts t - "Show offline contacts in roster when non-nil." - :type 'boolean - :group 'jabber-roster) - -(defcustom jabber-remove-newlines t - "Remove newlines in status messages? -Newlines in status messages mess up the roster display. However, -they are essential to status message poets. Therefore, you get to -choose the behaviour. - -Trailing newlines are always removed, regardless of this variable." - :type 'boolean - :group 'jabber-roster) - -(defcustom jabber-roster-show-bindings t - "Show keybindings in roster buffer?." - :type 'boolean - :group 'jabber-roster) - -(defcustom jabber-roster-show-title t - "Show title in roster buffer?." - :type 'boolean - :group 'jabber-roster) - -(defcustom jabber-roster-mode-hook nil - "Hook run when entering Roster mode." - :group 'jabber-roster - :type 'hook) - -(defcustom jabber-roster-default-group-name "other" - "Default group name for buddies without groups." - :group 'jabber-roster - :type 'string - :get '(lambda (var) - (let ((val (symbol-value var))) - (when (stringp val) - (set-text-properties 0 (length val) nil val)) - val)) - :set '(lambda (var val) - (when (stringp val) - (set-text-properties 0 (length val) nil val)) - (custom-set-default var val)) - ) - -(defcustom jabber-roster-show-empty-group nil - "Show empty groups in roster?." - :group 'jabber-roster - :type 'boolean) - -(defcustom jabber-roster-roll-up-group nil - "Show empty groups in roster?." - :group 'jabber-roster - :type 'boolean) - -(defface jabber-roster-user-online - '((t (:foreground "blue" :weight bold :slant normal))) - "face for displaying online users." - :group 'jabber-roster) - -(defface jabber-roster-user-xa - '((((background dark)) (:foreground "magenta" :weight normal :slant italic)) - (t (:foreground "black" :weight normal :slant italic))) - "face for displaying extended away users." - :group 'jabber-roster) - -(defface jabber-roster-user-dnd - '((t (:foreground "red" :weight normal :slant italic))) - "face for displaying do not disturb users." - :group 'jabber-roster) - -(defface jabber-roster-user-away - '((t (:foreground "dark green" :weight normal :slant italic))) - "face for displaying away users." - :group 'jabber-roster) - -(defface jabber-roster-user-chatty - '((t (:foreground "dark orange" :weight bold :slant normal))) - "face for displaying chatty users." - :group 'jabber-roster) - -(defface jabber-roster-user-error - '((t (:foreground "red" :weight light :slant italic))) - "face for displaying users sending presence errors." - :group 'jabber-roster) - -(defface jabber-roster-user-offline - '((t (:foreground "dark grey" :weight light :slant italic))) - "face for displaying offline users." - :group 'jabber-roster) - -(defvar jabber-roster-debug nil - "Debug roster draw.") - -(defvar jabber-roster-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (set-keymap-parent map jabber-common-keymap) - (define-key map [mouse-2] 'jabber-roster-mouse-2-action-at-point) - (define-key map (kbd "TAB") 'jabber-go-to-next-roster-item) - (define-key map (kbd "S-TAB") 'jabber-go-to-previous-roster-item) - (define-key map (kbd "M-TAB") 'jabber-go-to-previous-roster-item) - (define-key map (kbd "") 'jabber-go-to-previous-roster-item) - (define-key map (kbd "RET") 'jabber-roster-ret-action-at-point) - (define-key map (kbd "C-k") 'jabber-roster-delete-at-point) - - (define-key map "e" 'jabber-roster-edit-action-at-point) - (define-key map "s" 'jabber-send-subscription-request) - (define-key map "q" 'bury-buffer) - (define-key map "i" 'jabber-get-disco-items) - (define-key map "j" 'jabber-muc-join) - (define-key map "I" 'jabber-get-disco-info) - (define-key map "b" 'jabber-get-browse) - (define-key map "v" 'jabber-get-version) - (define-key map "a" 'jabber-send-presence) - (define-key map "g" 'jabber-display-roster) - (define-key map "S" 'jabber-ft-send) - (define-key map "o" 'jabber-roster-toggle-offline-display) - (define-key map "H" 'jabber-roster-toggle-binding-display) - ;;(define-key map "D" 'jabber-disconnect) - map)) - -(defun jabber-roster-ret-action-at-point () - "Action for ret. -Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group at -point." - (interactive) - (let ((group-at-point (get-text-property (point) - 'jabber-group)) - (account-at-point (get-text-property (point) - 'jabber-account)) - (jid-at-point (get-text-property (point) - 'jabber-jid))) - (if (and group-at-point account-at-point) - (jabber-roster-roll-group account-at-point group-at-point) - ;; Is this a normal contact, or a groupchat? Let's ask it. - (jabber-disco-get-info - account-at-point (jabber-jid-user jid-at-point) nil - #'jabber-roster-ret-action-at-point-1 - jid-at-point)))) - -(defun jabber-roster-ret-action-at-point-1 (jc jid result) - ;; If we get an error, assume it's a normal contact. - (if (eq (car result) 'error) - (jabber-chat-with jc jid) - ;; Otherwise, let's check whether it has a groupchat identity. - (let ((identities (car result))) - (if (find "conference" (if (sequencep identities) identities nil) - :key (lambda (i) (aref i 1)) - :test #'string=) - ;; Yes! Let's join it. - (jabber-muc-join jc jid - (jabber-muc-read-my-nickname jc jid t) - t) - ;; No. Let's open a normal chat buffer. - (jabber-chat-with jc jid))))) - -(defun jabber-roster-mouse-2-action-at-point (e) - "Action for mouse 2. -Before try to roll up/down group. Eval `chat-with-jid-at-point' is no group -at point." - (interactive "e") - (mouse-set-point e) - (let ((group-at-point (get-text-property (point) - 'jabber-group)) - (account-at-point (get-text-property (point) - 'jabber-account))) - (if (and group-at-point account-at-point) - (jabber-roster-roll-group account-at-point group-at-point) - (jabber-popup-combined-menu)))) - -(defun jabber-roster-delete-at-point () - "Delete at point from roster. -Try to delete the group from all contaacs. -Delete a jid if there is no group at point." - (interactive) - (let ((group-at-point (get-text-property (point) - 'jabber-group)) - (account-at-point (get-text-property (point) - 'jabber-account))) - (if (and group-at-point account-at-point) - (let ((jids-with-group - (gethash group-at-point - (plist-get - (fsm-get-state-data account-at-point) - :roster-hash)))) - (jabber-roster-delete-group-from-jids account-at-point - jids-with-group - group-at-point)) - (jabber-roster-delete-jid-at-point)))) - -(defun jabber-roster-edit-action-at-point () - "Action for e. Before try to edit group name. -Eval `jabber-roster-change' is no group at point." - (interactive) - (let ((group-at-point (get-text-property (point) - 'jabber-group)) - (account-at-point (get-text-property (point) - 'jabber-account))) - (if (and group-at-point account-at-point) - (let ((jids-with-group - (gethash group-at-point - (plist-get - (fsm-get-state-data account-at-point) - :roster-hash)))) - (jabber-roster-edit-group-from-jids account-at-point - jids-with-group - group-at-point)) - (call-interactively 'jabber-roster-change)))) - -(defun jabber-roster-roll-group (jc group-name &optional set) - "Roll up/down group in roster. -If optional SET is t, roll up group. -If SET is nor t or nil, roll down group." - (let* ((state-data (fsm-get-state-data jc)) - (roll-groups (plist-get state-data :roster-roll-groups)) - (new-roll-groups (if (find group-name roll-groups :test 'string=) - ;; group is rolled up, roll it down if needed - (if (or (not set) (and set (not (eq set t)))) - (remove-if-not (lambda (group-name-in-list) - (not (string= group-name - group-name-in-list))) - roll-groups) - roll-groups) - ;; group is rolled down, roll it up if needed - (if (or (not set) (and set (eq set t))) - (append roll-groups (list group-name)) - roll-groups))) ) - (unless (equal roll-groups new-roll-groups) - (plist-put - state-data :roster-roll-groups - new-roll-groups) - (jabber-display-roster)))) - -(defun jabber-roster-mode () - "Major mode for Jabber roster display. -Use the keybindings (mnemonic as Chat, Roster, Info, MUC, Service) to -bring up menus of actions. -\\{jabber-roster-mode-map}" - (kill-all-local-variables) - (setq major-mode 'jabber-roster-mode - mode-name "jabber-roster") - (use-local-map jabber-roster-mode-map) - (setq buffer-read-only t) - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'jabber-roster-mode-hook) - (run-hooks 'jabber-roster-mode-hook))) - -(put 'jabber-roster-mode 'mode-class 'special) - -;;;###autoload -(defun jabber-switch-to-roster-buffer (&optional jc) - "Switch to roster buffer. -Optional JC argument is ignored; it's there so this function can -be used in `jabber-post-connection-hooks'." - (interactive) - (if (not (get-buffer jabber-roster-buffer)) - (jabber-display-roster) - (switch-to-buffer jabber-roster-buffer))) - -(defun jabber-sort-roster (jc) - "Sort roster according to online status. -JC is the Jabber connection." - (let ((state-data (fsm-get-state-data jc))) - (dolist (group (plist-get state-data :roster-groups)) - (let ((group-name (car group))) - (puthash group-name - (sort - (gethash group-name - (plist-get state-data :roster-hash)) - #'jabber-roster-sort-items) - (plist-get state-data :roster-hash)))))) - -(defun jabber-roster-prepare-roster (jc) - "Make a hash based roster. -JC is the Jabber connection." - (let* ((state-data (fsm-get-state-data jc)) - (hash (make-hash-table :test 'equal)) - (buddies (plist-get state-data :roster)) - (all-groups '())) - (dolist (buddy buddies) - (let ((groups (get buddy 'groups))) - (if groups - (progn - (dolist (group groups) - (progn - (setq all-groups (append all-groups (list group))) - (puthash group - (append (gethash group hash) - (list buddy)) - hash)))) - (progn - (setq all-groups (append all-groups - (list jabber-roster-default-group-name))) - (puthash jabber-roster-default-group-name - (append (gethash jabber-roster-default-group-name hash) - (list buddy)) - hash))))) - - ;; remove duplicates name of group - (setq all-groups (sort - (remove-duplicates all-groups - :test 'string=) - 'string<)) - - ;; put to state-data all-groups as list of list - (plist-put state-data :roster-groups - (mapcar #'list all-groups)) - - ;; put to state-data hash-roster - (plist-put state-data :roster-hash - hash))) - -(defun jabber-roster-sort-items (a b) - "Sort roster items A and B according to `jabber-roster-sort-functions'. -Return t if A is less than B." - (dolist (fn jabber-roster-sort-functions) - (let ((comparison (funcall fn a b))) - (cond - ((< comparison 0) - (return t)) - ((> comparison 0) - (return nil)))))) - -(defun jabber-roster-sort-by-status (a b) - "Sort roster items by online status. -See `jabber-sort-order' for order used." - (flet ((order (item) (length (member (get item 'show) jabber-sort-order)))) - (let ((a-order (order a)) - (b-order (order b))) - ;; Note reversed test. Items with longer X-order go first. - (cond - ((< a-order b-order) - 1) - ((> a-order b-order) - -1) - (t - 0))))) - -(defun jabber-roster-sort-by-displayname (a b) - "Sort roster items by displayed name." - (let ((a-name (jabber-jid-displayname a)) - (b-name (jabber-jid-displayname b))) - (cond - ((string-lessp a-name b-name) -1) - ((string= a-name b-name) 0) - (t 1)))) - -(defun jabber-roster-sort-by-group (a b) - "Sort roster items by group membership." - (flet ((first-group (item) (or (car (get item 'groups)) ""))) - (let ((a-group (first-group a)) - (b-group (first-group b))) - (cond - ((string-lessp a-group b-group) -1) - ((string= a-group b-group) 0) - (t 1))))) - -(defun jabber-fix-status (status) - "Make status strings more readable." - (when status - (when (string-match "\n+$" status) - (setq status (replace-match "" t t status))) - (when jabber-remove-newlines - (while (string-match "\n" status) - (setq status (replace-match " " t t status)))) - status)) - -(defvar jabber-roster-ewoc nil - "Ewoc displaying the roster. -There is only one; we don't rely on buffer-local variables or -such.") - -(defun jabber-roster-filter-display (buddies) - "Filter BUDDIES for items to be displayed in the roster." - (remove-if-not (lambda (buddy) (or jabber-show-offline-contacts - (get buddy 'connected))) - buddies)) - -(defun jabber-roster-toggle-offline-display () - "Toggle display of offline contacts. -To change this permanently, customize the `jabber-show-offline-contacts'." - (interactive) - (setq jabber-show-offline-contacts - (not jabber-show-offline-contacts)) - (jabber-display-roster)) - -(defun jabber-roster-toggle-binding-display () - "Toggle display of the roster binding text." - (interactive) - (setq jabber-roster-show-bindings - (not jabber-roster-show-bindings)) - (jabber-display-roster)) - -(defun jabber-display-roster () - "Switch to the main jabber buffer and refresh the roster display to reflect the current information." - (interactive) - (with-current-buffer (get-buffer-create jabber-roster-buffer) - (if (not (eq major-mode 'jabber-roster-mode)) - (jabber-roster-mode)) - (setq buffer-read-only nil) - ;; line-number-at-pos is in Emacs >= 21.4. Only used to avoid - ;; excessive scrolling when updating roster, so not absolutely - ;; necessary. - (let ((current-line (and (fboundp 'line-number-at-pos) (line-number-at-pos))) - (current-column (current-column))) - (erase-buffer) - (setq jabber-roster-ewoc nil) - (when jabber-roster-show-title - (insert (jabber-propertize "Jabber roster" 'face 'jabber-title-large) "\n")) - (when jabber-roster-show-bindings - (insert "RET Open chat buffer C-k Delete roster item -e Edit item s Send subscription request -q Bury buffer i Get disco items -I Get disco info b Browse -j Join groupchat (MUC) v Get client version -a Send presence o Show offline contacts on/off -C-c C-c Chat menu C-c C-m Multi-User Chat menu -C-c C-i Info menu C-c C-r Roster menu -C-c C-s Service menu - -H Toggle displaying this text -")) - (insert "__________________________________\n\n") - (if (null jabber-connections) - (insert "Not connected\n") - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] #'jabber-send-presence) - (insert (jabber-propertize (concat (format " - %s" - (cdr (assoc *jabber-current-show* jabber-presence-strings))) - (if (not (zerop (length *jabber-current-status*))) - (format " (%s)" - (jabber-fix-status *jabber-current-status*))) - " -") - 'face (or (cdr (assoc *jabber-current-show* jabber-presence-faces)) - 'jabber-roster-user-online) - ;;'mouse-face (cons 'background-color "light grey") - 'keymap map) - "\n"))) - - (dolist (jc jabber-connections) - ;; use a hash-based roster - (when (not (plist-get (fsm-get-state-data jc) :roster-hash)) - (jabber-roster-prepare-roster jc)) - ;; We sort everything before putting it in the ewoc - (jabber-sort-roster jc) - (let ((before-ewoc (point)) - (ewoc (ewoc-create - (lexical-let ((jc jc)) - (lambda (data) - (let* ((group (car data)) - (group-name (car group)) - (buddy (car (cdr data)))) - (jabber-display-roster-entry jc group-name buddy)))) - (concat - (jabber-propertize (concat - (plist-get (fsm-get-state-data jc) :username) - "@" - (plist-get (fsm-get-state-data jc) :server)) - 'face 'jabber-title-medium) - "\n__________________________________\n") - "__________________________________")) - (new-groups '())) - (plist-put(fsm-get-state-data jc) :roster-ewoc ewoc) - (dolist (group (plist-get (fsm-get-state-data jc) :roster-groups)) - (let* ((group-name (car group)) - (buddies (jabber-roster-filter-display - (gethash group-name - (plist-get (fsm-get-state-data jc) :roster-hash))))) - (when (or jabber-roster-show-empty-group - (> (length buddies) 0)) - (let ((group-node (ewoc-enter-last ewoc (list group nil)))) - (if (not (find - group-name - (plist-get (fsm-get-state-data jc) :roster-roll-groups) - :test 'string=)) - (dolist (buddy (reverse buddies)) - (ewoc-enter-after ewoc group-node (list group buddy)))))))) - (goto-char (point-max)) - (insert "\n") - (put-text-property before-ewoc (point) - 'jabber-account jc))) - - (goto-char (point-min)) - (setq buffer-read-only t) - (if (called-interactively-p 'interactive) - (dolist (hook '(jabber-info-message-hooks jabber-alert-info-message-hooks)) - (run-hook-with-args hook 'roster (current-buffer) (funcall jabber-alert-info-message-function 'roster (current-buffer))))) - (when current-line - ;; Go back to previous line - don't use goto-line, since it - ;; sets the mark. - (goto-char (point-min)) - (forward-line (1- current-line)) - ;; ...and go back to previous column - (move-to-column current-column))))) - -(defun jabber-display-roster-entry (jc group-name buddy) - "Format and insert a roster entry for BUDDY at point. -BUDDY is a JID symbol. -JC is the Jabber connection." - (if buddy - (let ((buddy-str (format-spec - jabber-roster-line-format - (list - (cons ?a (jabber-propertize - " " - 'display (get buddy 'avatar))) - (cons ?c (if (get buddy 'connected) "*" " ")) - (cons ?u (cdr (assoc - (or - (get buddy 'subscription) "none") - jabber-roster-subscription-display))) - (cons ?n (if (> (length (get buddy 'name)) 0) - (get buddy 'name) - (symbol-name buddy))) - (cons ?j (symbol-name buddy)) - (cons ?r (or (get buddy 'resource) "")) - (cons ?s (or - (cdr (assoc (get buddy 'show) - jabber-presence-strings)) - (get buddy 'show))) - (cons ?S (if (get buddy 'status) - (jabber-fix-status (get buddy 'status)) - "")) - )))) - (add-text-properties 0 - (length buddy-str) - (list - 'face - (or (cdr (assoc (get buddy 'show) jabber-presence-faces)) - 'jabber-roster-user-online) - ;;'mouse-face - ;;(cons 'background-color "light grey") - 'help-echo - (symbol-name buddy) - 'jabber-jid - (symbol-name buddy) - 'jabber-account - jc) - buddy-str) - (insert buddy-str) - - (when (or (eq jabber-show-resources 'always) - (and (eq jabber-show-resources 'sometimes) - (> (jabber-count-connected-resources buddy) 1))) - (dolist (resource (get buddy 'resources)) - (when (plist-get (cdr resource) 'connected) - (let ((resource-str (format-spec jabber-resource-line-format - (list - (cons ?c "*") - (cons ?n (if (> - (length - (get buddy 'name)) 0) - (get buddy 'name) - (symbol-name buddy))) - (cons ?j (symbol-name buddy)) - (cons ?r (if (> - (length - (car resource)) 0) - (car resource) - "empty")) - (cons ?s (or - (cdr (assoc - (plist-get - (cdr resource) 'show) - jabber-presence-strings)) - (plist-get - (cdr resource) 'show))) - (cons ?S (if (plist-get - (cdr resource) 'status) - (jabber-fix-status - (plist-get (cdr resource) - 'status)) - "")) - (cons ?p (number-to-string - (plist-get (cdr resource) - 'priority))))))) - (add-text-properties 0 - (length resource-str) - (list - 'face - (or (cdr (assoc (plist-get - (cdr resource) - 'show) - jabber-presence-faces)) - 'jabber-roster-user-online) - 'jabber-jid - (format "%s/%s" (symbol-name buddy) (car resource)) - 'jabber-account - jc) - resource-str) - (insert "\n" resource-str)))))) - (let ((group-name (or group-name - jabber-roster-default-group-name))) - (add-text-properties 0 - (length group-name) - (list - 'face 'jabber-title-small - 'jabber-group group-name - 'jabber-account jc) - group-name) - (insert group-name)))) - -;;;###autoload -(defun jabber-roster-update (jc new-items changed-items deleted-items) - "Update roster, in memory and on display. -Add NEW-ITEMS, update CHANGED-ITEMS and remove DELETED-ITEMS, all -three being lists of JID symbols. -JC is the Jabber connection." - (let* ((roster (plist-get (fsm-get-state-data jc) :roster)) - (hash (plist-get (fsm-get-state-data jc) :roster-hash)) - (ewoc (plist-get (fsm-get-state-data jc) :roster-ewoc)) - (all-groups (plist-get (fsm-get-state-data jc) :roster-groups)) - (terminator - (lambda (deleted-items) - (dolist (delete-this deleted-items) - (let ((groups (get delete-this 'groups)) - (terminator - (lambda (g) - (let* - ((group (or g jabber-roster-default-group-name)) - (buddies (gethash group hash))) - (when (not buddies) - (setq new-groups (append new-groups (list group)))) - (puthash group - (delq delete-this buddies) - hash))))) - (if groups - (dolist (group groups) - (terminator group)) - (terminator groups))))))) - - ;; fix a old-roster - (dolist (delete-this deleted-items) - (setq roster (delq delete-this roster))) - (setq roster (append new-items roster)) - (plist-put (fsm-get-state-data jc) :roster roster) - - ;; update a hash-roster - (if (not hash) - (jabber-roster-prepare-roster jc) - - (when jabber-roster-debug - (message "update hash-based roster")) - - ;; delete items - (dolist (delete-this (append deleted-items changed-items)) - (let ((jid (symbol-name delete-this))) - (when jabber-roster-debug - (message (concat "delete jid: " jid))) - (dolist (group (mapcar (lambda (g) (car g)) all-groups)) - (when jabber-roster-debug - (message (concat "try to delete jid: " jid " from group " group))) - (puthash group - (delq delete-this (gethash group hash)) - hash)))) - - ;; insert changed-items - (dolist (insert-this (append changed-items new-items)) - (let ((jid (symbol-name insert-this))) - (when jabber-roster-debug - (message (concat "insert jid: " jid))) - (dolist (group (or (get insert-this 'groups) - (list jabber-roster-default-group-name))) - (when jabber-roster-debug - (message (concat "insert jid: " jid " to group " group))) - (puthash group - (append (gethash group hash) - (list insert-this)) - hash) - (setq all-groups (append all-groups (list (list group))))))) - - - (when jabber-roster-debug - (message "remove duplicates from new group")) - (setq all-groups (sort - (remove-duplicates all-groups - :test (lambda (g1 g2) - (let ((g1-name (car g1)) - (g2-name (car g2))) - (string= g1-name - g2-name)))) - (lambda (g1 g2) - (let ((g1-name (car g1)) - (g2-name (car g2))) - (string< g1-name - g2-name))))) - - (plist-put (fsm-get-state-data jc) :roster-groups all-groups)) - - - (when jabber-roster-debug - (message "re display roster")) - - ;; recreate roster buffer - (jabber-display-roster))) - -(defalias 'jabber-presence-update-roster 'ignore) -;;jabber-presence-update-roster is not needed anymore. -;;Its work is done in `jabber-process-presence'." -(make-obsolete 'jabber-presence-update-roster 'ignore) - -(defun jabber-next-property (&optional prev) - "Return position of next property appearence or nil if there is none. -If optional PREV is non-nil, return position of previous property appearence." - (let ((pos (point)) - (found nil) - (nextprev (if prev 'previous-single-property-change - 'next-single-property-change))) - (while (not found) - (setq pos - (let ((jid (funcall nextprev pos 'jabber-jid)) - (group (funcall nextprev pos 'jabber-group))) - (cond - ((not jid) group) - ((not group) jid) - (t (funcall (if prev 'max 'min) jid group))))) - (if (not pos) - (setq found t) - (setq found (or (get-text-property pos 'jabber-jid) - (get-text-property pos 'jabber-group))))) - pos)) - -(defun jabber-go-to-next-roster-item () - "Move the cursor to the next jid/group in the buffer." - (interactive) - (let* ((next (jabber-next-property)) - (next (if (not next) - (progn (goto-char (point-min)) - (jabber-next-property)) next))) - (if next (goto-char next) - (goto-char (point-min))))) - -(defun jabber-go-to-previous-roster-item () - "Move the cursor to the previous jid/group in the buffer." - (interactive) - (let* ((previous (jabber-next-property 'prev)) - (previous (if (not previous) - (progn (goto-char (point-max)) - (jabber-next-property 'prev)) previous))) - (if previous (goto-char previous) - (goto-char (point-max))))) - -(defun jabber-roster-restore-groups (jc) - "Restore roster's groups rolling state from private storage. -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (jabber-private-get jc 'roster "emacs-jabber" - 'jabber-roster-restore-groups-1 'ignore)) - -(defun jabber-roster-restore-groups-1 (jc xml-data) - "Parse roster groups and restore rolling state. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (when (string= (jabber-xml-get-xmlns xml-data) "emacs-jabber") - (let* ((data (car (last xml-data))) - (groups (if (stringp data) (split-string data "\n") nil))) - (dolist (group groups) - (jabber-roster-roll-group jc group t))))) - -(defun jabber-roster-save-groups () - "Save roster's groups rolling state in private storage." - (interactive) - (dolist (jc jabber-connections) - (let* ((groups (plist-get (fsm-get-state-data jc) :roster-roll-groups)) - (roll-groups - (if groups - (mapconcat (lambda (a) (substring-no-properties a)) groups "\n") - ""))) - (jabber-private-set jc - `(roster ((xmlns . "emacs-jabber")) - ,roll-groups) - 'jabber-report-success "Roster groups saved" - 'jabber-report-success "Failed to save roster groups")))) - -(require 'cl) - -(defvar jabber-export-roster-widget nil) - -(defvar jabber-import-subscription-p-widget nil) - -;;;###autoload -(defun jabber-export-roster (jc) - "Export roster for connection JC." - (interactive (list (jabber-read-account))) - (let ((state-data (fsm-get-state-data jc))) - (jabber-export-roster-do-it - (jabber-roster-to-sexp (plist-get state-data :roster))))) - -(defun jabber-export-roster-do-it (roster) - "Create buffer from which ROSTER can be exported to a file." - (interactive) - (with-current-buffer (get-buffer-create "Export roster") - (jabber-init-widget-buffer nil) - - (widget-insert (jabber-propertize "Export roster\n" - 'face 'jabber-title-large)) - (widget-insert "You are about to save your roster to a file. Here -you can edit it before saving. Changes done here will -not affect your actual roster. - -") - - (widget-create 'push-button :notify #'jabber-export-save "Save to file") - (widget-insert " ") - (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") - (widget-insert "\n\n") - (make-local-variable 'jabber-export-roster-widget) - - (jabber-export-display roster) - - (widget-setup) - (widget-minor-mode 1) - (goto-char (point-min)) - (switch-to-buffer (current-buffer)))) - -;;;###autoload -(defun jabber-import-roster (jc file) - "Create buffer for roster import for connection JC from FILE." - (interactive (list (jabber-read-account) - (read-file-name "Import roster from file: "))) - (let ((roster - (with-temp-buffer - (let ((coding-system-for-read 'utf-8)) - (jabber-roster-xml-to-sexp - (car (xml-parse-file file))))))) - (with-current-buffer (get-buffer-create "Import roster") - (setq jabber-buffer-connection jc) - - (jabber-init-widget-buffer nil) - - (widget-insert (jabber-propertize "Import roster\n" - 'face 'jabber-title-large)) - (widget-insert "You are about to import the contacts below to your roster. - -") - - (make-local-variable 'jabber-import-subscription-p-widget) - (setq jabber-import-subscription-p-widget - (widget-create 'checkbox)) - (widget-insert " Adjust subscriptions\n") - - (widget-create 'push-button :notify #'jabber-import-doit "Import to roster") - (widget-insert " ") - (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") - (widget-insert "\n\n") - (make-local-variable 'jabber-export-roster-widget) - - (jabber-export-display roster) - - (widget-setup) - (widget-minor-mode 1) - (goto-char (point-min)) - (switch-to-buffer (current-buffer))))) - -(defun jabber-export-remove-regexp (&rest ignore) - (let* ((value (widget-value jabber-export-roster-widget)) - (length-before (length value)) - (regexp (read-string "Remove JIDs matching regexp: "))) - (setq value (delete-if - #'(lambda (a) - (string-match regexp (nth 0 a))) - value)) - (widget-value-set jabber-export-roster-widget value) - (widget-setup) - (message "%d items removed" (- length-before (length value))))) - -(defun jabber-export-save (&rest ignore) - "Export roster to file." - (let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget))) - (coding-system-for-write 'utf-8)) - (with-temp-file (read-file-name "Export roster to file: ") - (insert "\n") - (dolist (item items) - (insert (jabber-sexp2xml item) "\n")) - (insert "\n")) - (message "Roster saved"))) - -(defun jabber-import-doit (&rest ignore) - "Import roster being edited in widget." - (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) - (jabber-roster (plist-get state-data :roster)) - roster-delta) - - (dolist (n (widget-value jabber-export-roster-widget)) - (let* ((jid (nth 0 n)) - (name (and (not (zerop (length (nth 1 n)))) - (nth 1 n))) - (subscription (nth 2 n)) - (groups (nth 3 n)) - (jid-symbol (jabber-jid-symbol jid)) - (in-roster-p (memq jid-symbol jabber-roster)) - (jid-name (and in-roster-p (get jid-symbol 'name))) - (jid-subscription (and in-roster-p (get jid-symbol 'subscription))) - (jid-groups (and in-roster-p (get jid-symbol 'groups)))) - ;; Do we need to change the roster? - (when (or - ;; If the contact is not in the roster already, - (not in-roster-p) - ;; or if the import introduces a name, - (and name (not jid-name)) - ;; or changes a name, - (and name jid-name (not (string= name jid-name))) - ;; or introduces new groups. - (set-difference groups jid-groups :test #'string=)) - (push (jabber-roster-sexp-to-xml - (list jid (or name jid-name) nil (union groups jid-groups :test #'string=)) - t) - roster-delta)) - ;; And adujst subscription. - (when (widget-value jabber-import-subscription-p-widget) - (let ((want-to (member subscription '("to" "both"))) - (want-from (member subscription '("from" "both"))) - (have-to (member jid-subscription '("to" "both"))) - (have-from (member jid-subscription '("from" "both")))) - (flet ((request-subscription - (type) - (jabber-send-sexp jabber-buffer-connection - `(presence ((to . ,jid) - (type . ,type)))))) - (cond - ((and want-to (not have-to)) - (request-subscription "subscribe")) - ((and have-to (not want-to)) - (request-subscription "unsubscribe"))) - (cond - ((and want-from (not have-from)) - ;; not much to do here - ) - ((and have-from (not want-from)) - (request-subscription "unsubscribed")))))))) - (when roster-delta - (jabber-send-iq jabber-buffer-connection - nil "set" - `(query ((xmlns . "jabber:iq:roster")) ,@roster-delta) - #'jabber-report-success "Roster import" - #'jabber-report-success "Roster import")))) - -(defun jabber-roster-to-sexp (roster) - "Convert ROSTER to simpler sexp format. -Return a list, where each item is a vector: -\[jid name subscription groups] -where groups is a list of strings." - (mapcar - #'(lambda (n) - (list - (symbol-name n) - (or (get n 'name) "") - (get n 'subscription) - (get n 'groups))) - roster)) - -(defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription) - "Convert SEXP to XML format. -Return an XML node." - `(item ((jid . ,(nth 0 sexp)) - ,@(let ((name (nth 1 sexp))) - (unless (zerop (length name)) - `((name . ,name)))) - ,@(unless omit-subscription - `((subscription . ,(nth 2 sexp))))) - ,@(mapcar - #'(lambda (g) - (list 'group nil g)) - (nth 3 sexp)))) - -(defun jabber-roster-xml-to-sexp (xml-data) - "Convert XML-DATA to simpler sexp format. -XML-DATA is an node with a child. -See `jabber-roster-to-sexp' for description of output format." - (assert (eq (jabber-xml-node-name xml-data) 'iq)) - (let ((query (car (jabber-xml-get-children xml-data 'query)))) - (assert query) - (mapcar - #'(lambda (n) - (list - (jabber-xml-get-attribute n 'jid) - (or (jabber-xml-get-attribute n 'name) "") - (jabber-xml-get-attribute n 'subscription) - (mapcar - #'(lambda (g) - (car (jabber-xml-node-children g))) - (jabber-xml-get-children n 'group)))) - (jabber-xml-get-children query 'item)))) - -(defun jabber-export-display (roster) - (setq jabber-export-roster-widget - (widget-create - '(repeat - :tag "Roster" - (list :format "%v" - (string :tag "JID") - (string :tag "Name") - (choice :tag "Subscription" - (const "none") - (const "both") - (const "to") - (const "from")) - (repeat :tag "Groups" - (string :tag "Group")))) - :value roster))) - -(defvar *jabber-open-info-queries* nil - "An 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)))) - -(require 'cl) - -(defgroup jabber-alerts nil "auditory and visual alerts for jabber events" - :group 'jabber) - -(defcustom jabber-alert-message-hooks '(jabber-message-echo - jabber-message-scroll) - "Hooks run when a new message arrives. - -Arguments are FROM, BUFFER, TEXT and TITLE. FROM is the JID of -the sender, BUFFER is the the buffer where the message can be -read, and TEXT is the text of the message. TITLE is the string -returned by `jabber-alert-message-function' for these arguments, -so that hooks do not have to call it themselves. - -This hook is meant for user customization of message alerts. For -other uses, see `jabber-message-hooks'." - :type 'hook - :options '(jabber-message-beep - jabber-message-wave - jabber-message-echo - jabber-message-switch - jabber-message-display - jabber-message-scroll) - :group 'jabber-alerts) - -(defvar jabber-message-hooks nil - "Internal hooks run when a new message arrives. - -This hook works just like `jabber-alert-message-hooks', except that -it's not meant to be customized by the user.") - -(defcustom jabber-alert-message-function - 'jabber-message-default-message - "Function for constructing short message alert messages. - -Arguments are FROM, BUFFER, and TEXT. This function should return a -string containing an appropriate text message, or nil if no message -should be displayed. - -The provided hooks displaying a text message get it from this function, -and show no message if it returns nil. Other hooks do what they do -every time." - :type 'function - :group 'jabber-alerts) - -(defcustom jabber-alert-muc-hooks '(jabber-muc-echo jabber-muc-scroll) - "Hooks run when a new MUC message arrives. - -Arguments are NICK, GROUP, BUFFER, TEXT and TITLE. NICK is the -nickname of the sender. GROUP is the JID of the group. BUFFER -is the the buffer where the message can be read, and TEXT is the -text of the message. TITLE is the string returned by -`jabber-alert-muc-function' for these arguments, so that hooks do -not have to call it themselves." - :type 'hook - :options '(jabber-muc-beep - jabber-muc-wave - jabber-muc-echo - jabber-muc-switch - jabber-muc-display - jabber-muc-scroll) - :group 'jabber-alerts) - -(defvar jabber-muc-hooks '() - "Internal hooks run when a new MUC message arrives. - -This hook works just like `jabber-alert-muc-hooks', except that -it's not meant to be customized by the user.") - -(defcustom jabber-alert-muc-function - 'jabber-muc-default-message - "Function for constructing short message alert messages. - -Arguments are NICK, GROUP, BUFFER, and TEXT. This function -should return a string containing an appropriate text message, or -nil if no message should be displayed. - -The provided hooks displaying a text message get it from this function, -and show no message if it returns nil. Other hooks do what they do -every time." - :type 'function - :group 'jabber-alerts) - -(defcustom jabber-alert-presence-hooks - '(jabber-presence-echo) - "Hooks run when a user's presence changes. - -Arguments are WHO, OLDSTATUS, NEWSTATUS, STATUSTEXT and -PROPOSED-ALERT. WHO is a symbol whose text is the JID of the contact, -and which has various interesting properties. OLDSTATUS is the old -presence or nil if disconnected. NEWSTATUS is the new presence, or -one of \"subscribe\", \"unsubscribe\", \"subscribed\" and -\"unsubscribed\". TITLE is the string returned by -`jabber-alert-presence-message-function' for these arguments." - :type 'hook - :options '(jabber-presence-beep - jabber-presence-wave - jabber-presence-switch - jabber-presence-display - jabber-presence-echo) - :group 'jabber-alerts) - -(defvar jabber-presence-hooks '(jabber-presence-watch) - "Internal hooks run when a user's presence changes. - -This hook works just like `jabber-alert-presence-hooks', except that -it's not meant to be customized by the user.") - -(defcustom jabber-alert-presence-message-function - 'jabber-presence-default-message - "Function for constructing title of presence alert messages. - -Arguments are WHO, OLDSTATUS, NEWSTATUS and STATUSTEXT. See -`jabber-alert-presence-hooks' for documentation. This function -should return a string containing an appropriate text message, or nil -if no message should be displayed. - -The provided hooks displaying a text message get it from this function. -All hooks refrain from action if this function returns nil." - :type 'function - :group 'jabber-alerts) - -(defcustom jabber-alert-info-message-hooks '(jabber-info-display jabber-info-echo) - "Hooks run when an info request is completed. - -First argument is WHAT, a symbol telling the kind of info request completed. -That might be 'roster, for requested roster updates, and 'browse, for -browse requests. Second argument in BUFFER, a buffer containing the result. -Third argument is PROPOSED-ALERT, containing the string returned by -`jabber-alert-info-message-function' for these arguments." - :type 'hook - :options '(jabber-info-beep - jabber-info-wave - jabber-info-echo - jabber-info-switch - jabber-info-display) - :group 'jabber-alerts) - -(defvar jabber-info-message-hooks '() - "Internal hooks run when an info request is completed. - -This hook works just like `jabber-alert-info-message-hooks', -except that it's not meant to be customized by the user.") - -(defcustom jabber-alert-info-message-function - 'jabber-info-default-message - "Function for constructing info alert messages. - -Arguments are WHAT, a symbol telling the kind of info request completed, -and BUFFER, a buffer containing the result." - :type 'function - :group 'jabber-alerts) - -(defcustom jabber-info-message-alist - '((roster . "Roster display updated") - (browse . "Browse request completed")) - "Alist for info alert messages, used by `jabber-info-default-message'." - :type '(alist :key-type symbol :value-type string - :options (roster browse)) - :group 'jabber-alerts) - -(defcustom jabber-alert-message-wave "" - "A sound file to play when a message arrived. -See `jabber-alert-message-wave-alist' if you want other sounds -for specific contacts." - :type 'file - :group 'jabber-alerts) - -(defcustom jabber-alert-message-wave-alist nil - "Specific sound files for messages from specific contacts. -The keys are regexps matching the JID, and the values are sound -files." - :type '(alist :key-type regexp :value-type file) - :group 'jabber-alerts) - -(defcustom jabber-alert-muc-wave "" - "A sound file to play when a MUC message arrived." - :type 'file - :group 'jabber-alerts) - -(defcustom jabber-alert-presence-wave "" - "A sound file to play when a presence arrived." - :type 'file - :group 'jabber-alerts) - -(defcustom jabber-alert-presence-wave-alist nil - "Specific sound files for presence from specific contacts. -The keys are regexps matching the JID, and the values are sound -files." - :type '(alist :key-type regexp :value-type file) - :group 'jabber-alerts) - -(defcustom jabber-alert-info-wave "" - "A sound file to play when an info query result arrived." - :type 'file - :group 'jabber-alerts) - -(defcustom jabber-play-sound-file 'play-sound-file - "A function to call to play alert sound files." - :type 'function - :group 'jabber-alerts) - -(defmacro define-jabber-alert (name docstring function) - "Define a new family of external alert hooks. -Use this macro when your hooks do nothing except displaying a string -in some new innovative way. You write a string display function, and -this macro does all the boring and repetitive work. - -NAME is the name of the alert family. The resulting hooks will be -called jabber-{message,muc,presence,info}-NAME. -DOCSTRING is the docstring to use for those hooks. -FUNCTION is a function that takes one argument, a string, -and displays it in some meaningful way. It can be either a -lambda form or a quoted function name. -The created functions are inserted as options in Customize. - -Examples: -\(define-jabber-alert foo \"Send foo alert\" 'foo-message) -\(define-jabber-alert bar \"Send bar alert\" - (lambda (msg) (bar msg 42)))" - (let ((sn (symbol-name name))) - (let ((msg (intern (format "jabber-message-%s" sn))) - (muc (intern (format "jabber-muc-%s" sn))) - (pres (intern (format "jabber-presence-%s" sn))) - (info (intern (format "jabber-info-%s" sn)))) - `(progn - (defun ,msg (from buffer text title) - ,docstring - (when title - (funcall ,function text title))) - (pushnew (quote ,msg) (get 'jabber-alert-message-hooks 'custom-options)) - (defun ,muc (nick group buffer text title) - ,docstring - (when title - (funcall ,function text title))) - (pushnew (quote ,muc) (get 'jabber-alert-muc-hooks 'custom-options)) - (defun ,pres (who oldstatus newstatus statustext title) - ,docstring - (when title - (funcall ,function statustext title))) - (pushnew (quote ,pres) (get 'jabber-alert-presence-hooks 'custom-options)) - (defun ,info (infotype buffer text) - ,docstring - (when text - (funcall ,function text))) - (pushnew (quote ,info) (get 'jabber-alert-info-message-hooks 'custom-options)))))) - -;; Alert hooks -(define-jabber-alert echo "Show a message in the echo area" - (lambda (text &optional title) (message "%s" (or title text)))) -(define-jabber-alert beep "Beep on event" - (lambda (&rest ignore) (beep))) - -;; Message alert hooks -(defun jabber-message-default-message (from buffer text) - (when (or jabber-message-alert-same-buffer - (not (memq (selected-window) (get-buffer-window-list buffer)))) - (if (jabber-muc-sender-p from) - (format "Private message from %s in %s" - (jabber-jid-resource from) - (jabber-jid-displayname (jabber-jid-user from))) - (format "Message from %s" (jabber-jid-displayname from))))) - -(defcustom jabber-message-alert-same-buffer t - "If nil, don't display message alerts for the current buffer." - :type 'boolean - :group 'jabber-alerts) - -(defcustom jabber-muc-alert-self nil - "If nil, don't display MUC alerts for your own messages." - :type 'boolean - :group 'jabber-alerts) - -(defun jabber-message-wave (from buffer text title) - "Play the wave file specified in `jabber-alert-message-wave'." - (when title - (let* ((case-fold-search t) - (bare-jid (jabber-jid-user from)) - (sound-file (or (dolist (entry jabber-alert-message-wave-alist) - (when (string-match (car entry) bare-jid) - (return (cdr entry)))) - jabber-alert-message-wave))) - (unless (equal sound-file "") - (funcall jabber-play-sound-file sound-file))))) - -(defun jabber-message-display (from buffer text title) - "Display the buffer where a new message has arrived." - (when title - (display-buffer buffer))) - -(defun jabber-message-switch (from buffer text title) - "Switch to the buffer where a new message has arrived." - (when title - (switch-to-buffer buffer))) - -(defun jabber-message-scroll (from buffer text title) - "Scroll all nonselected windows where the chat buffer is displayed." - ;; jabber-chat-buffer-display will DTRT with point in the buffer. - ;; But this change will not take effect in nonselected windows. - ;; Therefore we do that manually here. - ;; - ;; There are three cases: - ;; 1. The user started typing a message in this window. Point is - ;; greater than jabber-point-insert. In that case, we don't - ;; want to move point. - ;; 2. Point was at the end of the buffer, but no message was being - ;; typed. After displaying the message, point is now close to - ;; the end of the buffer. We advance it to the end. - ;; 3. The user was perusing history in this window. There is no - ;; simple way to distinguish this from 2, so the user loses. - (let ((windows (get-buffer-window-list buffer nil t)) - (new-point-max (with-current-buffer buffer (point-max)))) - (dolist (w windows) - (unless (eq w (selected-window)) - (set-window-point w new-point-max))))) - -;; MUC alert hooks -(defun jabber-muc-default-message (nick group buffer text) - (when (or jabber-message-alert-same-buffer - (not (memq (selected-window) (get-buffer-window-list buffer)))) - (if nick - (when (or jabber-muc-alert-self - (not (string= nick (cdr (assoc group *jabber-active-groupchats*))))) - (format "Message from %s in %s" nick (jabber-jid-displayname - group))) - (format "Message in %s" (jabber-jid-displayname group))))) - -(defun jabber-muc-wave (nick group buffer text title) - "Play the wave file specified in `jabber-alert-muc-wave'." - (when title - (funcall jabber-play-sound-file jabber-alert-muc-wave))) - -(defun jabber-muc-display (nick group buffer text title) - "Display the buffer where a new message has arrived." - (when title - (display-buffer buffer))) - -(defun jabber-muc-switch (nick group buffer text title) - "Switch to the buffer where a new message has arrived." - (when title - (switch-to-buffer buffer))) - -(defun jabber-muc-scroll (nick group buffer text title) - "Scroll buffer even if it is in an unselected window." - (jabber-message-scroll nil buffer nil nil)) - -;; Presence alert hooks -(defun jabber-presence-default-message (who oldstatus newstatus statustext) - "Return a string with the status change if OLDSTATUS and NEWSTATUS differs. - -Return nil if OLDSTATUS and NEWSTATUS are equal, and in other -cases a string of the form \"'name' (jid) is now NEWSTATUS (STATUSTEXT)\". - -This function is not called directly, but is the default for -`jabber-alert-presence-message-function'." - (cond - ((equal oldstatus newstatus) - nil) - (t - (let ((formattedname - (if (> (length (get who 'name)) 0) - (get who 'name) - (symbol-name who))) - (formattedstatus - (or - (cdr (assoc newstatus - '(("subscribe" . " requests subscription to your presence") - ("subscribed" . " has granted presence subscription to you") - ("unsubscribe" . " no longer subscribes to your presence") - ("unsubscribed" . " cancels your presence subscription")))) - (concat " is now " - (or - (cdr (assoc newstatus jabber-presence-strings)) - newstatus))))) - (concat formattedname formattedstatus))))) - -(defun jabber-presence-only-chat-open-message (who oldstatus newstatus statustext) - "Same as `jabber-presence-default-message' but managing the presence messages. - -Return the same as `jabber-presence-default-message' but only -if there is a chat buffer open for WHO, keeping the amount of presence messages -at a more manageable level when there are lots of users. - -This function is not called directly, but can be used as the value for -`jabber-alert-presence-message-function'." - (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))) - (jabber-presence-default-message who oldstatus newstatus statustext))) - -(defun jabber-presence-wave (who oldstatus newstatus statustext proposed-alert) - "Play the wave file specified in `jabber-alert-presence-wave'." - (when proposed-alert - (let* ((case-fold-search t) - (bare-jid (symbol-name who)) - (sound-file (or (dolist (entry jabber-alert-presence-wave-alist) - (when (string-match (car entry) bare-jid) - (return (cdr entry)))) - jabber-alert-presence-wave))) - (unless (equal sound-file "") - (funcall jabber-play-sound-file sound-file))))) - -;; This is now defined in jabber-roster.el. -;; (defun jabber-presence-update-roster (who oldstatus newstatus statustext proposed-alert) -;; "Update the roster display by calling `jabber-display-roster'" -;; (jabber-display-roster)) - -(defun jabber-presence-display (who oldstatus newstatus statustext proposed-alert) - "Display the roster buffer." - (when proposed-alert - (display-buffer jabber-roster-buffer))) - -(defun jabber-presence-switch (who oldstatus newstatus statustext proposed-alert) - "Switch to the roster buffer." - (when proposed-alert - (switch-to-buffer jabber-roster-buffer))) - -(defun jabber-info-default-message (infotype buffer) - "Function for constructing info alert messages. - -The argument is INFOTYPE, a symbol telling the kind of info request completed. -This function uses `jabber-info-message-alist' to find a message." - (concat (cdr (assq infotype jabber-info-message-alist)) - " (buffer "(buffer-name buffer) ")")) - -(defun jabber-info-wave (infotype buffer proposed-alert) - "Play the wave file specified in `jabber-alert-info-wave'." - (if proposed-alert - (funcall jabber-play-sound-file jabber-alert-info-wave))) - -(defun jabber-info-display (infotype buffer proposed-alert) - "Display buffer of completed request." - (when proposed-alert - (display-buffer buffer))) - -(defun jabber-info-switch (infotype buffer proposed-alert) - "Switch to buffer of completed request." - (when proposed-alert - (switch-to-buffer buffer))) - -;;; Personal alert hooks -(defmacro define-personal-jabber-alert (name) - "From ALERT function, make ALERT-personal function. - -This makes sense only for MUC. - -NAME: the name of the sender." - (let ((sn (symbol-name name))) - (let ((func (intern (format "%s-personal" sn)))) - `(progn - (defun ,func (nick group buffer text title) - (if (jabber-muc-looks-like-personal-p text group) - (,name nick group buffer text title))) - (pushnew (quote ,func) (get 'jabber-alert-muc-hooks 'custom-options))))) - ) - -(define-personal-jabber-alert jabber-muc-beep) -(define-personal-jabber-alert jabber-muc-wave) -(define-personal-jabber-alert jabber-muc-echo) -(define-personal-jabber-alert jabber-muc-switch) -(define-personal-jabber-alert jabber-muc-display) - -(defcustom jabber-autoanswer-alist nil - "Specific phrases to autoanswer on specific message. -The keys are regexps matching the incoming message text, and the values are -autoanswer phrase." - :type '(alist :key-type regexp :value-type string) - :group 'jabber-alerts) - -(defun jabber-autoanswer-answer (from buffer text proposed-alert) - "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. -Answer automaticaly when incoming text match the first element of -`jabber-autoanswer-alist'" - (when (and from buffer text proposed-alert jabber-autoanswer-alist) - (let ((message - (dolist (entry jabber-autoanswer-alist) - (when (string-match (car entry) text) - (return (cdr entry)))))) - (if message - (jabber-chat-send jabber-buffer-connection message))) - )) -(pushnew 'jabber-autoanswer-answer (get 'jabber-alert-message-hooks 'custom-options)) - -(defun jabber-autoanswer-answer-muc (nick group buffer text proposed-alert) - "Answer automaticaly when incoming text is in `jabber-autoanswer-alist'. -Answer automaticaly when incoming text match first element -of `jabber-autoanswer-alist'." - (when (and nick group buffer text proposed-alert jabber-autoanswer-alist) - (let ((message - (dolist (entry jabber-autoanswer-alist) - (when (string-match (car entry) text) - (return (cdr entry)))))) - (if message - (jabber-chat-send jabber-buffer-connection message))) - )) -(pushnew 'jabber-autoanswer-answer-muc (get 'jabber-alert-muc-hooks 'custom-options)) - -(defgroup jabber-history nil "Customization options for Emacs -Jabber history files." - :group 'jabber) - -(defcustom jabber-history-enabled nil - "Non-nil means message logging is enabled." - :type 'boolean - :group 'jabber-history) - -(defcustom jabber-history-muc-enabled nil - "Non-nil means MUC logging is enabled. -Default is nil, cause MUC logging may be i/o-intensive." - :type 'boolean - :group 'jabber-history) - -(defcustom jabber-history-dir - (locate-user-emacs-file "jabber-history" ".emacs-jabber") - "Base directory where per-contact history files are stored. -Used only when `jabber-use-global-history' is nil." - :type 'directory - :group 'jabber-history) - -(defcustom jabber-global-history-filename - (locate-user-emacs-file "jabber-global-message-log" ".jabber_global_message_log") - "Global file where all messages are logged. -Used when `jabber-use-global-history' is non-nil." - :type 'file - :group 'jabber-history) - -(defcustom jabber-use-global-history - ;; Using a global history file by default was a bad idea. Let's - ;; default to per-user files unless the global history file already - ;; exists, to avoid breaking existing installations. - (file-exists-p jabber-global-history-filename) - "Whether to use a global file for message history. -If non-nil, `jabber-global-history-filename' is used, otherwise, -messages are stored in per-user files under the -`jabber-history-dir' directory." - :type 'boolean - :group 'jabber-history) - -(defcustom jabber-history-enable-rotation nil - "Whether history files should be renamed when reach certain kilobytes. -Whether history files should be renamed when reach -`jabber-history-size-limit' kilobytes. If nil, history files -will grow indefinitely, otherwise they'll be renamed to --, where is 1 or the smallest -number after the last rotation." - :type 'boolean - :group 'jabber-history) - -(defcustom jabber-history-size-limit 1024 - "Maximum history file size in kilobytes. -When history file reaches this limit, it is renamed to --, where is 1 or the smallest -number after the last rotation." - :type 'integer - :group 'jabber-history) - -(defvar jabber-history-inhibit-received-message-functions nil - "Functions determining whether to log an incoming message stanza. -The functions in this list are called with two arguments, -the connection and the full message stanza. -If any of the functions returns non-nil, the stanza is not logged -in the message history.") - -(defun jabber-rotate-history-p (history-file) - "Return non-nil if HISTORY-FILE should be rotated." - (when (and jabber-history-enable-rotation - (file-exists-p history-file)) - (> (/ (nth 7 (file-attributes history-file)) 1024) - jabber-history-size-limit))) - -(defun jabber-history-rotate (history-file &optional try) - "Rename HISTORY-FILE to HISTORY-FILE-TRY." - (let ((suffix (number-to-string (or try 1)))) - (if (file-exists-p (concat history-file "-" suffix)) - (jabber-history-rotate history-file (if try (1+ try) 1)) - (rename-file history-file (concat history-file "-" suffix))))) - -(add-to-list 'jabber-message-chain 'jabber-message-history) -(defun jabber-message-history (jc xml-data) - "Log message to log file. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (when (and (not jabber-use-global-history) - (not (file-directory-p jabber-history-dir))) - (make-directory jabber-history-dir)) - (let ((is-muc (jabber-muc-message-p xml-data))) - (when (and jabber-history-enabled - (or - (not is-muc) ;chat message or private MUC message - (and jabber-history-muc-enabled is-muc))) ;muc message and muc logging active - (unless (run-hook-with-args-until-success - 'jabber-history-inhibit-received-message-functions - jc xml-data) - (let ((from (jabber-xml-get-attribute xml-data 'from)) - (text (car (jabber-xml-node-children - (car (jabber-xml-get-children xml-data 'body))))) - (timestamp (jabber-message-timestamp xml-data))) - (when (and from text) - (jabber-history-log-message "in" from nil text timestamp))))))) - -(add-hook 'jabber-chat-send-hooks 'jabber-history-send-hook) - -(defun jabber-history-send-hook (body id) - "Log outgoing message to log file." - (when (and (not jabber-use-global-history) - (not (file-directory-p jabber-history-dir))) - (make-directory jabber-history-dir)) - ;; This function is called from a chat buffer, so jabber-chatting-with - ;; contains the desired value. - (if jabber-history-enabled - (jabber-history-log-message "out" nil jabber-chatting-with body (current-time)))) - -(defun jabber-history-filename (contact) - "Return a history filename for CONTACT. -Return a history filename for CONTACT if the per-user file -loggin strategy is used or the global history filename." - (if jabber-use-global-history - jabber-global-history-filename - ;; jabber-jid-symbol is the best canonicalization we have. - (concat jabber-history-dir - "/" (symbol-name (jabber-jid-symbol contact))))) - -(defun jabber-history-log-message (direction from to body timestamp) - "Log a message." - (with-temp-buffer - ;; Remove properties - (set-text-properties 0 (length body) nil body) - ;; Encode text as Lisp string - get decoding for free - (setq body (prin1-to-string body)) - ;; Encode LF and CR - (while (string-match "\n" body) - (setq body (replace-match "\\n" nil t body nil))) - (while (string-match "\r" body) - (setq body (replace-match "\\r" nil t body nil))) - (insert (format "[\"%s\" \"%s\" %s %s %s]\n" - (jabber-encode-time (or timestamp (current-time))) - (or direction - "in") - (or (when from - (prin1-to-string from)) - "\"me\"") - (or (when to - (prin1-to-string to)) - "\"me\"") - body)) - (let ((coding-system-for-write 'utf-8) - (history-file (jabber-history-filename (or from to)))) - (when (and (not jabber-use-global-history) - (not (file-directory-p jabber-history-dir))) - (make-directory jabber-history-dir)) - (when (jabber-rotate-history-p history-file) - (jabber-history-rotate history-file)) - (condition-case e - (write-region (point-min) (point-max) history-file t 'quiet) - (error - (message "Unable to write history: %s" (error-message-string e))))))) - -(defun jabber-history-query (start-time - end-time - number - direction - jid-regexp - history-file) - "Return a list of vectors, one for each message matching the criteria. -START-TIME and END-TIME are floats as obtained from `float-time'. -Either or both may be nil, meaning no restriction. -NUMBER is the maximum number of messages to return, or t for -unlimited. -DIRECTION is either \"in\" or \"out\", or t for no limit on direction. -JID-REGEXP is a regexp which must match the JID. -HISTORY-FILE is the file in which to search. - -Currently jabber-history-query performs a linear search from the end -of the log file." - (when (file-readable-p history-file) - (with-temp-buffer - (let ((coding-system-for-read 'utf-8)) - (if jabber-use-global-history - (insert-file-contents history-file) - (let* ((lines-collected nil) - (matched-files - (directory-files jabber-history-dir t - (concat "^" - (regexp-quote (file-name-nondirectory - history-file))))) - (matched-files - (cons (car matched-files) - (sort (cdr matched-files) 'string>-numerical)))) - (while (not lines-collected) - (if (null matched-files) - (setq lines-collected t) - (let ((file (pop matched-files))) - (progn - (insert-file-contents file) - (when (numberp number) - (if (>= (count-lines (point-min) (point-max)) number) - (setq lines-collected t)))))))))) - (let (collected current-line) - (goto-char (point-max)) - (catch 'beginning-of-file - (while (progn - (backward-sexp) - (setq current-line (car (read-from-string - (buffer-substring - (point) - (save-excursion - (forward-sexp) - (point)))))) - (and (or (null start-time) - (> (jabber-float-time (jabber-parse-time - (aref current-line 0))) - start-time)) - (or (eq number t) - (< (length collected) number)))) - (if (and (or (eq direction t) - (string= direction (aref current-line 1))) - (or (null end-time) - (> end-time (jabber-float-time (jabber-parse-time - (aref current-line 0))))) - (string-match - jid-regexp - (car - (remove "me" - (list (aref current-line 2) - (aref current-line 3)))))) - (push current-line collected)) - (when (bobp) - (throw 'beginning-of-file nil)))) - collected)))) - -(defcustom jabber-backlog-days 3.0 - "Age limit on messages in chat buffer backlog, in days." - :group 'jabber - :type '(choice (number :tag "Number of days") - (const :tag "No limit" nil))) - -(defcustom jabber-backlog-number 10 - "Maximum number of messages in chat buffer backlog." - :group 'jabber - :type 'integer) - -(defun jabber-history-backlog (jid &optional before) - "Fetch context from previous chats with JID. -Return a list of history entries (vectors), limited by -`jabber-backlog-days' and `jabber-backlog-number'. -If BEFORE is non-nil, it should be a float-time after which -no entries will be fetched. `jabber-backlog-days' still -applies, though." - (jabber-history-query - (and jabber-backlog-days - (- (jabber-float-time) (* jabber-backlog-days 86400.0))) - before - jabber-backlog-number - t ; both incoming and outgoing - (concat "^" (regexp-quote (jabber-jid-user jid)) "\\(/.*\\)?$") - (jabber-history-filename jid))) - -(defun jabber-history-move-to-per-user () - "Migrate global history to per-user files." - (interactive) - (when (file-directory-p jabber-history-dir) - (error "Per-user history directory already exists")) - (make-directory jabber-history-dir) - (let ((jabber-use-global-history nil)) - (with-temp-buffer - (let ((coding-system-for-read 'utf-8)) - (insert-file-contents jabber-global-history-filename)) - (let ((progress-reporter - (when (fboundp 'make-progress-reporter) - (make-progress-reporter "Migrating history..." - (point-min) (point-max)))) - ;;(file-table (make-hash-table :test 'equal)) - ;; Keep track of blocks of entries pertaining to the same JID. - current-jid jid-start) - (while (not (eobp)) - (let* ((start (point)) - (end (progn (forward-line) (point))) - (line (buffer-substring start end)) - (parsed (car (read-from-string line))) - (jid (if (string= (aref parsed 2) "me") - (aref parsed 3) - (aref parsed 2)))) - ;; Whenever there is a change in JID... - (when (not (equal jid current-jid)) - (when current-jid - ;; ...save data for previous JID... - (let ((history-file (jabber-history-filename current-jid))) - (write-region jid-start start history-file t 'quiet))) - ;; ...and switch to new JID. - (setq current-jid jid) - (setq jid-start start)) - (when (fboundp 'progress-reporter-update) - (progress-reporter-update progress-reporter (point))))) - ;; Finally, save the last block, if any. - (when current-jid - (let ((history-file (jabber-history-filename current-jid))) - (write-region jid-start (point-max) history-file t 'quiet)))))) - (message "Done. Please change `jabber-use-global-history' now.")) - -(defvar jabber-point-insert nil - "Position where the message being composed starts.") - -(defvar jabber-send-function nil - "Function for sending a message from a chat buffer.") - -(defvar jabber-chat-mode-hook nil - "Hook called at the end of `jabber-chat-mode'. -Note that functions in this hook have no way of knowing -what kind of chat buffer is being created.") - -(defcustom jabber-chat-fill-long-lines t - "If non-nil, fill long lines in chat buffers. -Lines are broken at word boundaries at the width of the -window or at `fill-column', whichever is shorter." - :group 'jabber-chat - :type 'boolean) - -(defvar jabber-chat-ewoc nil - "The ewoc showing the messages of this chat buffer.") - -;;;###autoload -(defvar jabber-buffer-connection nil - "The connection used by this buffer.") -;;;###autoload -(make-variable-buffer-local 'jabber-buffer-connection) - -(defun jabber-chat-mode (jc ewoc-pp) - "Jabber chat mode. -\\{jabber-chat-mode-map} - -JC is the Jabber connection." - (kill-all-local-variables) - ;; Make sure to set this variable somewhere - (make-local-variable 'jabber-send-function) - (make-local-variable 'scroll-conservatively) - (make-local-variable 'jabber-point-insert) - (make-local-variable 'jabber-chat-ewoc) - (make-local-variable 'buffer-undo-list) - - (setq jabber-buffer-connection jc - scroll-conservatively 5 - buffer-undo-list t) ;dont keep undo list for chatbuffer - - (unless jabber-chat-ewoc - (setq jabber-chat-ewoc - (ewoc-create ewoc-pp nil "---")) - (goto-char (point-max)) - (put-text-property (point-min) (point) 'read-only t) - (let ((inhibit-read-only t)) - (put-text-property (point-min) (point) 'front-sticky t) - (put-text-property (point-min) (point) 'rear-nonsticky t)) - (setq jabber-point-insert (point-marker))) - - ;;(setq header-line-format jabber-chat-header-line-format) - - (setq major-mode 'jabber-chat-mode - mode-name "jabber-chat") - (use-local-map jabber-chat-mode-map) - - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'jabber-chat-mode-hook) - (run-hooks 'jabber-chat-mode-hook))) - -(put 'jabber-chat-mode 'mode-class 'special) - -;; Spell check only what you're currently writing -(defun jabber-chat-mode-flyspell-verify () - (>= (point) jabber-point-insert)) -(put 'jabber-chat-mode 'flyspell-mode-predicate - 'jabber-chat-mode-flyspell-verify) - -(defvar jabber-chat-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map jabber-common-keymap) - (define-key map "\r" 'jabber-chat-buffer-send) - map)) - -(defun jabber-chat-buffer-send () - (interactive) - ;; If user accidentally hits RET without writing anything, just - ;; ignore it. - (when (plusp (- (point-max) jabber-point-insert)) - ;; If connection was lost... - (unless (memq jabber-buffer-connection jabber-connections) - ;; ...maybe there is a new connection to the same account. - (let ((new-jc (jabber-find-active-connection jabber-buffer-connection))) - (if new-jc - ;; If so, just use it. - (setq jabber-buffer-connection new-jc) - ;; Otherwise, ask for a new account. - (setq jabber-buffer-connection (jabber-read-account t))))) - - (let ((body (delete-and-extract-region jabber-point-insert (point-max)))) - (funcall jabber-send-function jabber-buffer-connection body)))) - -(defun jabber-chat-buffer-fill-long-lines () - "Fill lines that are wider than the window width." - ;; This was mostly stolen from article-fill-long-lines - (interactive) - (save-excursion - (let ((inhibit-read-only t) - (width (window-width (get-buffer-window (current-buffer))))) - (goto-char (point-min)) - (let ((adaptive-fill-mode nil)) ;Why? -sm - (while (not (eobp)) - (end-of-line) - (when (>= (current-column) (min fill-column width)) - (save-restriction - (narrow-to-region (min (1+ (point)) (point-max)) - (point-at-bol)) - (let ((goback (point-marker))) - (fill-paragraph nil) - (goto-char (marker-position goback))))) - (forward-line 1)))))) - -;;;###autoload -(defun jabber-compose (jc &optional recipient) - "Create a buffer for composing a Jabber message. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "To whom? "))) - - (with-current-buffer (get-buffer-create - (generate-new-buffer-name - (concat - "Jabber-Compose" - (when recipient - (format "-%s" (jabber-jid-displayname recipient)))))) - (set (make-local-variable 'jabber-widget-alist) nil) - (setq jabber-buffer-connection jc) - (use-local-map widget-keymap) - - (insert (jabber-propertize "Compose Jabber message\n" 'face 'jabber-title-large)) - - (insert (substitute-command-keys "\\Completion available with \\[widget-complete].\n")) - (push (cons :recipients - (widget-create '(repeat :tag "Recipients" jid) - :value (when recipient - (list recipient)))) - jabber-widget-alist) - - (insert "\nSubject: ") - (push (cons :subject - (widget-create 'editable-field :value "")) - jabber-widget-alist) - - (insert "\nText:\n") - (push (cons :text - (widget-create 'text :value "")) - jabber-widget-alist) - - (insert "\n") - (widget-create 'push-button :notify #'jabber-compose-send "Send") - - (widget-setup) - - (switch-to-buffer (current-buffer)) - (goto-char (point-min)))) - -(defun jabber-compose-send (&rest ignore) - (let ((recipients (widget-value (cdr (assq :recipients jabber-widget-alist)))) - (subject (widget-value (cdr (assq :subject jabber-widget-alist)))) - (text (widget-value (cdr (assq :text jabber-widget-alist))))) - (when (null recipients) - (error "No recipients specified")) - - (dolist (to recipients) - (jabber-send-message jabber-buffer-connection to subject text nil)) - - (bury-buffer) - (message "Message sent"))) - -(require 'ewoc) -(eval-when-compile (require 'cl)) - -(defgroup jabber-chat nil "chat display options" - :group 'jabber) - -(defcustom jabber-chat-buffer-format "*-jabber-chat-%n-*" - "The format specification for the name of chat buffers. - -These fields are available (all are about the person you are chatting -with): - -%n Nickname, or JID if no nickname set -%j Bare JID (without resource) -%r Resource" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-chat-header-line-format - '("" (jabber-chat-buffer-show-avatar - (:eval - (let ((buddy (jabber-jid-symbol jabber-chatting-with))) - (jabber-propertize " " - 'display (get buddy 'avatar))))) - (:eval (jabber-jid-displayname jabber-chatting-with)) - "\t" (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with))) - (propertize - (or - (cdr (assoc (get buddy 'show) jabber-presence-strings)) - (get buddy 'show)) - 'face - (or (cdr (assoc (get buddy 'show) jabber-presence-faces)) - 'jabber-roster-user-online)))) - "\t" (:eval (jabber-fix-status (get (jabber-jid-symbol jabber-chatting-with) 'status))) - "\t" jabber-events-message ;see jabber-events.el - "\t" jabber-chatstates-message) ;see jabber-chatstates.el - "The specification for the header line of chat buffers. - -The format is that of `mode-line-format' and `header-line-format'." - :type 'sexp - :group 'jabber-chat) - -(defcustom jabber-chat-buffer-show-avatar t - "Show avatars in header line of chat buffer? -This variable might not take effect if you have changed -`jabber-chat-header-line-format'." - :type 'boolean - :group 'jabber-chat) - -(defcustom jabber-chat-time-format "%H:%M" - "The format specification for instant messages in the chat buffer. -See also `jabber-chat-delayed-time-format'. - -See `format-time-string' for valid values." - :type 'string - :group 'jabber-chat) - -(defcustom jabber-chat-delayed-time-format "%Y-%m-%d %H:%M" - "The format specification for delayed messages in the chat buffer. -See also `jabber-chat-time-format'. - -See `format-time-string' for valid values." - :type 'string - :group 'jabber-chat) - -(defcustom jabber-print-rare-time t - "Non-nil means to print \"rare time\" indications in chat buffers. -The default settings tell every new hour." - :type 'boolean - :group 'jabber-chat) - -(defcustom jabber-rare-time-format "%a %e %b %Y %H:00" - "The format specification for the rare time information. -Rare time information will be printed whenever the current time, -formatted according to this string, is different to the last -rare time printed." - :type 'string - :group 'jabber-chat) - -(defface jabber-rare-time-face - '((t (:foreground "darkgreen" :underline t))) - "face for displaying the rare time info" - :group 'jabber-chat) - -(defcustom jabber-chat-local-prompt-format "[%t] %n> " - "The format specification for lines you type in the chat buffer. - -These fields are available: - -%t Time, formatted according to `jabber-chat-time-format' - or `jabber-chat-delayed-time-format' -%u Username -%n Nickname (obsolete, same as username) -%r Resource -%j Bare JID (without resource)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-chat-foreign-prompt-format "[%t] %n> " - "The format specification for lines others type in the chat buffer. - -These fields are available: - -%t Time, formatted according to `jabber-chat-time-format' - or `jabber-chat-delayed-time-format' -%n Nickname, or JID if no nickname set -%u Username -%r Resource -%j Bare JID (without resource)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-chat-system-prompt-format "[%t] *** " - "The format specification for lines from the system or that are special in the chat buffer." - :type 'string - :group 'jabber-chat) - -(defface jabber-chat-prompt-local - '((t (:foreground "blue" :weight bold))) - "face for displaying the chat prompt for what you type in" - :group 'jabber-chat) - -(defface jabber-chat-prompt-foreign - '((t (:foreground "red" :weight bold))) - "face for displaying the chat prompt for what they send" - :group 'jabber-chat) - -(defface jabber-chat-prompt-system - '((t (:foreground "green" :weight bold))) - "face used for system and special messages" - :group 'jabber-chat) - -(defface jabber-chat-text-local '((t ())) - "Face used for text you write" - :group 'jabber-chat) - -(defface jabber-chat-text-foreign '((t ())) - "Face used for text others write" - :group 'jabber-chat) - -(defface jabber-chat-error - '((t (:foreground "red" :weight bold))) - "Face used for error messages" - :group 'jabber-chat) - -;;;###autoload -(defvar jabber-chatting-with nil - "JID of the person you are chatting with.") - -(defvar jabber-chat-printers '(jabber-chat-print-subject - jabber-chat-print-body - jabber-chat-print-url - jabber-chat-goto-address) - "List of functions that may be able to print part of a message. -Each function receives these arguments: - -XML-DATA The entire message stanza -WHO :local or :foreign, for sent or received stanza, respectively -MODE :insert or :printp. For :insert, insert text at point. - For :printp, return non-nil if function would insert text.") - -(defvar jabber-body-printers '(jabber-chat-normal-body) - "List of functions that may be able to print a body for a message. -Each function receives these arguments: - -XML-DATA The entire message stanza -WHO :local, :foreign or :error -MODE :insert or :printp. For :insert, insert text at point. - For :printp, return non-nil if function would insert text. - -These functions are called in order, until one of them returns -non-nil. - -Add a function to the beginning of this list if the tag it handles -replaces the contents of the tag.") - -(defvar jabber-chat-send-hooks nil - "List of functions called when a chat message is sent. -The arguments are the text to send, and the id attribute of the -message. - -The functions should return a list of XML nodes they want to be -added to the outgoing message.") - -(defvar jabber-chat-earliest-backlog nil - "Float-time of earliest backlog entry inserted into buffer. -nil if no backlog has been inserted.") - -;;;###autoload -(defun jabber-chat-get-buffer (chat-with) - "Return the chat buffer for chatting with CHAT-WITH (bare or full JID). -Either a string or a buffer is returned, so use `get-buffer' or -`get-buffer-create'." - (format-spec jabber-chat-buffer-format - (list - (cons ?n (jabber-jid-displayname chat-with)) - (cons ?j (jabber-jid-user chat-with)) - (cons ?r (or (jabber-jid-resource chat-with) ""))))) - -(defun jabber-chat-create-buffer (jc chat-with) - "Prepare a buffer for chatting with CHAT-WITH. -This function is idempotent. -JC is the Jabber connection." - (with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with)) - (unless (eq major-mode 'jabber-chat-mode) - (jabber-chat-mode jc #'jabber-chat-pp) - - (make-local-variable 'jabber-chatting-with) - (setq jabber-chatting-with chat-with) - (setq jabber-send-function 'jabber-chat-send) - (setq header-line-format jabber-chat-header-line-format) - - (make-local-variable 'jabber-chat-earliest-backlog) - - ;; insert backlog - (when (null jabber-chat-earliest-backlog) - (let ((backlog-entries (jabber-history-backlog chat-with))) - (if (null backlog-entries) - (setq jabber-chat-earliest-backlog (jabber-float-time)) - (setq jabber-chat-earliest-backlog - (jabber-float-time (jabber-parse-time - (aref (car backlog-entries) 0)))) - (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries)))))) - - ;; Make sure the connection variable is up to date. - (setq jabber-buffer-connection jc) - - (current-buffer))) - -(defun jabber-chat-insert-backlog-entry (msg) - "Insert backlog entry MSG at beginning of buffer." - ;; Rare timestamps are especially important in backlog. We risk - ;; having superfluous timestamps if we just add before each backlog - ;; entry. - (let* ((message-time (jabber-parse-time (aref msg 0))) - (fake-stanza `(message ((from . ,(aref msg 2))) - (body nil ,(aref msg 4)) - (x ((xmlns . "jabber:x:delay") - (stamp . ,(jabber-encode-legacy-time message-time)))))) - (node-data (list (if (string= (aref msg 1) "in") :foreign :local) - fake-stanza :delayed t))) - - ;; Insert after existing rare timestamp? - (if (and jabber-print-rare-time - (ewoc-nth jabber-chat-ewoc 0) - (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time) - (not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0)))))) - (ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data) - ;; Insert first. - (ewoc-enter-first jabber-chat-ewoc node-data) - (when jabber-print-rare-time - (ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time)))))) - -(add-to-list 'jabber-jid-chat-menu - (cons "Display more context" 'jabber-chat-display-more-backlog)) - -(defun jabber-chat-display-more-backlog (how-many) - "Display more context. HOW-MANY is number of messages. Specify 0 to display all messages." - (interactive "nHow many more messages (Specify 0 to display all)? ") - (let* ((inhibit-read-only t) - (jabber-backlog-days nil) - (jabber-backlog-number (if (= how-many 0) t how-many)) - (backlog-entries (jabber-history-backlog - (or jabber-chatting-with jabber-group) jabber-chat-earliest-backlog))) - (when backlog-entries - (setq jabber-chat-earliest-backlog - (jabber-float-time (jabber-parse-time - (aref (car backlog-entries) 0)))) - (save-excursion - (goto-char (point-min)) - (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries)))))) - -(add-to-list 'jabber-message-chain 'jabber-process-chat) - -(defun jabber-get-forwarded-message (xml-data) - (let* ((sent (car (jabber-xml-get-children xml-data 'sent))) - (forwarded (car (jabber-xml-get-children sent 'forwarded))) - (forwarded-message (car (jabber-xml-get-children forwarded 'message)))) - (when forwarded-message - forwarded-message))) - -(defun jabber-process-chat (jc xml-data) - "If XML-DATA is a one-to-one chat message, handle it as such. -JC is the Jabber connection." - ;; For now, everything that is not a public MUC message is - ;; potentially a 1to1 chat message. - (when (not (jabber-muc-message-p xml-data)) - ;; Note that we handle private MUC messages here. - (cl-destructuring-bind (xml-data chat-buffer) - (if (car (jabber-xml-get-children xml-data 'sent)) - (let* ((fwd-msg (jabber-get-forwarded-message xml-data)) - (to (jabber-xml-get-attribute fwd-msg 'to))) - (list fwd-msg - (jabber-chat-create-buffer jc to))) - (list xml-data nil)) - (let ((from (jabber-xml-get-attribute xml-data 'from)) - (error-p (jabber-xml-get-children xml-data 'error)) - (body-text (car (jabber-xml-node-children - (car (jabber-xml-get-children - xml-data 'body)))))) - ;; First check if we would output anything for this stanza. - (when (or error-p - (run-hook-with-args-until-success 'jabber-chat-printers - xml-data - :foreign :printp)) - ;; If so, create chat buffer, if necessary... - (with-current-buffer (if (jabber-muc-sender-p from) - (jabber-muc-private-create-buffer - jc - (jabber-jid-user from) - (jabber-jid-resource from)) - (or chat-buffer - (jabber-chat-create-buffer jc from))) - ;; ...add the message to the ewoc... - (let ((node (ewoc-enter-last jabber-chat-ewoc - (list (if error-p :error :foreign) - xml-data - :time - (current-time))))) - (jabber-maybe-print-rare-time node)) - - ;; ...and call alert hooks. - (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks)) - (run-hook-with-args hook - from (current-buffer) body-text - (funcall jabber-alert-message-function - from (current-buffer) body-text))))))))) - -(defun jabber-chat-send (jc body) - "Send BODY through connection JC, and display it in chat buffer. -JC is the Jabber connection." - ;; Build the stanza... - (let* ((id (apply 'format "emacs-msg-%d.%d.%d" (current-time))) - (stanza-to-send `(message - ((to . ,jabber-chatting-with) - (type . "chat") - (id . ,id)) - (body () ,body)))) - ;; ...add additional elements... - ;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead. - ;; That way we don't need to eliminate the "local hook" functionality - ;; here. - (dolist (hook jabber-chat-send-hooks) - (if (eq hook t) - ;; Local hook referring to global... - (when (local-variable-p 'jabber-chat-send-hooks) - (dolist (global-hook (default-value 'jabber-chat-send-hooks)) - (nconc stanza-to-send (funcall global-hook body id)))) - (nconc stanza-to-send (funcall hook body id)))) - ;; ...display it, if it would be displayed. - (when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp) - (jabber-maybe-print-rare-time - (ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time))))) - ;; ...and send it... - (jabber-send-sexp jc stanza-to-send))) - -(defun jabber-chat-pp (data) - "Pretty-print a stanza. -\(car data) is either :local, :foreign, :error or :notice. -\(cadr data) is the stanza. -This function is used as an ewoc prettyprinter." - (let* ((beg (point)) - (original-timestamp (when (listp (cadr data)) - (jabber-message-timestamp (cadr data)))) - (internal-time - (plist-get (cddr data) :time)) - (body (ignore-errors (car - (jabber-xml-node-children - (car - (jabber-xml-get-children (cadr data) 'body)))))) - (/me-p - (and (> (length body) 4) - (string= (substring body 0 4) "/me ")))) - - ;; Print prompt... - (let ((delayed (or original-timestamp (plist-get (cddr data) :delayed))) - (prompt-start (point))) - (case (car data) - (:local - (jabber-chat-self-prompt (or original-timestamp internal-time) - delayed - /me-p)) - (:foreign - (if (and (listp (cadr data)) - (jabber-muc-private-message-p (cadr data))) - (jabber-muc-private-print-prompt (cadr data)) - ;; For :error and :notice, this might be a string... beware - (jabber-chat-print-prompt (when (listp (cadr data)) (cadr data)) - (or original-timestamp internal-time) - delayed - /me-p))) - ((:error :notice :subscription-request) - (jabber-chat-system-prompt (or original-timestamp internal-time))) - (:muc-local - (jabber-muc-print-prompt (cadr data) t /me-p)) - (:muc-foreign - (jabber-muc-print-prompt (cadr data) nil /me-p)) - ((:muc-notice :muc-error) - (jabber-muc-system-prompt))) - (put-text-property prompt-start (point) 'field 'jabber-prompt)) - - ;; ...and body - (case (car data) - ((:local :foreign) - (run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert)) - ((:muc-local :muc-foreign) - (let ((printers (append jabber-muc-printers jabber-chat-printers))) - (run-hook-with-args 'printers (cadr data) (car data) :insert))) - ((:error :muc-error) - (if (stringp (cadr data)) - (insert (jabber-propertize (cadr data) 'face 'jabber-chat-error)) - (jabber-chat-print-error (cadr data)))) - ((:notice :muc-notice) - (insert (cadr data))) - (:rare-time - (insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data)) - 'face 'jabber-rare-time-face))) - (:subscription-request - (insert "This user requests subscription to your presence.\n") - (when (and (stringp (cadr data)) (not (zerop (length (cadr data))))) - (insert "Message: " (cadr data) "\n")) - (insert "Accept?\n\n") - (flet ((button - (text action) - (if (fboundp 'insert-button) - (insert-button text 'action action) - ;; simple button replacement - (let ((keymap (make-keymap))) - (define-key keymap "\r" action) - (insert (jabber-propertize text 'keymap keymap 'face 'highlight)))) - (insert "\t"))) - (button "Mutual" 'jabber-subscription-accept-mutual) - (button "One-way" 'jabber-subscription-accept-one-way) - (button "Decline" 'jabber-subscription-decline)))) - - (when jabber-chat-fill-long-lines - (save-restriction - (narrow-to-region beg (point)) - (jabber-chat-buffer-fill-long-lines))) - - (put-text-property beg (point) 'read-only t) - (put-text-property beg (point) 'front-sticky t) - (put-text-property beg (point) 'rear-nonsticky t))) - -(defun jabber-rare-time-needed (time1 time2) - "Return non-nil if a timestamp should be printed between TIME1 and TIME2." - (not (string= (format-time-string jabber-rare-time-format time1) - (format-time-string jabber-rare-time-format time2)))) - -(defun jabber-maybe-print-rare-time (node) - "Print rare time before NODE, if appropriate." - (let* ((prev (ewoc-prev jabber-chat-ewoc node)) - (data (ewoc-data node)) - (prev-data (when prev (ewoc-data prev)))) - (flet ((entry-time (entry) - (or (when (listp (cadr entry)) - (jabber-message-timestamp (cadr entry))) - (plist-get (cddr entry) :time)))) - (when (and jabber-print-rare-time - (or (null prev) - (jabber-rare-time-needed (entry-time prev-data) - (entry-time data)))) - (ewoc-enter-before jabber-chat-ewoc node - (list :rare-time (entry-time data))))))) - -(defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p) - "Print prompt for received message in XML-DATA. -TIMESTAMP is the timestamp to print, or nil to get it -from a jabber:x:delay element. -If DELAYED is non-nil, print long timestamp -\(`jabber-chat-delayed-time-format' as opposed to -`jabber-chat-time-format'). -If DONT-PRINT-NICK-P is non-nil, don't include nickname." - (let ((from (jabber-xml-get-attribute xml-data 'from)) - (timestamp (or timestamp (jabber-message-timestamp xml-data)))) - (insert (jabber-propertize - (format-spec jabber-chat-foreign-prompt-format - (list - (cons ?t (format-time-string - (if delayed - jabber-chat-delayed-time-format - jabber-chat-time-format) - timestamp)) - (cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from))) - (cons ?u (or (jabber-jid-username from) from)) - (cons ?r (jabber-jid-resource from)) - (cons ?j (jabber-jid-user from)))) - 'face 'jabber-chat-prompt-foreign - 'help-echo - (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from))))) - -(defun jabber-chat-system-prompt (timestamp) - (insert (jabber-propertize - (format-spec jabber-chat-foreign-prompt-format - (list - (cons ?t (format-time-string jabber-chat-time-format - timestamp)) - (cons ?n "") - (cons ?u "") - (cons ?r "") - (cons ?j ""))) - 'face 'jabber-chat-prompt-system - 'help-echo - (concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp))))) - -(defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p) - "Print prompt for sent message. -TIMESTAMP is the timestamp to print, or nil for now. -If DELAYED is non-nil, print long timestamp -\(`jabber-chat-delayed-time-format' as opposed to -`jabber-chat-time-format'). -If DONT-PRINT-NICK-P is non-nil, don't include nickname." - (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) - (username (plist-get state-data :username)) - (server (plist-get state-data :server)) - (resource (plist-get state-data :resource)) - (nickname username)) - (insert (jabber-propertize - (format-spec jabber-chat-local-prompt-format - (list - (cons ?t (format-time-string - (if delayed - jabber-chat-delayed-time-format - jabber-chat-time-format) - timestamp)) - (cons ?n (if dont-print-nick-p "" nickname)) - (cons ?u username) - (cons ?r resource) - (cons ?j (concat username "@" server)))) - 'face 'jabber-chat-prompt-local - 'help-echo - (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you"))))) - -(defun jabber-chat-print-error (xml-data) - "Print error in given in a readable way. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((the-error (car (jabber-xml-get-children xml-data 'error)))) - (insert - (jabber-propertize - (concat "Error: " (jabber-parse-error the-error)) - 'face 'jabber-chat-error)))) - -(defun jabber-chat-print-subject (xml-data who mode) - "Print subject of given , if any. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((subject (car - (jabber-xml-node-children - (car - (jabber-xml-get-children xml-data 'subject)))))) - (when (not (zerop (length subject))) - (case mode - (:printp - t) - (:insert - (insert (jabber-propertize - "Subject: " 'face 'jabber-chat-prompt-system) - (jabber-propertize - subject - 'face 'jabber-chat-text-foreign) - "\n")))))) - -(defun jabber-chat-print-body (xml-data who mode) - (run-hook-with-args-until-success 'jabber-body-printers xml-data who mode)) - -(defun jabber-chat-normal-body (xml-data who mode) - "Print body for received message in XML-DATA." - (let ((body (car - (jabber-xml-node-children - (car - (jabber-xml-get-children xml-data 'body)))))) - (when body - - (when (eql mode :insert) - (if (and (> (length body) 4) - (string= (substring body 0 4) "/me ")) - (let ((action (substring body 4)) - (nick (cond - ((eq who :local) - (plist-get (fsm-get-state-data jabber-buffer-connection) :username)) - ((or (jabber-muc-message-p xml-data) - (jabber-muc-private-message-p xml-data)) - (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from))) - (t - (jabber-jid-displayname (jabber-xml-get-attribute xml-data 'from)))))) - (insert (jabber-propertize - (concat nick - " " - action) - 'face 'jabber-chat-prompt-system))) - (insert (jabber-propertize - body - 'face (case who - ((:foreign :muc-foreign) 'jabber-chat-text-foreign) - ((:local :muc-local) 'jabber-chat-text-local)))))) - t))) - -(defun jabber-chat-print-url (xml-data who mode) - "Print URLs provided in jabber:x:oob namespace. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((foundp nil)) - (dolist (x (jabber-xml-node-children xml-data)) - (when (and (listp x) (eq (jabber-xml-node-name x) 'x) - (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob")) - (setq foundp t) - - (when (eql mode :insert) - (let ((url (car (jabber-xml-node-children - (car (jabber-xml-get-children x 'url))))) - (desc (car (jabber-xml-node-children - (car (jabber-xml-get-children x 'desc)))))) - (insert "\n" - (jabber-propertize - "URL: " 'face 'jabber-chat-prompt-system) - (format "%s <%s>" desc url)))))) - foundp)) - -(defun jabber-chat-goto-address (xml-data who mode) - "Call `goto-address' on the newly written text. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (when (eq mode :insert) - (ignore-errors - (let ((end (point)) - (limit (max (- (point) 1000) (1+ (point-min))))) - ;; We only need to fontify the text written since the last - ;; prompt. The prompt has a field property, so we can find it - ;; using `field-beginning'. - (goto-address-fontify (field-beginning nil nil limit) end))))) - -(add-to-list 'jabber-jid-chat-menu - (cons "Compose message" 'jabber-compose)) - -(defun jabber-send-message (jc to subject body type) - "Send a message tag to the server. -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "to: ") - (jabber-read-with-input-method "subject: ") - (jabber-read-with-input-method "body: ") - (read-string "type: "))) - (jabber-send-sexp jc - `(message ((to . ,to) - ,(if (> (length type) 0) - `(type . ,type))) - ,(if (> (length subject) 0) - `(subject () ,subject)) - ,(if (> (length body) 0) - `(body () ,body)))) - (if (and jabber-history-enabled (not (string= type "groupchat"))) - (jabber-history-log-message "out" nil to body (current-time)))) - -(add-to-list 'jabber-jid-chat-menu - (cons "Start chat" 'jabber-chat-with)) - -(defun jabber-chat-with (jc jid &optional other-window) - "Open an empty chat window for chatting with JID. -With a prefix argument, open buffer in other window. -Returns the chat buffer. -JC is the Jabber connection." - (interactive (let* ((jid - (jabber-read-jid-completing "chat with:")) - (account - (jabber-read-account nil jid))) - (list - account jid current-prefix-arg))) - (let ((buffer (jabber-chat-create-buffer jc jid))) - (if other-window - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer)))) - -(defun jabber-chat-with-jid-at-point (&optional other-window) - "Start chat with JID at point. -Signal an error if there is no JID at point. -With a prefix argument, open buffer in other window." - (interactive "P") - (let ((jid-at-point (get-text-property (point) - 'jabber-jid)) - (account (get-text-property (point) - 'jabber-account))) - (if (and jid-at-point account) - (jabber-chat-with account jid-at-point other-window) - (error "No contact at point")))) - -(defvar jabber-presence-element-functions nil - "List of functions returning extra elements for stanzas. -Each function takes one argument, the connection, and returns a -possibly empty list of extra child element of the -stanza.") - -(defvar jabber-presence-history () - "Keeps track of previously used presence status types.") - -(add-to-list 'jabber-iq-set-xmlns-alist - (cons "jabber:iq:roster" (function (lambda (jc x) (jabber-process-roster jc x nil))))) -(defun jabber-process-roster (jc xml-data closure-data) - "Process an incoming roster infoquery result. -CLOSURE-DATA should be 'initial if initial roster push, nil otherwise. -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((roster (plist-get (fsm-get-state-data jc) :roster)) - (from (jabber-xml-get-attribute xml-data 'from)) - (type (jabber-xml-get-attribute xml-data 'type)) - (id (jabber-xml-get-attribute xml-data 'id)) - (username (plist-get (fsm-get-state-data jc) :username)) - (server (plist-get (fsm-get-state-data jc) :server)) - (resource (plist-get (fsm-get-state-data jc) :resource)) - new-items changed-items deleted-items) - ;; Perform sanity check on "from" attribute: it should be either absent - ;; match our own JID, or match the server's JID (the latter is what - ;; Facebook does). - (if (not (or (null from) - (string= from server) - (string= from (concat username "@" server)) - (string= from (concat username "@" server "/" resource)))) - (message "Roster push with invalid \"from\": \"%s\" (expected \"%s\", \"%s@%s\" or \"%s@%s/%s\")" - from - server username server username server resource) - - (dolist (item (jabber-xml-get-children (car (jabber-xml-get-children xml-data 'query)) 'item)) - (let (roster-item - (jid (jabber-jid-symbol (jabber-xml-get-attribute item 'jid)))) - - ;; If subscripton="remove", contact is to be removed from roster - (if (string= (jabber-xml-get-attribute item 'subscription) "remove") - (progn - (if (jabber-jid-rostername jid) - (message "%s (%s) removed from roster" (jabber-jid-rostername jid) jid) - (message "%s removed from roster" jid)) - (push jid deleted-items)) - - ;; Find contact if already in roster - (setq roster-item (car (memq jid roster))) - - (if roster-item - (push roster-item changed-items) - ;; If not found, create a new roster item. - (unless (eq closure-data 'initial) - (if (jabber-xml-get-attribute item 'name) - (message "%s (%s) added to roster" (jabber-xml-get-attribute item 'name) jid) - (message "%s added to roster" jid))) - (setq roster-item jid) - (push roster-item new-items)) - - ;; If this is an initial push, we want to forget - ;; everything we knew about this contact before - e.g. if - ;; the contact was online when we disconnected and offline - ;; when we reconnect, we don't want to see stale presence - ;; information. This assumes that no contacts are shared - ;; between accounts. - (when (eq closure-data 'initial) - (setplist roster-item nil)) - - ;; Now, get all data associated with the contact. - (put roster-item 'name (jabber-xml-get-attribute item 'name)) - (put roster-item 'subscription (jabber-xml-get-attribute item 'subscription)) - (put roster-item 'ask (jabber-xml-get-attribute item 'ask)) - - ;; Since roster items can't be changed incrementally, we - ;; save the original XML to be able to modify it, instead of - ;; having to reproduce it. This is for forwards - ;; compatibility. - (put roster-item 'xml item) - - (put roster-item 'groups - (mapcar (lambda (foo) (nth 2 foo)) - (jabber-xml-get-children item 'group))))))) - ;; This is the function that does the actual updating and - ;; redrawing of the roster. - (jabber-roster-update jc new-items changed-items deleted-items) - - (if (and id (string= type "set")) - (jabber-send-iq jc nil "result" nil - nil nil nil nil id))) - - ;; After initial roster push, run jabber-post-connect-hooks. We do - ;; it here and not before since we want to have the entire roster - ;; before we receive any presence stanzas. - (when (eq closure-data 'initial) - (run-hook-with-args 'jabber-post-connect-hooks jc))) - -(defun jabber-initial-roster-failure (jc xml-data _closure-data) - "Report the initial roster failure. -If the initial roster request fails, let's report it, but run -`jabber-post-connect-hooks' anyway. According to the spec, there -is nothing exceptional about the server not returning a roster. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (jabber-report-success jc xml-data "Initial roster retrieval") - (run-hook-with-args 'jabber-post-connect-hooks jc)) - -(add-to-list 'jabber-presence-chain 'jabber-process-presence) -(defun jabber-process-presence (jc xml-data) - "Process incoming presence tags. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - ;; XXX: use JC argument - (let ((roster (plist-get (fsm-get-state-data jc) :roster)) - (from (jabber-xml-get-attribute xml-data 'from)) - (to (jabber-xml-get-attribute xml-data 'to)) - (type (jabber-xml-get-attribute xml-data 'type)) - (presence-show (car (jabber-xml-node-children - (car (jabber-xml-get-children xml-data 'show))))) - (presence-status (car (jabber-xml-node-children - (car (jabber-xml-get-children xml-data 'status))))) - (error (car (jabber-xml-get-children xml-data 'error))) - (priority (string-to-number (or (car (jabber-xml-node-children (car (jabber-xml-get-children xml-data 'priority)))) - "0")))) - (cond - ((string= type "subscribe") - (run-with-idle-timer 0.01 nil #'jabber-process-subscription-request jc from presence-status)) - - ((jabber-muc-presence-p xml-data) - (jabber-muc-process-presence jc xml-data)) - - (t - ;; XXX: Think about what to do about out-of-roster presences. - (let ((buddy (jabber-jid-symbol from))) - (if (memq buddy roster) - (let* ((oldstatus (get buddy 'show)) - (resource (or (jabber-jid-resource from) "")) - (resource-plist (cdr (assoc resource - (get buddy 'resources)))) - newstatus) - (cond - ((and (string= resource "") (member type '("unavailable" "error"))) - ;; 'unavailable' or 'error' from bare JID means that all resources - ;; are offline. - (setq resource-plist nil) - (setq newstatus (if (string= type "error") "error" nil)) - (let ((new-message (if error - (jabber-parse-error error) - presence-status))) - ;; erase any previous information - (put buddy 'resources nil) - (put buddy 'connected nil) - (put buddy 'show newstatus) - (put buddy 'status new-message))) - - ((string= type "unavailable") - (setq resource-plist - (plist-put resource-plist 'connected nil)) - (setq resource-plist - (plist-put resource-plist 'show nil)) - (setq resource-plist - (plist-put resource-plist 'status - presence-status))) - - ((string= type "error") - (setq newstatus "error") - (setq resource-plist - (plist-put resource-plist 'connected nil)) - (setq resource-plist - (plist-put resource-plist 'show "error")) - (setq resource-plist - (plist-put resource-plist 'status - (if error - (jabber-parse-error error) - presence-status)))) - ((or - (string= type "unsubscribe") - (string= type "subscribed") - (string= type "unsubscribed")) - ;; Do nothing, except letting the user know. The Jabber protocol - ;; places all this complexity on the server. - (setq newstatus type)) - (t - (setq resource-plist - (plist-put resource-plist 'connected t)) - (setq resource-plist - (plist-put resource-plist 'show (or presence-show ""))) - (setq resource-plist - (plist-put resource-plist 'status - presence-status)) - (setq resource-plist - (plist-put resource-plist 'priority priority)) - (setq newstatus (or presence-show "")))) - - (when resource-plist - ;; this is for `assoc-set!' in guile - (if (assoc resource (get buddy 'resources)) - (setcdr (assoc resource (get buddy 'resources)) resource-plist) - (put buddy 'resources (cons (cons resource resource-plist) (get buddy 'resources)))) - (jabber-prioritize-resources buddy)) - - (fsm-send jc (cons :roster-update buddy)) - - (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) - (run-hook-with-args hook - buddy - oldstatus - newstatus - (plist-get resource-plist 'status) - (funcall jabber-alert-presence-message-function - buddy - oldstatus - newstatus - (plist-get resource-plist 'status))))))))))) - -(defun jabber-process-subscription-request (jc from presence-status) - "Process an incoming subscription request. -JC is the Jabber connection." - (with-current-buffer (jabber-chat-create-buffer jc from) - (ewoc-enter-last jabber-chat-ewoc (list :subscription-request presence-status :time (current-time))) - - (dolist (hook '(jabber-presence-hooks jabber-alert-presence-hooks)) - (run-hook-with-args hook (jabber-jid-symbol from) nil "subscribe" presence-status (funcall jabber-alert-presence-message-function (jabber-jid-symbol from) nil "subscribe" presence-status))))) - -(defun jabber-subscription-accept-mutual (&rest ignored) - (message "Subscription accepted; reciprocal subscription request sent") - (jabber-subscription-reply "subscribed" "subscribe")) - -(defun jabber-subscription-accept-one-way (&rest ignored) - (message "Subscription accepted") - (jabber-subscription-reply "subscribed")) - -(defun jabber-subscription-decline (&rest ignored) - (message "Subscription declined") - (jabber-subscription-reply "unsubscribed")) - -(defun jabber-subscription-reply (&rest types) - (let ((to (jabber-jid-user jabber-chatting-with))) - (dolist (type types) - (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,to) (type . ,type))))))) - -(defun jabber-prioritize-resources (buddy) - "Set connected, show and status properties for BUDDY. -Show status properties from highest-priority resource." - (let ((resource-alist (get buddy 'resources)) - (highest-priority nil)) - ;; Reset to nil at first, for cases (a) resource-alist is nil - ;; and (b) all resources are disconnected. - (put buddy 'connected nil) - (put buddy 'show nil) - (put buddy 'status nil) - (mapc #'(lambda (resource) - (let* ((resource-plist (cdr resource)) - (priority (plist-get resource-plist 'priority))) - (if (plist-get resource-plist 'connected) - (when (or (null highest-priority) - (and priority - (> priority highest-priority))) - ;; if no priority specified, interpret as zero - (setq highest-priority (or priority 0)) - (put buddy 'connected (plist-get resource-plist 'connected)) - (put buddy 'show (plist-get resource-plist 'show)) - (put buddy 'status (plist-get resource-plist 'status)) - (put buddy 'resource (car resource))) - - ;; if we have not found a connected resource yet, but this - ;; disconnected resource has a status message, display it. - (when (not (get buddy 'connected)) - (if (plist-get resource-plist 'status) - (put buddy 'status (plist-get resource-plist 'status))) - (if (plist-get resource-plist 'show) - (put buddy 'show (plist-get resource-plist 'show))))))) - resource-alist))) - -(defun jabber-count-connected-resources (buddy) - "Return the number of connected resources for BUDDY." - (let ((resource-alist (get buddy 'resources)) - (count 0)) - (dolist (resource resource-alist) - (if (plist-get (cdr resource) 'connected) - (setq count (1+ count)))) - count)) - -;;;###autoload -(defun jabber-send-presence (show status priority) - "Set presence for all accounts." - (interactive - (list - (completing-read "show: " '("" "away" "xa" "dnd" "chat") - nil t nil 'jabber-presence-history) - (jabber-read-with-input-method "status message: " *jabber-current-status* - '*jabber-status-history*) - (read-string "priority: " (int-to-string (if *jabber-current-priority* - *jabber-current-priority* - jabber-default-priority))))) - - (setq *jabber-current-show* show *jabber-current-status* status) - (setq *jabber-current-priority* - (if (numberp priority) priority (string-to-number priority))) - - (let (subelements-map) - ;; For each connection, we use a different set of subelements. We - ;; cache them, to only generate them once. - - ;; Ordinary presence, with no specified recipient - (dolist (jc jabber-connections) - (let ((subelements (jabber-presence-children jc))) - (push (cons jc subelements) subelements-map) - (jabber-send-sexp-if-connected jc `(presence () ,@subelements)))) - - ;; Then send presence to groupchats - (dolist (gc *jabber-active-groupchats*) - (let* ((buffer (get-buffer (jabber-muc-get-buffer (car gc)))) - (jc (when buffer - (buffer-local-value 'jabber-buffer-connection buffer))) - (subelements (cdr (assq jc subelements-map)))) - (when jc - (jabber-send-sexp-if-connected - jc `(presence ((to . ,(concat (car gc) "/" (cdr gc)))) - ,@subelements)))))) - - (jabber-display-roster)) - -(defun jabber-presence-children (jc) - "Return the children for a stanza. -JC is the Jabber connection." - `(,(when (> (length *jabber-current-status*) 0) - `(status () ,*jabber-current-status*)) - ,(when (> (length *jabber-current-show*) 0) - `(show () ,*jabber-current-show*)) - ,(when *jabber-current-priority* - `(priority () ,(number-to-string *jabber-current-priority*))) - ,@(apply 'append (mapcar (lambda (f) - (funcall f jc)) - jabber-presence-element-functions)))) - -(defun jabber-send-directed-presence (jc jid type) - "Send a directed presence stanza to JID. -TYPE is one of: -\"online\", \"away\", \"xa\", \"dnd\", \"chatty\": - Appear as present with the given status. -\"unavailable\": - Appear as offline. -\"probe\": - Ask the contact's server for updated presence. -\"subscribe\": - Ask for subscription to contact's presence. - (see also `jabber-send-subscription-request') -\"unsubscribe\": - Cancel your subscription to contact's presence. -\"subscribed\": - Accept contact's request for presence subscription. - (this is usually done within a chat buffer) -\"unsubscribed\": - Cancel contact's subscription to your presence. - -JC is the Jabber connection." - (interactive - (list (jabber-read-account) - (jabber-read-jid-completing "Send directed presence to: ") - (completing-read "Type (default is online): " - '(("online") - ("away") - ("xa") - ("dnd") - ("chatty") - ("probe") - ("unavailable") - ("subscribe") - ("unsubscribe") - ("subscribed") - ("unsubscribed")) - nil t nil 'jabber-presence-history "online"))) - (cond - ((member type '("probe" "unavailable" - "subscribe" "unsubscribe" - "subscribed" "unsubscribed")) - (jabber-send-sexp jc `(presence ((to . ,jid) - (type . ,type))))) - - (t - (let ((*jabber-current-show* - (if (string= type "online") - "" - type)) - (*jabber-current-status* nil)) - (jabber-send-sexp jc `(presence ((to . ,jid)) - ,@(jabber-presence-children jc))))))) - -(defun jabber-send-away-presence (&optional status) - "Set status to away. -With prefix argument, ask for status message." - (interactive - (list - (when current-prefix-arg - (jabber-read-with-input-method - "status message: " *jabber-current-status* '*jabber-status-history*)))) - (jabber-send-presence "away" (if status status *jabber-current-status*) - *jabber-current-priority*)) - -;; XXX code duplication! -(defun jabber-send-xa-presence (&optional status) - "Send extended away presence. -With prefix argument, ask for status message." - (interactive - (list - (when current-prefix-arg - (jabber-read-with-input-method - "status message: " *jabber-current-status* '*jabber-status-history*)))) - (jabber-send-presence "xa" (if status status *jabber-current-status*) - *jabber-current-priority*)) - -;;;###autoload -(defun jabber-send-default-presence (&optional ignore) - "Send default presence. -Default presence is specified by `jabber-default-show', -`jabber-default-status', and `jabber-default-priority'." - (interactive) - (jabber-send-presence - jabber-default-show jabber-default-status jabber-default-priority)) - -(defun jabber-send-current-presence (&optional ignore) - "(Re-)send current presence. -That is, if presence has already been sent, use current settings, -otherwise send defaults (see `jabber-send-default-presence')." - (interactive) - (if *jabber-current-show* - (jabber-send-presence *jabber-current-show* *jabber-current-status* - *jabber-current-priority*) - (jabber-send-default-presence))) - -(add-to-list 'jabber-jid-roster-menu (cons "Send subscription request" - 'jabber-send-subscription-request)) -(defun jabber-send-subscription-request (jc to &optional request) - "Send a subscription request to jid. -Show him your request text, if specified. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "to: ") - (jabber-read-with-input-method "request: "))) - (jabber-send-sexp jc - `(presence - ((to . ,to) - (type . "subscribe")) - ,@(when (and request (> (length request) 0)) - (list `(status () ,request)))))) - -(defvar jabber-roster-group-history nil - "History of entered roster groups.") - -(add-to-list 'jabber-jid-roster-menu - (cons "Add/modify roster entry" 'jabber-roster-change)) -(defun jabber-roster-change (jc jid name groups) - "Add or change a roster item. -JC is the Jabber connection." - (interactive (let* ((jid (jabber-jid-symbol - (jabber-read-jid-completing "Add/change JID: "))) - (account (jabber-read-account)) - (name (get jid 'name)) - (groups (get jid 'groups)) - (all-groups - (apply #'append - (mapcar - (lambda (j) (get j 'groups)) - (plist-get (fsm-get-state-data account) :roster))))) - (when (string< emacs-version "22") - ;; Older emacsen want the completion table to be an alist... - (setq all-groups (mapcar #'list all-groups))) - (list account - jid (jabber-read-with-input-method (format "Name: (default `%s') " name) nil nil name) - (delete "" - (completing-read-multiple - (format - "Groups, comma-separated: (default %s) " - (if groups - (mapconcat #'identity groups ",") - "none")) - all-groups - nil nil nil - 'jabber-roster-group-history - (mapconcat #'identity groups ",") - t))))) - ;; If new fields are added to the roster XML structure in a future standard, - ;; they will be clobbered by this function. - ;; XXX: specify account - (jabber-send-iq jc nil "set" - (list 'query (list (cons 'xmlns "jabber:iq:roster")) - (append - (list 'item (append - (list (cons 'jid (symbol-name jid))) - (if (and name (> (length name) 0)) - (list (cons 'name name))))) - (mapcar #'(lambda (x) `(group () ,x)) - groups))) - #'jabber-report-success "Roster item change" - #'jabber-report-success "Roster item change")) - -(add-to-list 'jabber-jid-roster-menu - (cons "Delete roster entry" 'jabber-roster-delete)) -(defun jabber-roster-delete (jc jid) - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Delete from roster: "))) - (jabber-send-iq jc nil "set" - `(query ((xmlns . "jabber:iq:roster")) - (item ((jid . ,jid) - (subscription . "remove")))) - #'jabber-report-success "Roster item removal" - #'jabber-report-success "Roster item removal")) - -(defun jabber-roster-delete-jid-at-point () - "Delete JID at point from roster. -Signal an error if there is no JID at point." - (interactive) - (let ((jid-at-point (get-text-property (point) - 'jabber-jid)) - (account (get-text-property (point) 'jabber-account))) - (if (and jid-at-point account - (or jabber-silent-mode (yes-or-no-p (format "Really delete %s from roster? " jid-at-point)))) - (jabber-roster-delete account jid-at-point) - (error "No contact at point")))) - -(defun jabber-roster-delete-group-from-jids (jc jids group) - "Delete group `group' from all JIDs. -JC is the Jabber connection." - (interactive) - (dolist (jid jids) - (jabber-roster-change - jc jid (get jid 'name) - (remove-if-not (lambda (g) (not (string= g group))) - (get jid 'groups))))) - -(defun jabber-roster-edit-group-from-jids (jc jids group) - "Edit group `group' from all JIDs. -JC is the Jabber connection." - (interactive) - (let ((new-group - (jabber-read-with-input-method - (format "New group: (default `%s') " group) nil nil group))) - (dolist (jid jids) - (jabber-roster-change - jc jid (get jid 'name) - (remove-duplicates - (mapcar - (lambda (g) (if (string= g group) - new-group - g)) - (get jid 'groups)) - :test 'string=))))) - -;;;###autoload -(eval-after-load "jabber-core" - '(add-to-list 'jabber-presence-chain #'jabber-process-caps)) - -(defvar jabber-caps-cache (make-hash-table :test 'equal)) - -(defconst jabber-caps-hash-names - (if (fboundp 'secure-hash) - '(("sha-1" . sha1) - ("sha-224" . sha224) - ("sha-256" . sha256) - ("sha-384" . sha384) - ("sha-512" . sha512)) - ;; `secure-hash' was introduced in Emacs 24. For Emacs 23, fall - ;; back to the `sha1' function, handled specially in - ;; `jabber-caps--secure-hash'. - '(("sha-1" . sha1))) - "Hash function name map. -Maps names defined in http://www.iana.org/assignments/hash-function-text-names -to symbols accepted by `secure-hash'. - -XEP-0115 currently recommends SHA-1, but let's be future-proof.") - -(defun jabber-caps-get-cached (jid) - "Get disco info from Entity Capabilities cache. -JID should be a string containing a full JID. -Return (IDENTITIES FEATURES), or nil if not in cache." - (let* ((symbol (jabber-jid-symbol jid)) - (resource (or (jabber-jid-resource jid) "")) - (resource-plist (cdr (assoc resource (get symbol 'resources)))) - (key (plist-get resource-plist 'caps))) - (when key - (let ((cache-entry (gethash key jabber-caps-cache))) - (when (and (consp cache-entry) (not (floatp (car cache-entry)))) - cache-entry))))) - -;;;###autoload -(defun jabber-process-caps (jc xml-data) - "Look for entity capabilities in presence stanzas. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (type (jabber-xml-get-attribute xml-data 'type)) - (c (jabber-xml-path xml-data '(("http://jabber.org/protocol/caps" . "c"))))) - (when (and (null type) c) - (jabber-xml-let-attributes - (ext hash node ver) c - (cond - (hash - ;; If the element has a hash attribute, it follows the - ;; "modern" version of XEP-0115. - (jabber-process-caps-modern jc from hash node ver)) - (t - ;; No hash attribute. Use legacy version of XEP-0115. - ;; TODO: do something clever here. - )))))) - -(defun jabber-process-caps-modern (jc jid hash node ver) - (when (assoc hash jabber-caps-hash-names) - ;; We support the hash function used. - (let* ((key (cons hash ver)) - (cache-entry (gethash key jabber-caps-cache))) - ;; Remember the hash in the JID symbol. - (let* ((symbol (jabber-jid-symbol jid)) - (resource (or (jabber-jid-resource jid) "")) - (resource-entry (assoc resource (get symbol 'resources))) - (new-resource-plist (plist-put (cdr resource-entry) 'caps key))) - (if resource-entry - (setf (cdr resource-entry) new-resource-plist) - (push (cons resource new-resource-plist) (get symbol 'resources)))) - - (flet ((request-disco-info - () - (jabber-send-iq - jc jid - "get" - `(query ((xmlns . "http://jabber.org/protocol/disco#info") - (node . ,(concat node "#" ver)))) - #'jabber-process-caps-info-result (list hash node ver) - #'jabber-process-caps-info-error (list hash node ver)))) - (cond - ((and (consp cache-entry) - (floatp (car cache-entry))) - ;; We have a record of asking someone about this hash. - (if (< (- (float-time) (car cache-entry)) 10.0) - ;; We asked someone about this hash less than 10 seconds ago. - ;; Let's add the new JID to the entry, just in case that - ;; doesn't work out. - (pushnew jid (cdr cache-entry) :test #'string=) - ;; We asked someone about it more than 10 seconds ago. - ;; They're probably not going to answer. Let's ask - ;; this contact about it instead. - (setf (car cache-entry) (float-time)) - (request-disco-info))) - ((null cache-entry) - ;; We know nothing about this hash. Let's note the - ;; fact that we tried to get information about it. - (puthash key (list (float-time)) jabber-caps-cache) - (request-disco-info)) - (t - ;; We already know what this hash represents, so we - ;; can cache info for this contact. - (puthash (cons jid nil) cache-entry jabber-disco-info-cache))))))) - -(defun jabber-process-caps-info-result (jc xml-data closure-data) - (destructuring-bind (hash node ver) closure-data - (let* ((key (cons hash ver)) - (query (jabber-iq-query xml-data)) - (verification-string (jabber-caps-ver-string query hash))) - (if (string= ver verification-string) - ;; The hash is correct; save info. - (puthash key (jabber-disco-parse-info xml-data) jabber-caps-cache) - ;; The hash is incorrect. - (jabber-caps-try-next jc hash node ver))))) - -(defun jabber-process-caps-info-error (jc xml-data closure-data) - (destructuring-bind (hash node ver) closure-data - (jabber-caps-try-next jc hash node ver))) - -(defun jabber-caps-try-next (jc hash node ver) - (let* ((key (cons hash ver)) - (cache-entry (gethash key jabber-caps-cache))) - (when (floatp (car-safe cache-entry)) - (let ((next-jid (pop (cdr cache-entry)))) - ;; Do we know someone else we could ask about this hash? - (if next-jid - (progn - (setf (car cache-entry) (float-time)) - (jabber-send-iq - jc next-jid - "get" - `(query ((xmlns . "http://jabber.org/protocol/disco#info") - (node . ,(concat node "#" ver)))) - #'jabber-process-caps-info-result (list hash node ver) - #'jabber-process-caps-info-error (list hash node ver))) - ;; No, forget about it for now. - (remhash key jabber-caps-cache)))))) - -(defun jabber-caps-ver-string (query hash) - ;; XEP-0115, section 5.1 - ;; 1. Initialize an empty string S. - (with-temp-buffer - (let* ((identities (jabber-xml-get-children query 'identity)) - (disco-features (mapcar (lambda (f) (jabber-xml-get-attribute f 'var)) - (jabber-xml-get-children query 'feature))) - (maybe-forms (jabber-xml-get-children query 'x)) - (forms (remove-if-not - (lambda (x) - ;; Keep elements that are forms and have a FORM_TYPE, - ;; according to XEP-0128. - (and (string= (jabber-xml-get-xmlns x) "jabber:x:data") - (jabber-xdata-formtype x))) - maybe-forms))) - ;; 2. Sort the service discovery identities [15] by category - ;; and then by type and then by xml:lang (if it exists), - ;; formatted as CATEGORY '/' [TYPE] '/' [LANG] '/' - ;; [NAME]. [16] Note that each slash is included even if the - ;; LANG or NAME is not included (in accordance with XEP-0030, - ;; the category and type MUST be included. - (setq identities (sort identities #'jabber-caps-identity-<)) - ;; 3. For each identity, append the 'category/type/lang/name' to - ;; S, followed by the '<' character. - (dolist (identity identities) - (jabber-xml-let-attributes (category type xml:lang name) identity - ;; Use `concat' here instead of passing everything to - ;; `insert', since `concat' tolerates nil values. - (insert (concat category "/" type "/" xml:lang "/" name "<")))) - ;; 4. Sort the supported service discovery features. [17] - (setq disco-features (sort disco-features #'string<)) - ;; 5. For each feature, append the feature to S, followed by the - ;; '<' character. - (dolist (f disco-features) - (insert f "<")) - ;; 6. If the service discovery information response includes - ;; XEP-0128 data forms, sort the forms by the FORM_TYPE (i.e., - ;; by the XML character data of the element). - (setq forms (sort forms (lambda (a b) - (string< (jabber-xdata-formtype a) - (jabber-xdata-formtype b))))) - ;; 7. For each extended service discovery information form: - (dolist (form forms) - ;; Append the XML character data of the FORM_TYPE field's - ;; element, followed by the '<' character. - (insert (jabber-xdata-formtype form) "<") - ;; Sort the fields by the value of the "var" attribute. - (let ((fields (sort (jabber-xml-get-children form 'field) - (lambda (a b) - (string< (jabber-xml-get-attribute a 'var) - (jabber-xml-get-attribute b 'var)))))) - (dolist (field fields) - ;; For each field other than FORM_TYPE: - (unless (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") - ;; Append the value of the "var" attribute, followed by the '<' character. - (insert (jabber-xml-get-attribute field 'var) "<") - ;; Sort values by the XML character data of the element. - (let ((values (sort (mapcar (lambda (value) - (car (jabber-xml-node-children value))) - (jabber-xml-get-children field 'value)) - #'string<))) - ;; For each element, append the XML character - ;; data, followed by the '<' character. - (dolist (value values) - (insert value "<")))))))) - - ;; 8. Ensure that S is encoded according to the UTF-8 encoding - ;; (RFC 3269 [18]). - (let ((s (encode-coding-string (buffer-string) 'utf-8 t)) - (algorithm (cdr (assoc hash jabber-caps-hash-names)))) - ;; 9. Compute the verification string by hashing S using the - ;; algorithm specified in the 'hash' attribute (e.g., SHA-1 as - ;; defined in RFC 3174 [19]). The hashed data MUST be generated - ;; with binary output and encoded using Base64 as specified in - ;; Section 4 of RFC 4648 [20] (note: the Base64 output MUST NOT - ;; include whitespace and MUST set padding bits to zero). [21] - (base64-encode-string (jabber-caps--secure-hash algorithm s) t)))) - -(defun jabber-caps--secure-hash (algorithm string) - (cond - ;; `secure-hash' was introduced in Emacs 24 - ((fboundp 'secure-hash) - (secure-hash algorithm string nil nil t)) - ((eq algorithm 'sha1) - ;; For SHA-1, we can use the `sha1' function. - (sha1 string nil nil t)) - (t - (error "Cannot use hash algorithm %s!" algorithm)))) - -(defun jabber-caps-identity-< (a b) - (let ((a-category (jabber-xml-get-attribute a 'category)) - (b-category (jabber-xml-get-attribute b 'category))) - (or (string< a-category b-category) - (and (string= a-category b-category) - (let ((a-type (jabber-xml-get-attribute a 'type)) - (b-type (jabber-xml-get-attribute b 'type))) - (or (string< a-type b-type) - (and (string= a-type b-type) - (let ((a-xml:lang (jabber-xml-get-attribute a 'xml:lang)) - (b-xml:lang (jabber-xml-get-attribute b 'xml:lang))) - (string< a-xml:lang b-xml:lang))))))))) - -(defvar jabber-caps-default-hash-function "sha-1" - "Hash function to use when sending caps in presence stanzas. -The value should be a key in `jabber-caps-hash-names'.") - -(defvar jabber-caps-current-hash nil - "The current disco hash we're sending out in presence stanzas.") - -(defconst jabber-caps-node "http://emacs-jabber.sourceforge.net") - -;;;###autoload -(defun jabber-disco-advertise-feature (feature) - (unless (member feature jabber-advertised-features) - (push feature jabber-advertised-features) - (when jabber-caps-current-hash - (jabber-caps-recalculate-hash) - ;; If we're already connected, we need to send updated presence - ;; for the new feature. - (mapc #'jabber-send-current-presence jabber-connections)))) - -(defun jabber-caps-recalculate-hash () - "Update `jabber-caps-current-hash' for feature list change. -Also update `jabber-disco-info-nodes', so we return results for -the right node." - (let* ((old-hash jabber-caps-current-hash) - (old-node (and old-hash (concat jabber-caps-node "#" old-hash))) - (new-hash - (jabber-caps-ver-string `(query () ,@(jabber-disco-return-client-info)) - jabber-caps-default-hash-function)) - (new-node (concat jabber-caps-node "#" new-hash))) - (when old-node - (let ((old-entry (assoc old-node jabber-disco-info-nodes))) - (when old-entry - (setq jabber-disco-info-nodes (delq old-entry jabber-disco-info-nodes))))) - (push (list new-node #'jabber-disco-return-client-info nil) - jabber-disco-info-nodes) - (setq jabber-caps-current-hash new-hash))) - -;;;###autoload -(defun jabber-caps-presence-element (_jc) - (unless jabber-caps-current-hash - (jabber-caps-recalculate-hash)) - - (list - `(c ((xmlns . "http://jabber.org/protocol/caps") - (hash . ,jabber-caps-default-hash-function) - (node . ,jabber-caps-node) - (ver . ,jabber-caps-current-hash))))) - -;;;###autoload -(eval-after-load "jabber-presence" - '(add-to-list 'jabber-presence-element-functions #'jabber-caps-presence-element)) - -(defvar jabber-advertised-features - (list "http://jabber.org/protocol/disco#info") - "Features advertised on service discovery requests. - -Don't add your feature to this list directly. Instead, call -`jabber-disco-advertise-feature'.") - -(defvar jabber-disco-items-nodes - (list - (list "" nil nil)) - "Alist of node names and information about returning disco item data. -Key is node name as a string, or \"\" for no node specified. Value is -a list of two items. - -First item is data to return. If it is a function, that function is -called and its return value is used; if it is a list, that list is -used. The list should be the XML data to be returned inside the - element, like this: - -\((item ((name . \"Name of first item\") - (jid . \"first.item\") - (node . \"node\")))) - -Second item is access control function. That function is passed the -JID, and returns non-nil if access is granted. If the second item is -nil, access is always granted.") - -(defvar jabber-disco-info-nodes - (list - (list "" #'jabber-disco-return-client-info nil)) - "Alist of node names and information returning disco info data. -Key is node name as a string, or \"\" for no node specified. Value is -a list of two items. - -First item is data to return. If it is a function, that function is -called and its return value is used; if it is a list, that list is -used. The list should be the XML data to be returned inside the - element, like this: - -\((identity ((category . \"client\") - (type . \"pc\") - (name . \"Jabber client\"))) - (feature ((var . \"some-feature\")))) - -Second item is access control function. That function is passed the -JID, and returns non-nil if access is granted. If the second item is -nil, access is always granted.") - -(add-to-list 'jabber-iq-get-xmlns-alist - (cons "http://jabber.org/protocol/disco#info" 'jabber-return-disco-info)) -(add-to-list 'jabber-iq-get-xmlns-alist - (cons "http://jabber.org/protocol/disco#items" 'jabber-return-disco-info)) -(defun jabber-return-disco-info (jc xml-data) - "Respond to a service discovery request. -See XEP-0030. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id)) - (xmlns (jabber-iq-xmlns xml-data)) - (which-alist (eval (cdr (assoc xmlns - (list - (cons "http://jabber.org/protocol/disco#info" 'jabber-disco-info-nodes) - (cons "http://jabber.org/protocol/disco#items" 'jabber-disco-items-nodes)))))) - (node (or - (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node) - "")) - (return-list (cdr (assoc node which-alist))) - (func (nth 0 return-list)) - (access-control (nth 1 return-list))) - (if return-list - (if (and (functionp access-control) - (not (funcall access-control jc to))) - (jabber-signal-error "Cancel" 'not-allowed) - ;; Access control passed - (let ((result (if (functionp func) - (funcall func jc xml-data) - func))) - (jabber-send-iq jc to "result" - `(query ((xmlns . ,xmlns) - ,@(when node - (list (cons 'node node)))) - ,@result) - nil nil nil nil id))) - - ;; No such node - (jabber-signal-error "Cancel" 'item-not-found)))) - -(defun jabber-disco-return-client-info (&optional jc xml-data) - `( - ;; If running under a window system, this is - ;; a GUI client. If not, it is a console client. - (identity ((category . "client") - (name . "Emacs Jabber client") - (type . ,(if (memq window-system - '(x w32 mac ns)) - "pc" - "console")))) - ,@(mapcar - #'(lambda (featurename) - `(feature ((var . ,featurename)))) - jabber-advertised-features))) - -(add-to-list 'jabber-jid-info-menu - (cons "Send items disco query" 'jabber-get-disco-items)) -(defun jabber-get-disco-items (jc to &optional node) - "Send a service discovery request for items. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Send items disco request to: " nil nil nil 'full t) - (jabber-read-node "Node (or leave empty): "))) - (jabber-send-iq jc to - "get" - (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#items")) - (if (> (length node) 0) - (list (cons 'node node))))) - #'jabber-process-data #'jabber-process-disco-items - #'jabber-process-data "Item discovery failed")) - -(add-to-list 'jabber-jid-info-menu - (cons "Send info disco query" 'jabber-get-disco-info)) -(defun jabber-get-disco-info (jc to &optional node) - "Send a service discovery request for info. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Send info disco request to: " nil nil nil 'full t) - (jabber-read-node "Node (or leave empty): "))) - (jabber-send-iq jc to - "get" - (list 'query (append (list (cons 'xmlns "http://jabber.org/protocol/disco#info")) - (if (> (length node) 0) - (list (cons 'node node))))) - #'jabber-process-data #'jabber-process-disco-info - #'jabber-process-data "Info discovery failed")) - -(defun jabber-process-disco-info (jc xml-data) - "Handle results from info disco requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let ((beginning (point))) - (dolist (x (jabber-xml-node-children (jabber-iq-query xml-data))) - (cond - ((eq (jabber-xml-node-name x) 'identity) - (let ((name (jabber-xml-get-attribute x 'name)) - (category (jabber-xml-get-attribute x 'category)) - (type (jabber-xml-get-attribute x 'type))) - (insert (jabber-propertize (if name - name - "Unnamed") - 'face 'jabber-title-medium) - "\n\nCategory:\t" category "\n") - (if type - (insert "Type:\t\t" type "\n")) - (insert "\n"))) - ((eq (jabber-xml-node-name x) 'feature) - (let ((var (jabber-xml-get-attribute x 'var))) - (insert "Feature:\t" var "\n"))))) - (put-text-property beginning (point) - 'jabber-jid (jabber-xml-get-attribute xml-data 'from)) - (put-text-property beginning (point) - 'jabber-account jc))) - -(defun jabber-process-disco-items (jc xml-data) - "Handle results from items disco requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let ((items (jabber-xml-get-children (jabber-iq-query xml-data) 'item))) - (if items - (dolist (item items) - (let ((jid (jabber-xml-get-attribute item 'jid)) - (name (jabber-xml-get-attribute item 'name)) - (node (jabber-xml-get-attribute item 'node))) - (insert - (jabber-propertize - (concat - (jabber-propertize - (concat jid "\n" (if node (format "Node: %s\n" node))) - 'face 'jabber-title-medium) - name "\n\n") - 'jabber-jid jid - 'jabber-account jc - 'jabber-node node)))) - (insert "No items found.\n")))) -;; Keys are ("jid" . "node"), where "node" is nil if appropriate. -;; Values are (identities features), where each identity is ["name" -;; "category" "type"], and each feature is a string. -(defvar jabber-disco-info-cache (make-hash-table :test 'equal)) - -;; Keys are ("jid" . "node"). Values are (items), where each -;; item is ["name" "jid" "node"] (some values may be nil). -(defvar jabber-disco-items-cache (make-hash-table :test 'equal)) - -(defun jabber-disco-get-info (jc jid node callback closure-data &optional force) - "Get disco info for JID and NODE, using connection JC. -Call CALLBACK with JC and CLOSURE-DATA as first and second -arguments and result as third argument when result is available. -On success, result is (IDENTITIES FEATURES), where each identity is [\"name\" -\"category\" \"type\"], and each feature is a string. -On error, result is the error node, recognizable by (eq (car result) 'error). - -If CALLBACK is nil, just fetch data. If FORCE is non-nil, -invalidate cache and get fresh data." - (when force - (remhash (cons jid node) jabber-disco-info-cache)) - (let ((result (unless force (jabber-disco-get-info-immediately jid node)))) - (if result - (and callback (run-with-timer 0 nil callback jc closure-data result)) - (jabber-send-iq jc jid - "get" - `(query ((xmlns . "http://jabber.org/protocol/disco#info") - ,@(when node `((node . ,node))))) - #'jabber-disco-got-info (cons callback closure-data) - (lambda (jc xml-data callback-data) - (when (car callback-data) - (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) - (cons callback closure-data))))) - -(defun jabber-disco-got-info (jc xml-data callback-data) - (let ((jid (jabber-xml-get-attribute xml-data 'from)) - (node (jabber-xml-get-attribute (jabber-iq-query xml-data) - 'node)) - (result (jabber-disco-parse-info xml-data))) - (puthash (cons jid node) result jabber-disco-info-cache) - (when (car callback-data) - (funcall (car callback-data) jc (cdr callback-data) result)))) - -(defun jabber-disco-parse-info (xml-data) - "Extract data from an stanza containing a disco#info result. -See `jabber-disco-get-info' for a description of the return value. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (list - (mapcar - #'(lambda (id) - (vector (jabber-xml-get-attribute id 'name) - (jabber-xml-get-attribute id 'category) - (jabber-xml-get-attribute id 'type))) - (jabber-xml-get-children (jabber-iq-query xml-data) 'identity)) - (mapcar - #'(lambda (feature) - (jabber-xml-get-attribute feature 'var)) - (jabber-xml-get-children (jabber-iq-query xml-data) 'feature)))) - -(defun jabber-disco-get-info-immediately (jid node) - "Get cached disco info for JID and NODE. -Return nil if no info available. - -Fill the cache with `jabber-disco-get-info'." - (or - ;; Check "normal" cache... - (gethash (cons jid node) jabber-disco-info-cache) - ;; And then check Entity Capabilities. - (and (null node) (jabber-caps-get-cached jid)))) - -(defun jabber-disco-get-items (jc jid node callback closure-data &optional force) - "Get disco items for JID and NODE, using connection JC. -Call CALLBACK with JC and CLOSURE-DATA as first and second -arguments and items result as third argument when result is -available. -On success, result is a list of items, where each -item is [\"name\" \"jid\" \"node\"] (some values may be nil). -On error, result is the error node, recognizable by (eq (car result) 'error). - -If CALLBACK is nil, just fetch data. If FORCE is non-nil, -invalidate cache and get fresh data." - (when force - (remhash (cons jid node) jabber-disco-items-cache)) - (let ((result (gethash (cons jid node) jabber-disco-items-cache))) - (if result - (and callback (run-with-timer 0 nil callback jc closure-data result)) - (jabber-send-iq jc jid - "get" - `(query ((xmlns . "http://jabber.org/protocol/disco#items") - ,@(when node `((node . ,node))))) - #'jabber-disco-got-items (cons callback closure-data) - (lambda (jc xml-data callback-data) - (when (car callback-data) - (funcall (car callback-data) jc (cdr callback-data) (jabber-iq-error xml-data)))) - (cons callback closure-data))))) - -(defun jabber-disco-got-items (jc xml-data callback-data) - (let ((jid (jabber-xml-get-attribute xml-data 'from)) - (node (jabber-xml-get-attribute (jabber-iq-query xml-data) - 'node)) - (result - (mapcar - #'(lambda (item) - (vector - (jabber-xml-get-attribute item 'name) - (jabber-xml-get-attribute item 'jid) - (jabber-xml-get-attribute item 'node))) - (jabber-xml-get-children (jabber-iq-query xml-data) 'item)))) - (puthash (cons jid node) result jabber-disco-items-cache) - (when (car callback-data) - (funcall (car callback-data) jc (cdr callback-data) result)))) - -(defun jabber-disco-get-items-immediately (jid node) - (gethash (cons jid node) jabber-disco-items-cache)) - -(defun jabber-disco-publish (jc node item-name item-jid item-node) - "Publish the given item under disco node NODE." - (jabber-send-iq jc nil - "set" - `(query ((xmlns . "http://jabber.org/protocol/disco#items") - ,@(when node `((node . ,node)))) - (item ((action . "update") - (jid . ,item-jid) - ,@(when item-name - `((name . ,item-name))) - ,@(when item-node - `((node . ,item-node)))))) - 'jabber-report-success "Disco publish" - 'jabber-report-success "Disco publish")) - -(defun jabber-disco-publish-remove (jc node item-jid item-node) - "Remove the given item from published disco items. - -JC is the Jabber connection." - (jabber-send-iq jc nil - "set" - `(query ((xmlns . "http://jabber.org/protocol/disco#items") - ,@(when node `((node . ,node)))) - (item ((action . "remove") - (jid . ,item-jid) - ,@(when item-node - `((node . ,item-node)))))) - 'jabber-report-success "Disco removal" - 'jabber-report-success "Disco removal")) - -(add-to-list 'jabber-jid-info-menu (cons "Ping" 'jabber-ping)) - -(defun jabber-ping-send (jc to process-func on-success on-error) - "Send XEP-0199 ping IQ stanza. -JC is connection to use, TO is full JID, PROCESS-FUNC is fucntion to call to -process result, ON-SUCCESS and ON-ERROR is arg for this function depending on -result." - (jabber-send-iq jc to "get" - '(ping ((xmlns . "urn:xmpp:ping"))) - process-func on-success - process-func on-error)) - -(defun jabber-ping (to) - "Ping XMPP entity. -TO is full JID. All connected JIDs is used." - (interactive (list (jabber-read-jid-completing "Send ping to: " nil nil nil 'full))) - (dolist (jc jabber-connections) - (jabber-ping-send jc to 'jabber-silent-process-data 'jabber-process-ping "Ping is unsupported"))) - -;; called by jabber-process-data -(defun jabber-process-ping (jc xml-data) - "Handle results from ping requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((to (jabber-xml-get-attribute xml-data 'from))) - (format "%s is alive" to))) - -(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:ping" 'jabber-pong)) -(jabber-disco-advertise-feature "urn:xmpp:ping") - -(defun jabber-pong (jc xml-data) - "Return pong as defined in XEP-0199. -Sender and Id are determined from the incoming packet passed in XML-DATA. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id))) - (jabber-send-iq jc to "result" nil nil nil nil nil id))) - -;;;###autoload -(defgroup jabber-keepalive nil - "Keepalive functions try to detect lost connection" - :group 'jabber) - -(defcustom jabber-keepalive-interval 600 - "Interval in seconds between connection checks." - :type 'integer - :group 'jabber-keepalive) - -(defcustom jabber-keepalive-timeout 20 - "Seconds to wait for response from server." - :type 'integer - :group 'jabber-keepalive) - -(defvar jabber-keepalive-timer nil - "Timer object for keepalive function.") - -(defvar jabber-keepalive-timeout-timer nil - "Timer object for keepalive timeout function.") - -(defvar jabber-keepalive-pending nil - "List of outstanding keepalive connections.") - -(defvar jabber-keepalive-debug nil - "Log keepalive traffic when non-nil.") - -;;;###autoload -(defun jabber-keepalive-start (&optional jc) - "Activate keepalive. -That is, regularly send a ping request to the server, and -disconnect it if it doesn't answer. See variable `jabber-keepalive-interval' -and variable `jabber-keepalive-timeout'. - -The JC argument makes it possible to add this function to -`jabber-post-connect-hooks'; it is ignored. Keepalive is activated -for all accounts regardless of the argument." - (interactive) - - (when jabber-keepalive-timer - (jabber-keepalive-stop)) - - (setq jabber-keepalive-timer - (run-with-timer 5 - jabber-keepalive-interval - 'jabber-keepalive-do)) - (add-hook 'jabber-post-disconnect-hook 'jabber-keepalive-stop)) - -(defun jabber-keepalive-stop () - "Deactivate keepalive." - (interactive) - - (when jabber-keepalive-timer - (jabber-cancel-timer jabber-keepalive-timer) - (setq jabber-keepalive-timer nil))) - -(defun jabber-keepalive-do () - (when jabber-keepalive-debug - (message "%s: sending keepalive packet(s)" (current-time-string))) - (setq jabber-keepalive-timeout-timer - (run-with-timer jabber-keepalive-timeout - nil - 'jabber-keepalive-timeout)) - (setq jabber-keepalive-pending jabber-connections) - (dolist (c jabber-connections) - ;; Whether we get an error or not is not interesting. - ;; Getting a response at all is. - (jabber-ping-send c nil 'jabber-keepalive-got-response nil nil))) - -(defun jabber-keepalive-got-response (jc &rest args) - (when jabber-keepalive-debug - (message "%s: got keepalive response from %s" - (current-time-string) - (plist-get (fsm-get-state-data jc) :server))) - (setq jabber-keepalive-pending (remq jc jabber-keepalive-pending)) - (when (and (null jabber-keepalive-pending) (timerp jabber-keepalive-timeout-timer)) - (jabber-cancel-timer jabber-keepalive-timeout-timer) - (setq jabber-keepalive-timeout-timer nil))) - -(defun jabber-keepalive-timeout () - (jabber-cancel-timer jabber-keepalive-timer) - (setq jabber-keepalive-timer nil) - - (dolist (c jabber-keepalive-pending) - (message "%s: keepalive timeout, connection to %s considered lost" - (current-time-string) - (plist-get (fsm-get-state-data c) :server)) - - (run-hook-with-args 'jabber-lost-connection-hooks c) - (jabber-disconnect-one c nil))) - -(defcustom jabber-whitespace-ping-interval 30 - "Send a space character to the server with this interval, in seconds. - -This is a traditional remedy for a number of problems: to keep NAT -boxes from considering the connection dead, to have the OS discover -earlier that the connection is lost, and to placate servers which rely -on the client doing this, e.g. Openfire. - -If you want to verify that the server is able to answer, see -`jabber-keepalive-start' for another mechanism." - :type '(integer :tag "Interval in seconds") - :group 'jabber-core) - -(defvar jabber-whitespace-ping-timer nil - "Timer object for whitespace pings.") - -;;;###autoload -(defun jabber-whitespace-ping-start (&optional jc) - "Start sending whitespace pings at regular intervals. -See `jabber-whitespace-ping-interval'. - -The JC argument is ignored; whitespace pings are enabled for all -accounts." - (interactive) - - (when jabber-whitespace-ping-timer - (jabber-whitespace-ping-stop)) - - (setq jabber-whitespace-ping-timer - (run-with-timer 5 - jabber-whitespace-ping-interval - 'jabber-whitespace-ping-do)) - (add-hook 'jabber-post-disconnect-hook 'jabber-whitespace-ping-stop)) - -(defun jabber-whitespace-ping-stop () - "Deactivate whitespace pings." - (interactive) - - (when jabber-whitespace-ping-timer - (jabber-cancel-timer jabber-whitespace-ping-timer) - (setq jabber-whitespace-ping-timer nil))) - -(defun jabber-whitespace-ping-do () - (dolist (c jabber-connections) - (ignore-errors (jabber-send-string c " ")))) - -(require 'cl) - -(jabber-disco-advertise-feature "http://jabber.org/protocol/feature-neg") - -(defun jabber-fn-parse (xml-data type) - "Parse a Feature Negotiation request, return alist representation. -XML-DATA should have one child element, , in the jabber:x:data -namespace. - -TYPE is either 'request or 'response. - -Returned alist has field name as key, and value is a list of offered -alternatives." - (let ((x (car (jabber-xml-get-children xml-data 'x)))) - (unless (and x - (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data")) - (jabber-signal-error "Modify" 'bad-request "Malformed Feature Negotiation")) - - (let (alist - (fields (jabber-xml-get-children x 'field))) - (dolist (field fields) - (let ((var (jabber-xml-get-attribute field 'var)) - (value (car (jabber-xml-get-children field 'value))) - (options (jabber-xml-get-children field 'option))) - (setq alist (cons - (cons var - (cond - ((eq type 'request) - (mapcar #'(lambda (option) - (car (jabber-xml-node-children - (car (jabber-xml-get-children - option 'value))))) - options)) - ((eq type 'response) - (jabber-xml-node-children value)) - (t - (error "Incorrect Feature Negotiation type: %s" type)))) - alist)))) - ;; return alist - alist))) - -(defun jabber-fn-encode (alist type) - "Transform a feature alist into an node int the jabber:x:data namespace. -Note that this is not the reverse of `jabber-fn-parse'. - -TYPE is either 'request or 'response." - (let ((requestp (eq type 'request))) - `(x ((xmlns . "jabber:x:data") - (type . ,(if requestp "form" "submit"))) - ,@(mapcar #'(lambda (field) - `(field - ((type . "list-single") - (var . ,(car field))) - ,@(if requestp - (mapcar - #'(lambda (option) - `(option nil (value nil ,option))) - (cdr field)) - (list `(value nil ,(cadr field)))))) - alist)))) - -(defun jabber-fn-intersection (mine theirs) - "Find values acceptable to both parties. - -MINE and THEIRS are alists, as returned by `jabber-fn-parse'. - -An alist is returned, where the keys are the negotiated variables, -and the values are lists containing the preferred option. If -negotiation is impossible, an error is signalled. The errors are as -specified in XEP-0020, and not necessarily the ones of higher-level -protocols." - - (let ((vars (mapcar #'car mine)) - (their-vars (mapcar #'car theirs))) - - ;; are the same variables being negotiated? - (sort vars 'string-lessp) - (sort their-vars 'string-lessp) - (let ((mine-but-not-theirs (set-difference vars their-vars :test 'string=)) - (theirs-but-not-mine (set-difference their-vars vars :test 'string=))) - (when mine-but-not-theirs - (jabber-signal-error "Modify" 'not-acceptable (car mine-but-not-theirs))) - (when theirs-but-not-mine - (jabber-signal-error "Cancel" 'feature-not-implemented (car theirs-but-not-mine)))) - - (let (alist) - (dolist (var vars) - (let ((my-options (cdr (assoc var mine))) - (their-options (cdr (assoc var theirs)))) - (let ((common-options (intersection my-options their-options :test 'string=))) - (if common-options - ;; we have a match; but which one to use? - ;; the first one will probably work - (setq alist - (cons (list var (car common-options)) - alist)) - ;; no match - (jabber-signal-error "Modify" 'not-acceptable var))))) - alist))) - -(require 'widget) -(require 'wid-edit) - -(defvar jabber-widget-alist nil - "Alist of widgets currently used.") - -(defvar jabber-form-type nil - "Type of form. -One of: -'x-data, jabber:x:data -'register, as used in jabber:iq:register and jabber:iq:search.") - -(defvar jabber-submit-to nil - "JID of the entity to which form data is to be sent.") - -(jabber-disco-advertise-feature "jabber:x:data") - -(define-widget 'jid 'string - "JID widget." - :value-to-internal (lambda (widget value) - (let ((displayname (jabber-jid-rostername value))) - (if displayname - (format "%s <%s>" displayname value) - value))) - :value-to-external (lambda (widget value) - (if (string-match "<\\([^>]+\\)>[ \t]*$" value) - (match-string 1 value) - value)) - :complete-function 'jid-complete) - -(defun jid-complete () - "Perform completion on JID preceding point." - (interactive) - ;; mostly stolen from widget-color-complete - (let* ((prefix (buffer-substring-no-properties (widget-field-start widget) - (point))) - (list (append (mapcar #'symbol-name *jabber-roster*) - (delq nil - (mapcar #'(lambda (item) - (when (jabber-jid-rostername item) - (format "%s <%s>" (jabber-jid-rostername item) - (symbol-name item)))) - *jabber-roster*)))) - (completion (try-completion prefix list))) - (cond ((eq completion t) - (message "Exact match.")) - ((null completion) - (error "Can't find completion for \"%s\"" prefix)) - ((not (string-equal prefix completion)) - (insert-and-inherit (substring completion (length prefix)))) - (t - (message "Making completion list...") - (with-output-to-temp-buffer "*Completions*" - (display-completion-list (all-completions prefix list nil) - prefix)) - (message "Making completion list...done"))))) - -(defun jabber-init-widget-buffer (submit-to) - "Setup buffer-local variables for widgets." - (make-local-variable 'jabber-widget-alist) - (make-local-variable 'jabber-submit-to) - (setq jabber-widget-alist nil) - (setq jabber-submit-to submit-to) - (setq buffer-read-only nil) - ;; XXX: This is because data from other queries would otherwise be - ;; appended to this buffer, which would fail since widget buffers - ;; are read-only... or something like that. Maybe there's a - ;; better way. - (rename-uniquely)) - -(defun jabber-render-register-form (query &optional default-username) - "Display widgets from element in IQ register or search namespace. -Display widgets from element in jabber:iq:{register,search} namespace. -DEFAULT-USERNAME is the default value for the username field." - (make-local-variable 'jabber-widget-alist) - (setq jabber-widget-alist nil) - (make-local-variable 'jabber-form-type) - (setq jabber-form-type 'register) - - (if (jabber-xml-get-children query 'instructions) - (widget-insert "Instructions: " (car (jabber-xml-node-children (car (jabber-xml-get-children query 'instructions)))) "\n")) - (if (jabber-xml-get-children query 'registered) - (widget-insert "You are already registered. You can change your details here.\n")) - (widget-insert "\n") - - (let ((possible-fields - ;; taken from XEP-0077 - '((username . "Username") - (nick . "Nickname") - (password . "Password") - (name . "Full name") - (first . "First name") - (last . "Last name") - (email . "E-mail") - (address . "Address") - (city . "City") - (state . "State") - (zip . "Zip") - (phone . "Telephone") - (url . "Web page") - (date . "Birth date")))) - (dolist (field (jabber-xml-node-children query)) - (let ((entry (assq (jabber-xml-node-name field) possible-fields))) - (when entry - (widget-insert (cdr entry) "\t") - ;; Special case: when registering a new account, the default - ;; username is the one specified in jabber-username. Things - ;; will break if the user changes that name, though... - (let ((default-value (or (when (eq (jabber-xml-node-name field) 'username) - default-username) - ""))) - (setq jabber-widget-alist - (cons - (cons (car entry) - (widget-create 'editable-field - :secret (if (eq (car entry) 'password) - ?* nil) - (or (car (jabber-xml-node-children - field)) default-value))) - jabber-widget-alist))) - (widget-insert "\n")))))) - -(defun jabber-parse-register-form () - "Return children of a tag containing information entered in the widgets of the current buffer." - (mapcar - (lambda (widget-cons) - (list (car widget-cons) - nil - (widget-value (cdr widget-cons)))) - jabber-widget-alist)) - -(defun jabber-render-xdata-form (x &optional defaults) - "Display widgets from element in jabber:x:data namespace. -DEFAULTS is an alist associating variable names with default values. -DEFAULTS takes precedence over values specified in the form." - (make-local-variable 'jabber-widget-alist) - (setq jabber-widget-alist nil) - (make-local-variable 'jabber-form-type) - (setq jabber-form-type 'xdata) - - (let ((title (car (jabber-xml-node-children (car (jabber-xml-get-children x 'title)))))) - (if (stringp title) - (widget-insert (jabber-propertize title 'face 'jabber-title-medium) "\n\n"))) - (let ((instructions (car (jabber-xml-node-children (car (jabber-xml-get-children x 'instructions)))))) - (if (stringp instructions) - (widget-insert "Instructions: " instructions "\n\n"))) - - (dolist (field (jabber-xml-get-children x 'field)) - (let* ((var (jabber-xml-get-attribute field 'var)) - (label (jabber-xml-get-attribute field 'label)) - (type (jabber-xml-get-attribute field 'type)) - (required (jabber-xml-get-children field 'required)) - (values (jabber-xml-get-children field 'value)) - (options (jabber-xml-get-children field 'option)) - (desc (car (jabber-xml-get-children field 'desc))) - (default-value (assoc var defaults))) - ;; "required" not implemented yet - - (cond - ((string= type "fixed") - (widget-insert (car (jabber-xml-node-children (car values))))) - - ((string= type "text-multi") - (if (or label var) - (widget-insert (or label var) ":\n")) - (push (cons (cons var type) - (widget-create 'text (or (cdr default-value) - (mapconcat #'(lambda (val) - (car (jabber-xml-node-children val))) - values "\n") - ""))) - jabber-widget-alist)) - - ((string= type "list-single") - (if (or label var) - (widget-insert (or label var) ":\n")) - (push (cons (cons var type) - (apply 'widget-create - 'radio-button-choice - :value (or (cdr default-value) - (car (xml-node-children (car values)))) - (mapcar (lambda (option) - `(item :tag ,(jabber-xml-get-attribute option 'label) - :value ,(car (jabber-xml-node-children (car (jabber-xml-get-children option 'value)))))) - options))) - jabber-widget-alist)) - - ((string= type "boolean") - (push (cons (cons var type) - (widget-create 'checkbox - :tag (or label var) - :value (if default-value - (cdr default-value) - (not (null - (member (car (xml-node-children (car values))) '("1" "true"))))))) - jabber-widget-alist) - (if (or label var) - (widget-insert " " (or label var) "\n"))) - - (t ; in particular including text-single and text-private - (if (or label var) - (widget-insert (or label var) ": ")) - (setq jabber-widget-alist - (cons - (cons (cons var type) - (widget-create 'editable-field - :secret (if (string= type "text-private") ?* nil) - (or (cdr default-value) - (car (jabber-xml-node-children (car values))) - ""))) - jabber-widget-alist)))) - (when (and desc (car (jabber-xml-node-children desc))) - (widget-insert "\n" (car (jabber-xml-node-children desc)))) - (widget-insert "\n")))) - -(defun jabber-parse-xdata-form () - "Return an tag containing information entered in the widgets of the current buffer." - `(x ((xmlns . "jabber:x:data") - (type . "submit")) - ,@(mapcar - (lambda (widget-cons) - (let ((values (jabber-xdata-value-convert (widget-value (cdr widget-cons)) (cdar widget-cons)))) - ;; empty fields are not included - (when values - `(field ((var . ,(caar widget-cons))) - ,@(mapcar - (lambda (value) - (list 'value nil value)) - values))))) - jabber-widget-alist))) - -(defun jabber-xdata-value-convert (value type) - "Convert VALUE from form used by widget library to form required by XEP-0004. -Return a list of strings, each of which to be included as cdata in a tag." - (cond - ((string= type "boolean") - (if value (list "1") (list "0"))) - ((string= type "text-multi") - (split-string value "[\n\r]")) - (t ; in particular including text-single, text-private and list-single - (if (zerop (length value)) - nil - (list value))))) - -(defun jabber-render-xdata-search-results (xdata) - "Render search results in x:data form." - - (let ((title (car (jabber-xml-get-children xdata 'title)))) - (when title - (insert (jabber-propertize (car (jabber-xml-node-children title)) 'face 'jabber-title-medium) "\n"))) - - (if (jabber-xml-get-children xdata 'reported) - (jabber-render-xdata-search-results-multi xdata) - (jabber-render-xdata-search-results-single xdata))) - -(defun jabber-render-xdata-search-results-multi (xdata) - "Render multi-record search results." - (let (fields - (jid-fields 0)) - (let ((reported (car (jabber-xml-get-children xdata 'reported))) - (column 0)) - (dolist (field (jabber-xml-get-children reported 'field)) - (let (width) - ;; Clever algorithm for estimating width based on field type goes here. - (setq width 20) - - (setq fields - (append - fields - (list (cons (jabber-xml-get-attribute field 'var) - (list 'label (jabber-xml-get-attribute field 'label) - 'type (jabber-xml-get-attribute field 'type) - 'column column))))) - (setq column (+ column width)) - (if (string= (jabber-xml-get-attribute field 'type) "jid-single") - (setq jid-fields (1+ jid-fields)))))) - - (dolist (field-cons fields) - (indent-to (plist-get (cdr field-cons) 'column) 1) - (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold))) - (insert "\n\n") - - ;; Now, the items - (dolist (item (jabber-xml-get-children xdata 'item)) - - (let ((start-of-line (point)) - jid) - - ;; The following code assumes that the order of the s in each - ;; is the same as in the tag. - (dolist (field (jabber-xml-get-children item 'field)) - (let ((field-plist (cdr (assoc (jabber-xml-get-attribute field 'var) fields))) - (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) - - (indent-to (plist-get field-plist 'column) 1) - - ;; Absent values are sometimes "", sometimes nil. insert - ;; doesn't like nil. - (when value - ;; If there is only one JID field, let the whole row - ;; have the jabber-jid property. If there are many JID - ;; fields, the string belonging to each field has that - ;; property. - (if (string= (plist-get field-plist 'type) "jid-single") - (if (not (eq jid-fields 1)) - (insert (jabber-propertize value 'jabber-jid value)) - (setq jid value) - (insert value)) - (insert value))))) - - (if jid - (put-text-property start-of-line (point) - 'jabber-jid jid)) - (insert "\n"))))) - -(defun jabber-render-xdata-search-results-single (xdata) - "Render single-record search results." - (dolist (field (jabber-xml-get-children xdata 'field)) - (let ((label (jabber-xml-get-attribute field 'label)) - (type (jabber-xml-get-attribute field 'type)) - (values (mapcar #'(lambda (val) - (car (jabber-xml-node-children val))) - (jabber-xml-get-children field 'value)))) - ;; XXX: consider type - (insert (jabber-propertize (concat label ": ") 'face 'bold)) - (indent-to 30) - (insert (apply #'concat values) "\n")))) - -(defun jabber-xdata-formtype (x) - "Return the form type of the xdata form in X, by XEP-0068. -Return nil if no form type is specified." - (catch 'found-formtype - (dolist (field (jabber-xml-get-children x 'field)) - (when (and (string= (jabber-xml-get-attribute field 'var) "FORM_TYPE") - (string= (jabber-xml-get-attribute field 'type) "hidden")) - (throw 'found-formtype (car (jabber-xml-node-children - (car (jabber-xml-get-children field 'value))))))))) - -(require 'cl) - -(defvar jabber-bookmarks (make-hash-table :test 'equal) - "Mapping from full JIDs to bookmarks. -Bookmarks are what has been retrieved from the server, as list of -XML elements. This is nil if bookmarks have not been retrieved, -and t if no bookmarks where found.") - -;;;###autoload -(defun jabber-get-conference-data (jc conference-jid cont &optional key) - "Get bookmark data for CONFERENCE-JID. -KEY may be nil or one of :name, :autojoin, :nick and :password. -If KEY is nil, a plist containing the above keys is returned. -CONT is called when the result is available, with JC and the -result as arguments. If CONT is nil, return the requested data -immediately, and return nil if it is not in the cache." - (if (null cont) - (let ((cache (jabber-get-bookmarks-from-cache jc))) - (if (and cache (listp cache)) - (jabber-get-conference-data-internal - cache conference-jid key))) - (jabber-get-bookmarks - jc - (lexical-let ((conference-jid conference-jid) - (key key) - (cont cont)) - (lambda (jc result) - (let ((entry (jabber-get-conference-data-internal result conference-jid key))) - (funcall cont jc entry))))))) - -(defun jabber-get-conference-data-internal (result conference-jid key) - (let ((entry (dolist (node result) - (when (and (eq (jabber-xml-node-name node) 'conference) - (string= (jabber-xml-get-attribute node 'jid) conference-jid)) - (return (jabber-parse-conference-bookmark node)))))) - (if key - (plist-get entry key) - entry))) - -;;;###autoload -(defun jabber-parse-conference-bookmark (node) - "Convert a tag into a plist. -The plist may contain the keys :jid, :name, :autojoin, -:nick and :password." - (when (eq (jabber-xml-node-name node) 'conference) - (list :jid (jabber-xml-get-attribute node 'jid) - :name (jabber-xml-get-attribute node 'name) - :autojoin (member (jabber-xml-get-attribute node 'autojoin) - '("true" "1")) - :nick (car (jabber-xml-node-children - (car (jabber-xml-get-children node 'nick)))) - :password (car (jabber-xml-node-children - (car (jabber-xml-get-children node 'password))))))) - -;;;###autoload -(defun jabber-get-bookmarks (jc cont &optional refresh) - "Retrieve bookmarks (if needed) and call CONT. -Arguments to CONT are JC and the bookmark list. CONT will be -called as the result of a filter function or a timer. -If REFRESH is non-nil, always fetch bookmarks." - (let ((bookmarks (gethash (jabber-connection-bare-jid jc) jabber-bookmarks))) - (if (and (not refresh) bookmarks) - (run-with-timer 0 nil cont jc (when (listp bookmarks) bookmarks)) - (lexical-let* ((cont cont) - (callback (lambda (jc result) (jabber-get-bookmarks-1 jc result cont)))) - (jabber-private-get jc 'storage "storage:bookmarks" - callback callback))))) - -(defun jabber-get-bookmarks-1 (jc result cont) - (let ((my-jid (jabber-connection-bare-jid jc)) - (value - (if (eq (jabber-xml-node-name result) 'storage) - (or (jabber-xml-node-children result) t) - t))) - (puthash my-jid value jabber-bookmarks) - (funcall cont jc (when (listp value) value)))) - -;;;###autoload -(defun jabber-get-bookmarks-from-cache (jc) - "Return cached bookmarks for JC. -If bookmarks have not yet been fetched by `jabber-get-bookmarks', -return nil." - (gethash (jabber-connection-bare-jid jc) jabber-bookmarks)) - -(defun jabber-set-bookmarks (jc bookmarks &optional callback) - "Set bookmarks to BOOKMARKS, which is a list of XML elements. -If CALLBACK is non-nil, call it with JC and t or nil as arguments -on success or failure, respectively." - (unless callback - (setq callback #'ignore)) - (jabber-private-set - jc - `(storage ((xmlns . "storage:bookmarks")) - ,@bookmarks) - callback t - callback nil)) - -;;;###autoload -(defun jabber-edit-bookmarks (jc) - "Create a buffer for editing bookmarks interactively. - -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (jabber-get-bookmarks jc 'jabber-edit-bookmarks-1 t)) - -(defun jabber-edit-bookmarks-1 (jc bookmarks) - (setq bookmarks - (mapcar - (lambda (e) - (case (jabber-xml-node-name e) - (url - (list 'url (or (jabber-xml-get-attribute e 'url) "") - (or (jabber-xml-get-attribute e 'name) ""))) - (conference - (list 'conference - (or (jabber-xml-get-attribute e 'jid) "") - (or (jabber-xml-get-attribute e 'name) "") - (not (not (member (jabber-xml-get-attribute e 'autojoin) - '("true" "1")))) - (or (jabber-xml-path e '(nick "")) "") - (or (jabber-xml-path e '(password "")) ""))))) - bookmarks)) - (setq bookmarks (delq nil bookmarks)) - (with-current-buffer (get-buffer-create "Edit bookmarks") - (jabber-init-widget-buffer nil) - (setq jabber-buffer-connection jc) - - (widget-insert (jabber-propertize (concat "Edit bookmarks for " - (jabber-connection-bare-jid jc)) - 'face 'jabber-title-large) - "\n\n") - - (when (or (bound-and-true-p jabber-muc-autojoin) - (bound-and-true-p jabber-muc-default-nicknames)) - (widget-insert "The variables `jabber-muc-autojoin' and/or `jabber-muc-default-nicknames'\n" - "contain values. They are only available to jabber.el on this machine.\n" - "You may want to import them into your bookmarks, to make them available\n" - "to any client on any machine.\n") - (widget-create 'push-button :notify 'jabber-bookmarks-import "Import values from variables") - (widget-insert "\n\n")) - - (push (cons 'bookmarks - (widget-create - '(repeat - :tag "Bookmarks" - (choice - (list :tag "Conference" - (const :format "" conference) - (string :tag "JID") ;XXX: jid widget type? - (string :tag "Name") - (checkbox :tag "Autojoin" :format "%[%v%] Autojoin?\n") - (string :tag "Nick") ;or nil? - (string :tag "Password") ;or nil? - ) - (list :tag "URL" - (const :format "" url) - (string :tag "URL") - (string :tag "Name")))) - :value bookmarks)) - jabber-widget-alist) - - (widget-insert "\n") - (widget-create 'push-button :notify 'jabber-bookmarks-submit "Submit") - - (widget-setup) - (widget-minor-mode 1) - (switch-to-buffer (current-buffer)) - (goto-char (point-min)))) - -(defun jabber-bookmarks-submit (&rest ignore) - (let ((bookmarks (widget-value (cdr (assq 'bookmarks jabber-widget-alist))))) - (setq bookmarks - (mapcar - (lambda (entry) - (case (car entry) - (url - (destructuring-bind (symbol url name) entry - `(url ((url . ,url) - (name . ,name))))) - (conference - (destructuring-bind (symbol jid name autojoin nick password) - entry - `(conference ((jid . ,jid) - (name . ,name) - (autojoin . ,(if autojoin - "1" - "0"))) - ,@(unless (zerop (length nick)) - `((nick () ,nick))) - ,@(unless (zerop (length password)) - `((password () ,password)))))))) - bookmarks)) - (remhash (jabber-connection-bare-jid jabber-buffer-connection) jabber-bookmarks) - (jabber-private-set - jabber-buffer-connection - `(storage ((xmlns . "storage:bookmarks")) - ,@bookmarks) - 'jabber-report-success "Storing bookmarks" - 'jabber-report-success "Storing bookmarks"))) - -(defun jabber-bookmarks-import (&rest ignore) - (let* ((value (widget-value (cdr (assq 'bookmarks jabber-widget-alist)))) - (conferences (mapcar - 'cdr - (remove-if-not - (lambda (entry) - (eq (car entry) 'conference)) - value)))) - (dolist (default-nickname jabber-muc-default-nicknames) - (destructuring-bind (muc-jid . nick) default-nickname - (let ((entry (assoc muc-jid conferences))) - (if entry - (setf (fourth entry) nick) - (setq entry (list muc-jid "" nil nick "")) - (push entry conferences) - (push (cons 'conference entry) value))))) - (dolist (autojoin jabber-muc-autojoin) - (let ((entry (assoc autojoin conferences))) - (if entry - (setf (third entry) t) - (setq entry (list autojoin "" t "" "")) - (push (cons 'conference entry) value)))) - (widget-value-set (cdr (assq 'bookmarks jabber-widget-alist)) value) - (widget-setup))) - -;;;###autoload -(defun jabber-private-get (jc node-name namespace success-callback error-callback) - "Retrieve an item from private XML storage. -The item to retrieve is identified by NODE-NAME (a symbol) and -NAMESPACE (a string). - -On success, SUCCESS-CALLBACK is called with JC and the retrieved -XML fragment. - -On error, ERROR-CALLBACK is called with JC and the entire IQ -result." - (jabber-send-iq jc nil "get" - `(query ((xmlns . "jabber:iq:private")) - (,node-name ((xmlns . ,namespace)))) - #'jabber-private-get-1 success-callback - #'(lambda (jc xml-data error-callback) - (funcall error-callback jc xml-data)) - error-callback)) -(defun jabber-private-get-1 (jc xml-data success-callback) - (funcall success-callback jc - (car (jabber-xml-node-children - (jabber-iq-query xml-data))))) -;;;###autoload -(defun jabber-private-set (jc fragment &optional - success-callback success-closure-data - error-callback error-closure-data) - "Store FRAGMENT in private XML storage. -SUCCESS-CALLBACK, SUCCESS-CLOSURE-DATA, ERROR-CALLBACK and -ERROR-CLOSURE-DATA are used as in `jabber-send-iq'. - -JC is the Jabber connection." - (jabber-send-iq jc nil "set" - `(query ((xmlns . "jabber:iq:private")) - ,fragment) - success-callback success-closure-data - error-callback error-closure-data)) -(eval-when-compile (require 'cl)) ;for ignore-errors -;; we need hexrgb-hsv-to-hex: -(eval-and-compile - (or (ignore-errors (require 'hexrgb)) - ;; jabber-fallback-lib/ from jabber/lisp/jabber-fallback-lib - (ignore-errors - (let ((load-path (cons (expand-file-name - "jabber-fallback-lib" - (file-name-directory (locate-library "jabber"))) - load-path))) - (require 'hexrgb))) - (error - "The hexrgb library was not found in `load-path' or jabber-fallback-lib/ directory"))) - -(defcustom jabber-muc-participant-colors nil - "Alist of used colors. -Format is (nick . color). Color may be -in #RGB or textual (like red or blue) notation. Colors will be -added in #RGB notation for unknown nicks." - :type '(alist :key-type string :value-type color) - :group 'jabber-chat) - -(defcustom jabber-muc-colorize-local nil - "Colorize MUC messages from you." - :type 'boolean - :group 'jabber-chat) - -(defcustom jabber-muc-colorize-foreign nil - "Colorize MUC messages not from you." - :type 'boolean - :group 'jabber-chat) - -(defcustom jabber-muc-nick-saturation 1.0 - "Default saturation for nick coloring." - :type 'float - :group 'jabber-chat) - -(defcustom jabber-muc-nick-value 1.0 - "Default value for nick coloring." - :type 'float - :group 'jabber-chat) - -(defun jabber-muc-nick-gen-color (nick) - "Return a good enough color from the available pool." - (let ((hue (/ (mod (string-to-number (substring (md5 nick) 0 6) 16) 360) 360.0))) - (hexrgb-hsv-to-hex hue jabber-muc-nick-saturation jabber-muc-nick-value))) - -(defun jabber-muc-nick-get-color (nick) - "Get NICKs color." - (let ((color (cdr (assoc nick jabber-muc-participant-colors)))) - (if color - color - (progn - (unless jabber-muc-participant-colors ) - (push (cons nick (jabber-muc-nick-gen-color nick)) jabber-muc-participant-colors) - (cdr (assoc nick jabber-muc-participant-colors)))))) - -;; we need jabber-bookmarks for jabber-muc-autojoin (via -;; jabber-get-bookmarks and jabber-parse-conference-bookmark): - -(require 'cl) - -;;;###autoload -(defvar *jabber-active-groupchats* nil - "Alist of groupchats and nicknames. -Keys are strings, the bare JID of the room. -Values are strings.") - -(defvar jabber-pending-groupchats (make-hash-table) - "Hash table of groupchats and nicknames. -Keys are JID symbols; values are strings. -This table records the last nickname used to join the particular -chat room. Items are thus never removed.") - -(defvar jabber-muc-participants nil - "Alist of groupchats and participants. -Keys are strings, the bare JID of the room. -Values are lists of nickname strings.") - -(defvar jabber-group nil - "The groupchat you are participating in.") - -(defvar jabber-muc-topic "" - "The topic of the current MUC room.") - -(defvar jabber-role-history () - "Keeps track of previously used roles.") - -(defvar jabber-affiliation-history () - "Keeps track of previously used affiliations.") - -(defvar jabber-muc-nickname-history () - "Keeps track of previously referred-to nicknames.") - -(defcustom jabber-muc-default-nicknames nil - "Default nickname for specific MUC rooms." - :group 'jabber-chat - :type '(repeat - (cons :format "%v" - (string :tag "JID of room") - (string :tag "Nickname")))) - -(defcustom jabber-muc-autojoin nil - "List of MUC rooms to automatically join on connection. -This list is saved in your Emacs customizations. You can also store -such a list on the Jabber server, where it is available to every -client; see `jabber-edit-bookmarks'." - :group 'jabber-chat - :type '(repeat (string :tag "JID of room"))) - -(defcustom jabber-muc-disable-disco-check nil - "If non-nil, disable checking disco#info of rooms before joining them. -Disco information can tell whether the room exists and whether it is -password protected, but some servers do not support it. If you want -to join chat rooms on such servers, set this variable to t." - :group 'jabber-chat - :type 'boolean) - -(defcustom jabber-groupchat-buffer-format "*-jabber-groupchat-%n-*" - "The format specification for the name of groupchat buffers. - -These fields are available (all are about the group you are chatting -in): - -%n Roster name of group, or JID if no nickname set -%b Name of group from bookmarks or roster name or JID if none set -%j Bare JID (without resource)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-groupchat-prompt-format "[%t] %n> " - "The format specification for lines in groupchat. - -These fields are available: - -%t Time, formatted according to `jabber-chat-time-format' -%n, %u, %r - Nickname in groupchat -%j Full JID (room@server/nick)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-muc-header-line-format - '(" " (:eval (jabber-jid-displayname jabber-group)) - "\t" jabber-muc-topic) - "The specification for the header line of MUC buffers. - -The format is that of `mode-line-format' and `header-line-format'." - :type 'sexp - :group 'jabber-chat) - -(defcustom jabber-muc-private-buffer-format "*-jabber-muc-priv-%g-%n-*" - "The format specification for the buffer name for private MUC messages. - -These fields are available: - -%g Roster name of group, or JID if no nickname set -%n Nickname of the group member you're chatting with" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-muc-private-foreign-prompt-format "[%t] %g/%n> " - "The format specification for lines others type in a private MUC buffer. - -These fields are available: - -%t Time, formatted according to `jabber-chat-time-format' -%n Nickname in room -%g Short room name (either roster name or username part of JID)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-muc-print-names-format " %n %a %j\n" - "The format specification for MUC list lines. - -Fields available: - -%n Nickname in room -%a Affiliation status -%j Full JID (room@server/nick)" - :type 'string - :group 'jabber-chat) - -(defcustom jabber-muc-private-header-line-format - '(" " (:eval (jabber-jid-resource jabber-chatting-with)) - " in " (:eval (jabber-jid-displayname (jabber-jid-user jabber-chatting-with))) - "\t" jabber-events-message - "\t" jabber-chatstates-message) - "The specification for the header line of private MUC chat buffers. - -The format is that of `mode-line-format' and `header-line-format'." - :type 'sexp - :group 'jabber-chat) - -;;;###autoload -(defvar jabber-muc-printers '() - "List of functions that may be able to print part of a MUC message. -This gets prepended to `jabber-chat-printers', which see.") - -;;;###autoload -(defun jabber-muc-get-buffer (group) - "Return the chat buffer for chatroom GROUP. -Either a string or a buffer is returned, so use `get-buffer' or -`get-buffer-create'." - (format-spec jabber-groupchat-buffer-format - (list - (cons ?n (jabber-jid-displayname group)) - (cons ?b (jabber-jid-bookmarkname group)) - (cons ?j (jabber-jid-user group))))) - -(defun jabber-muc-create-buffer (jc group) - "Prepare a buffer for chatroom GROUP. -This function is idempotent. - -JC is the Jabber connection." - (with-current-buffer (get-buffer-create (jabber-muc-get-buffer group)) - (unless (eq major-mode 'jabber-chat-mode) - (jabber-chat-mode jc #'jabber-chat-pp)) - ;; Make sure the connection variable is up to date. - (setq jabber-buffer-connection jc) - - (set (make-local-variable 'jabber-group) group) - (make-local-variable 'jabber-muc-topic) - (setq jabber-send-function 'jabber-muc-send) - (setq header-line-format jabber-muc-header-line-format) - (current-buffer))) - -;;;###autoload -(defun jabber-muc-private-get-buffer (group nickname) - "Return the chat buffer for private chat with NICKNAME in GROUP. -Either a string or a buffer is returned, so use `get-buffer' or -`get-buffer-create'." - (format-spec jabber-muc-private-buffer-format - (list - (cons ?g (jabber-jid-displayname group)) - (cons ?n nickname)))) - -(defun jabber-muc-private-create-buffer (jc group nickname) - "Prepare a buffer for chatting with NICKNAME in GROUP. -This function is idempotent. - -JC is the Jabber connection." - (with-current-buffer (get-buffer-create (jabber-muc-private-get-buffer group nickname)) - (unless (eq major-mode 'jabber-chat-mode) - (jabber-chat-mode jc #'jabber-chat-pp)) - - (set (make-local-variable 'jabber-chatting-with) (concat group "/" nickname)) - (setq jabber-send-function 'jabber-chat-send) - (setq header-line-format jabber-muc-private-header-line-format) - - (current-buffer))) - -(defun jabber-muc-send (jc body) - "Send BODY to MUC room in current buffer. - -JC is the Jabber connection." - ;; There is no need to display the sent message in the buffer, as - ;; we will get it back from the MUC server. - (jabber-send-sexp jc - `(message - ((to . ,jabber-group) - (type . "groupchat")) - (body () ,body)))) - -(defun jabber-muc-add-groupchat (group nickname) - "Remember participating in GROUP under NICKNAME." - (let ((whichgroup (assoc group *jabber-active-groupchats*))) - (if whichgroup - (setcdr whichgroup nickname) - (add-to-list '*jabber-active-groupchats* (cons group nickname))))) - -(defun jabber-muc-remove-groupchat (group) - "Remove GROUP from internal bookkeeping." - (let ((whichgroup (assoc group *jabber-active-groupchats*)) - (whichparticipants (assoc group jabber-muc-participants))) - (setq *jabber-active-groupchats* - (delq whichgroup *jabber-active-groupchats*)) - (setq jabber-muc-participants - (delq whichparticipants jabber-muc-participants)))) - -(defun jabber-muc-connection-closed (bare-jid) - "Remove MUC data for BARE-JID. -Forget all information about rooms that had been entered with -this JID. Suitable to call when the connection is closed." - (dolist (room-entry jabber-muc-participants) - (let* ((room (car room-entry)) - (buffer (get-buffer (jabber-muc-get-buffer room)))) - (when (bufferp buffer) - (with-current-buffer buffer - (when (string= bare-jid - (jabber-connection-bare-jid jabber-buffer-connection)) - (setq *jabber-active-groupchats* - (delete* room *jabber-active-groupchats* - :key #'car :test #'string=)) - (setq jabber-muc-participants - (delq room-entry jabber-muc-participants)))))))) - -(defun jabber-muc-participant-plist (group nickname) - "Return plist associated with NICKNAME in GROUP. -Return nil if nothing known about that combination." - (let ((whichparticipants (assoc group jabber-muc-participants))) - (when whichparticipants - (cdr (assoc nickname whichparticipants))))) - -(defun jabber-muc-modify-participant (group nickname new-plist) - "Assign properties in NEW-PLIST to NICKNAME in GROUP." - (let ((participants (assoc group jabber-muc-participants))) - ;; either we have a list of participants already... - (if participants - (let ((participant (assoc nickname participants))) - ;; and maybe this participant is already in the list - (if participant - ;; if so, just update role, affiliation, etc. - (setf (cdr participant) new-plist) - (push (cons nickname new-plist) (cdr participants)))) - ;; or we don't - (push (cons group (list (cons nickname new-plist))) jabber-muc-participants)))) - -(defun jabber-muc-report-delta (nickname old-plist new-plist reason actor) - "Compare OLD-PLIST and NEW-PLIST, and return a string explaining the change. -Return nil if nothing noteworthy has happened. -NICKNAME is the user experiencing the change. REASON and ACTOR, if non-nil, -are the corresponding presence fields. - -This function is only concerned with presence stanzas resulting -in the user entering/staying in the room." - ;; The keys in the plist are affiliation, role and jid. - (when (plist-get new-plist 'jid) - ;; nickname is only used for displaying, so we can modify it if we - ;; want to. - (setq nickname (concat nickname " <" - (jabber-jid-user (plist-get new-plist 'jid)) - ">"))) - (cond - ((null old-plist) - ;; User enters the room - (concat nickname " enters the room (" - (plist-get new-plist 'role) - (unless (string= (plist-get new-plist 'affiliation) "none") - (concat ", " (plist-get new-plist 'affiliation))) - ")")) - - ;; If affiliation changes, the role change is usually the logical - ;; one, so don't report it separately. - ((not (string= (plist-get old-plist 'affiliation) - (plist-get new-plist 'affiliation))) - (let ((actor-reason (concat (when actor - (concat " by " actor)) - (when reason - (concat ": " reason)))) - (from (plist-get old-plist 'affiliation)) - (to (plist-get new-plist 'affiliation))) - ;; There are many ways to express these transitions in English. - ;; This one favors eloquence over regularity and consistency. - (cond - ;; Higher affiliation - ((or (and (member from '("outcast" "none" "member")) - (member to '("admin" "owner"))) - (and (string= from "admin") (string= to "owner"))) - (concat nickname " has been promoted to " to actor-reason)) - ;; Lower affiliation - ((or (and (member from '("owner" "admin")) - (string= to "member")) - (and (string= from "owner") (string= to "admin"))) - (concat nickname " has been demoted to " to actor-reason)) - ;; Become member - ((string= to "member") - (concat nickname " has been granted membership" actor-reason)) - ;; Lose membership - ((string= to "none") - (concat nickname " has been deprived of membership" actor-reason))))) - - ;; Role changes - ((not (string= (plist-get old-plist 'role) - (plist-get new-plist 'role))) - (let ((actor-reason (concat (when actor - (concat " by " actor)) - (when reason - (concat ": " reason)))) - (from (plist-get old-plist 'role)) - (to (plist-get new-plist 'role))) - ;; Possible roles are "none" (not in room, hence not of interest - ;; in this function), "visitor" (no voice), "participant" (has - ;; voice), and "moderator". - (cond - ((string= to "moderator") - (concat nickname " has been granted moderator privileges" actor-reason)) - ((and (string= from "moderator") - (string= to "participant")) - (concat nickname " had moderator privileges revoked" actor-reason)) - ((string= to "participant") - (concat nickname " has been granted voice" actor-reason)) - ((string= to "visitor") - (concat nickname " has been denied voice" actor-reason))))))) - -(defun jabber-muc-remove-participant (group nickname) - "Forget everything about NICKNAME in GROUP." - (let ((participants (assoc group jabber-muc-participants))) - (when participants - (let ((participant (assoc nickname (cdr participants)))) - (setf (cdr participants) (delq participant (cdr participants))))))) - -(defmacro jabber-muc-argument-list (&optional args) - "Prepend connection and group name to ARGS. -If the current buffer is not an MUC buffer, signal an error. -This macro is meant for use as an argument to `interactive'." - `(if (null jabber-group) - (error "Not in MUC buffer") - (nconc (list jabber-buffer-connection jabber-group) ,args))) - -(defun jabber-muc-read-completing (prompt &optional allow-not-joined) - "Read the name of a joined chatroom, or use chatroom of current buffer if any. -If ALLOW-NOT-JOINED is provided and non-nil, permit choosing any -JID; only provide completion as a guide." - (or jabber-group - (jabber-read-jid-completing prompt - (if (null *jabber-active-groupchats*) - (error "You haven't joined any group") - (mapcar (lambda (x) (jabber-jid-symbol (car x))) - *jabber-active-groupchats*)) - (not allow-not-joined) - jabber-group))) - -(defun jabber-muc-read-nickname (group prompt) - "Read the nickname of a participant in GROUP." - (let ((nicknames (cdr (assoc group jabber-muc-participants)))) - (unless nicknames - (error "Unknown group: %s" group)) - (completing-read prompt nicknames nil t nil 'jabber-muc-nickname-history))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Request vcard" 'jabber-muc-vcard-get)) - -;;;###autoload -(defun jabber-muc-vcard-get (jc group nickname) - "Request vcard from chat with NICKNAME in GROUP. - -JC is the Jabber connection." - (interactive - (jabber-muc-argument-list - (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) - (let ((muc-name (format "%s/%s" group nickname))) - (jabber-vcard-get jc muc-name))) - -(defun jabber-muc-instant-config (jc group) - "Accept default configuration for GROUP. -This can be used for a newly created room, as an alternative to -filling out the configuration form with `jabber-muc-get-config'. -Both of these methods unlock the room, so that other users can -enter it. - -JC is the Jabber connection." - (interactive (jabber-muc-argument-list)) - (jabber-send-iq jc group - "set" - '(query ((xmlns . "http://jabber.org/protocol/muc#owner")) - (x ((xmlns . "jabber:x:data") (type . "submit")))) - #'jabber-report-success "MUC instant configuration" - #'jabber-report-success "MUC instant configuration")) - -(add-to-list 'jabber-jid-muc-menu - (cons "Configure groupchat" 'jabber-muc-get-config)) - -(defun jabber-muc-get-config (jc group) - "Ask for MUC configuration form. - -JC is the Jabber connection." - (interactive (jabber-muc-argument-list)) - (jabber-send-iq jc group - "get" - '(query ((xmlns . "http://jabber.org/protocol/muc#owner"))) - #'jabber-process-data #'jabber-muc-render-config - #'jabber-process-data "MUC configuration request failed")) - -(defalias 'jabber-groupchat-get-config 'jabber-muc-get-config - "Deprecated. See `jabber-muc-get-config' instead.") - -(defun jabber-muc-render-config (jc xml-data) - "Render MUC configuration form. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let ((query (jabber-iq-query xml-data)) - xdata) - (dolist (x (jabber-xml-get-children query 'x)) - (if (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") - (setq xdata x))) - (if (not xdata) - (insert "No configuration possible.\n") - - (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from)) - (setq jabber-buffer-connection jc) - - (jabber-render-xdata-form xdata) - - (widget-create 'push-button :notify #'jabber-muc-submit-config "Submit") - (widget-insert "\t") - (widget-create 'push-button :notify #'jabber-muc-cancel-config "Cancel") - (widget-insert "\n") - - (widget-setup) - (widget-minor-mode 1)))) - -(defalias 'jabber-groupchat-render-config 'jabber-muc-render-config - "Deprecated. See `jabber-muc-render-config' instead.") - -(defun jabber-muc-submit-config (&rest ignore) - "Submit MUC configuration form." - - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - `(query ((xmlns . "http://jabber.org/protocol/muc#owner")) - ,(jabber-parse-xdata-form)) - #'jabber-report-success "MUC configuration" - #'jabber-report-success "MUC configuration")) - -(defalias 'jabber-groupchat-submit-config 'jabber-muc-submit-config - "Deprecated. See `jabber-muc-submit-config' instead.") - -(defun jabber-muc-cancel-config (&rest ignore) - "Cancel MUC configuration form." - - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - '(query ((xmlns . "http://jabber.org/protocol/muc#owner")) - (x ((xmlns . "jabber:x:data") (type . "cancel")))) - nil nil nil nil)) - -(defalias 'jabber-groupchat-cancel-config 'jabber-muc-cancel-config - "Deprecated. See `jabber-muc-cancel-config' instead.") - -(add-to-list 'jabber-jid-muc-menu - (cons "Join groupchat" 'jabber-muc-join)) - -(defun jabber-muc-join (jc group nickname &optional popup) - "Join a groupchat, or change nick. -In interactive calls, or if POPUP is non-nil, switch to the -groupchat buffer. - -JC is the Jabber connection." - (interactive - (let ((account (jabber-read-account)) - (group (jabber-read-jid-completing "group: "))) - (list account group (jabber-muc-read-my-nickname account group) t))) - - ;; If the user is already in the room, we don't need as many checks. - (if (or (assoc group *jabber-active-groupchats*) - ;; Or if the users asked us not to check disco info. - jabber-muc-disable-disco-check) - (jabber-muc-join-3 jc group nickname nil popup) - ;; Else, send a disco request to find out what we are connecting - ;; to. - (jabber-disco-get-info jc group nil #'jabber-muc-join-2 - (list group nickname popup)))) - -(defalias 'jabber-groupchat-join 'jabber-muc-join - "Deprecated. Use `jabber-muc-join' instead.") - -(defun jabber-muc-join-2 (jc closure result) - (destructuring-bind (group nickname popup) closure - (let* ( ;; Either success... - (identities (car result)) - (features (cadr result)) - ;; ...or error - (condition (when (eq identities 'error) (jabber-error-condition result)))) - (cond - ;; Maybe the room doesn't exist yet. - ((eq condition 'item-not-found) - (unless (or jabber-silent-mode - (y-or-n-p (format "%s doesn't exist. Create it? " - (jabber-jid-displayname group)))) - (error "Non-existent groupchat"))) - - ;; Maybe the room doesn't support disco. - ((eq condition 'feature-not-implemented) - t ;whatever... we will ignore it later - ) - ;; Maybe another error occurred. Report it to user - (condition - (message "Couldn't query groupchat: %s" (jabber-parse-error result))) - - ;; Bad stanza? Without NS, for example - ((and (eq identities 'error) (not condition)) - (message "Bad error stanza received"))) - - ;; Continue only if it is really chat room. If there was an - ;; error, give the chat room the benefit of the doubt. (Needed - ;; for ejabberd's mod_irc, for example) - (when (or condition - (find "conference" (if (sequencep identities) identities nil) - :key (lambda (i) (aref i 1)) - :test #'string=)) - (let ((password - ;; Is the room password-protected? - (when (member "muc_passwordprotected" features) - (or - (jabber-get-conference-data jc group nil :password) - (read-passwd (format "Password for %s: " (jabber-jid-displayname group))))))) - - (jabber-muc-join-3 jc group nickname password popup)))))) - -(defalias 'jabber-groupchat-join-2 'jabber-muc-join-2 - "Deprecated. See `jabber-muc-join-2' instead.") - -(defun jabber-muc-join-3 (jc group nickname password popup) - - ;; Remember that this is a groupchat _before_ sending the stanza. - ;; The response might come quicker than you think. - - (puthash (jabber-jid-symbol group) nickname jabber-pending-groupchats) - - (jabber-send-sexp jc - `(presence ((to . ,(format "%s/%s" group nickname))) - (x ((xmlns . "http://jabber.org/protocol/muc")) - ,@(when password - `((password () ,password)))) - ,@(jabber-presence-children jc))) - - ;; There, stanza sent. Now we just wait for the MUC service to - ;; mirror the stanza. This is handled in - ;; `jabber-muc-process-presence', where a buffer will be created for - ;; the room. - - ;; But if the user interactively asked to join, he/she probably - ;; wants the buffer to pop up right now. - (when popup - (let ((buffer (jabber-muc-create-buffer jc group))) - (switch-to-buffer buffer)))) - -(defalias 'jabber-groupchat-join-3 'jabber-muc-join-3 - "Deprecated. See `jabber-muc-join-3' instead.") - -(defun jabber-muc-read-my-nickname (jc group &optional default) - "Read nickname for joining GROUP. -If DEFAULT is non-nil, return default nick without prompting. - -JC is the Jabber connection." - (let ((default-nickname (or - (jabber-get-conference-data jc group nil :nick) - (cdr (assoc group jabber-muc-default-nicknames)) - (plist-get (fsm-get-state-data jc) :username)))) - (if default - default-nickname - (jabber-read-with-input-method (format "Nickname: (default %s) " - default-nickname) - nil nil default-nickname)))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Change nickname" 'jabber-muc-nick)) - -(defalias 'jabber-muc-nick 'jabber-muc-join) - -(add-to-list 'jabber-jid-muc-menu - (cons "Leave groupchat" 'jabber-muc-leave)) - -(defun jabber-muc-leave (jc group) - "Leave a groupchat. - -JC is the Jabber connection." - (interactive (jabber-muc-argument-list)) - (let ((whichgroup (assoc group *jabber-active-groupchats*))) - ;; send unavailable presence to our own nick in room - (jabber-send-sexp jc - `(presence ((to . ,(format "%s/%s" group (cdr whichgroup))) - (type . "unavailable")))))) - -(defalias 'jabber-groupchat-leave 'jabber-muc-leave - "Deprecated. Use `jabber-muc-leave' instead.") - -(add-to-list 'jabber-jid-muc-menu - (cons "List participants" 'jabber-muc-names)) - -(defun jabber-muc-names () - "Print names, affiliations, and roles of participants in current buffer." - (interactive) - (ewoc-enter-last jabber-chat-ewoc (list :notice - (jabber-muc-print-names - (cdr (assoc jabber-group jabber-muc-participants))) - :time (current-time)))) - -(defun jabber-muc-format-names (participant) - "Format one participant name." - (format-spec jabber-muc-print-names-format - (list - (cons ?n (car participant)) - (cons ?a (plist-get (cdr participant) 'affiliation)) - (cons ?j (or (plist-get (cdr participant) 'jid) ""))))) - -(defun jabber-muc-print-names (participants) - "Format and return data in PARTICIPANTS." - (let ((mlist) (plist) (vlist) (nlist)) - (mapcar (lambda (x) - (let ((role (plist-get (cdr x) 'role))) - (cond ((string= role "moderator") - (add-to-list 'mlist x)) - ((string= role "participant") - (add-to-list 'plist x)) - ((string= role "visitor") - (add-to-list 'vlist x)) - ((string= role "none") - (add-to-list 'nlist x))))) - participants) - (concat - (apply 'concat "\nModerators:\n" (mapcar 'jabber-muc-format-names mlist)) - (apply 'concat "\nParticipants:\n" (mapcar 'jabber-muc-format-names plist)) - (apply 'concat "\nVisitors:\n" (mapcar 'jabber-muc-format-names vlist)) - (apply 'concat "\nNones:\n" (mapcar 'jabber-muc-format-names nlist))) - )) - -(add-to-list 'jabber-jid-muc-menu - (cons "Set topic" 'jabber-muc-set-topic)) - -(defun jabber-muc-set-topic (jc group topic) - "Set topic of GROUP to TOPIC. - -JC is the Jabber connection." - (interactive - (jabber-muc-argument-list - (list (jabber-read-with-input-method "New topic: " jabber-muc-topic)))) - (jabber-send-message jc group topic nil "groupchat")) - -(defun jabber-muc-snarf-topic (xml-data) - "Record subject (topic) of the given , if any. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((new-topic (jabber-xml-path xml-data '(subject "")))) - (when new-topic - (setq jabber-muc-topic new-topic)))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Set role (kick, voice, op)" 'jabber-muc-set-role)) - -(defun jabber-muc-set-role (jc group nickname role reason) - "Set role of NICKNAME in GROUP to ROLE, specifying REASON. - -JC is the Jabber connection." - (interactive - (jabber-muc-argument-list - (let ((nickname (jabber-muc-read-nickname jabber-group "Nickname: "))) - (list nickname - (completing-read "New role: " '(("none") ("visitor") ("participant") ("moderator")) nil t nil 'jabber-role-history) - (read-string "Reason: "))))) - (unless (or (zerop (length nickname)) (zerop (length role))) - (jabber-send-iq jc group "set" - `(query ((xmlns . "http://jabber.org/protocol/muc#admin")) - (item ((nick . ,nickname) - (role . ,role)) - ,(unless (zerop (length reason)) - `(reason () ,reason)))) - 'jabber-report-success "Role change" - 'jabber-report-success "Role change"))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Set affiliation (ban, member, admin)" 'jabber-muc-set-affiliation)) - -(defun jabber-muc-set-affiliation (jc group nickname-or-jid nickname-p affiliation reason) - "Set affiliation of NICKNAME-OR-JID in GROUP to AFFILIATION. -If NICKNAME-P is non-nil, NICKNAME-OR-JID is a nickname in the -group, else it is a JID. - -JC is the Jabber connection." - (interactive - (jabber-muc-argument-list - (let ((nickname-p (y-or-n-p "Specify user by room nickname? "))) - (list - (if nickname-p - (jabber-muc-read-nickname jabber-group "Nickname: ") - (jabber-read-jid-completing "User: ")) - nickname-p - (completing-read "New affiliation: " - '(("none") ("outcast") ("member") ("admin") ("owner")) nil t nil 'jabber-affiliation-history) - (read-string "Reason: "))))) - (let ((jid - (if nickname-p - (let ((participants (cdr (assoc group jabber-muc-participants)))) - (unless participants - (error "Couldn't find group %s" group)) - (let ((participant (cdr (assoc nickname-or-jid participants)))) - (unless participant - (error "Couldn't find %s in group %s" nickname-or-jid group)) - (or (plist-get participant 'jid) - (error "JID of %s in group %s is unknown" nickname-or-jid group)))) - nickname-or-jid))) - (jabber-send-iq jc group "set" - `(query ((xmlns . "http://jabber.org/protocol/muc#admin")) - (item ((jid . ,jid) - (affiliation . ,affiliation)) - ,(unless (zerop (length reason)) - `(reason () ,reason)))) - 'jabber-report-success "Affiliation change" - 'jabber-report-success "Affiliation change"))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Invite someone to chatroom" 'jabber-muc-invite)) - -(defun jabber-muc-invite (jc jid group reason) - "Invite JID to GROUP, stating REASON. - -JC is the Jabber connection." - (interactive - (list (jabber-read-account) - (jabber-read-jid-completing - "Invite whom: " - ;; The current room is _not_ a good default for whom to invite. - (remq (jabber-jid-symbol jabber-group) (jabber-concat-rosters))) - (jabber-muc-read-completing "To group: ") - (jabber-read-with-input-method "Reason: "))) - (jabber-send-sexp - jc - `(message ((to . ,group)) - (x ((xmlns . "http://jabber.org/protocol/muc#user")) - (invite ((to . ,jid)) - ,(unless (zerop (length reason)) - `(reason nil ,reason))))))) - -(add-to-list 'jabber-body-printers 'jabber-muc-print-invite) - -(defun jabber-muc-print-invite (xml-data who mode) - "Print MUC invitation. - -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (dolist (x (jabber-xml-get-children xml-data 'x)) - (when (string= (jabber-xml-get-attribute x 'xmlns) "http://jabber.org/protocol/muc#user") - (let ((invitation (car (jabber-xml-get-children x 'invite)))) - (when invitation - (when (eql mode :insert) - (let ((group (jabber-xml-get-attribute xml-data 'from)) - (inviter (jabber-xml-get-attribute invitation 'from)) - (reason (car (jabber-xml-node-children (car (jabber-xml-get-children invitation 'reason)))))) - ;; XXX: password - (insert "You have been invited to MUC room " (jabber-jid-displayname group)) - (when inviter - (insert " by " (jabber-jid-displayname inviter))) - (insert ".") - (when reason - (insert " Reason: " reason)) - (insert "\n\n") - - (let ((action - `(lambda (&rest ignore) (interactive) - (jabber-muc-join jabber-buffer-connection ,group - (jabber-muc-read-my-nickname jabber-buffer-connection ,group))))) - (if (fboundp 'insert-button) - (insert-button "Accept" - 'action action) - ;; Simple button replacement - (let ((keymap (make-keymap))) - (define-key keymap "\r" action) - (insert (jabber-propertize "Accept" - 'keymap keymap - 'face 'highlight)))) - - (insert "\t") - - (let ((action - `(lambda (&rest ignore) (interactive) - (let ((reason - (jabber-read-with-input-method - "Reason: "))) - (jabber-send-sexp - jabber-buffer-connection - (list 'message - (list (cons 'to ,group)) - (list 'x - (list (cons 'xmlns "http://jabber.org/protocol/muc#user")) - (list 'decline - (list (cons 'to ,inviter)) - (unless (zerop (length reason)) - (list 'reason nil reason)))))))))) - (if (fboundp 'insert-button) - (insert-button "Decline" - 'action action) - ;; Simple button replacement - (let ((keymap (make-keymap))) - (define-key keymap "\r" action) - (insert (jabber-propertize "Decline" - 'keymap keymap - 'face 'highlight)))))))) - (return t)))))) - -(defun jabber-muc-autojoin (jc) - "Join rooms specified in account bookmarks and global `jabber-muc-autojoin'. - -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (let ((nickname (plist-get (fsm-get-state-data jc) :username))) - (when (bound-and-true-p jabber-muc-autojoin) - (dolist (group jabber-muc-autojoin) - (jabber-muc-join jc group (or - (cdr (assoc group jabber-muc-default-nicknames)) - (plist-get (fsm-get-state-data jc) :username))))) - (jabber-get-bookmarks - jc - (lambda (jc bookmarks) - (dolist (bookmark bookmarks) - (setq bookmark (jabber-parse-conference-bookmark bookmark)) - (when (and bookmark (plist-get bookmark :autojoin)) - (jabber-muc-join jc (plist-get bookmark :jid) - (or (plist-get bookmark :nick) - (plist-get (fsm-get-state-data jc) :username))))))))) - -;;;###autoload -(defun jabber-muc-message-p (message) - "Return non-nil if MESSAGE is a groupchat message. -That does not include private messages in a groupchat, but does -include groupchat invites." - ;; Public groupchat messages have type "groupchat" and are from - ;; room@server/nick. Public groupchat errors have type "error" and - ;; are from room@server. - (let ((from (jabber-xml-get-attribute message 'from)) - (type (jabber-xml-get-attribute message 'type))) - (or - (string= type "groupchat") - (and (string= type "error") - (gethash (jabber-jid-symbol from) jabber-pending-groupchats)) - (jabber-xml-path message '(("http://jabber.org/protocol/muc#user" . "x") invite))))) - -;;;###autoload -(defun jabber-muc-sender-p (jid) - "Return non-nil if JID is a full JID of an MUC participant." - (and (assoc (jabber-jid-user jid) *jabber-active-groupchats*) - (jabber-jid-resource jid))) - -;;;###autoload -(defun jabber-muc-private-message-p (message) - "Return non-nil if MESSAGE is a private message in a groupchat." - (let ((from (jabber-xml-get-attribute message 'from)) - (type (jabber-xml-get-attribute message 'type))) - (and - (not (string= type "groupchat")) - (jabber-muc-sender-p from)))) - -(add-to-list 'jabber-jid-muc-menu - (cons "Open private chat" 'jabber-muc-private)) - -(defun jabber-muc-private (jc group nickname) - "Open private chat with NICKNAME in GROUP. - -JC is the Jabber connection." - (interactive - (jabber-muc-argument-list - (list (jabber-muc-read-nickname jabber-group "Nickname: ")))) - (switch-to-buffer (jabber-muc-private-create-buffer jabber-buffer-connection group nickname))) - -(defun jabber-muc-presence-p (presence) - "Return non-nil if PRESENCE is presence from groupchat." - (let ((from (jabber-xml-get-attribute presence 'from)) - (type (jabber-xml-get-attribute presence 'type)) - (muc-marker (find-if - (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) - "http://jabber.org/protocol/muc#user")) - (jabber-xml-get-children presence 'x)))) - ;; This is MUC presence if it has an MUC-namespaced tag... - (or muc-marker - ;; ...or if it is error presence from a room we tried to join. - (and (string= type "error") - (gethash (jabber-jid-symbol from) jabber-pending-groupchats))))) - -(defun jabber-muc-parse-affiliation (x-muc) - "Parse X-MUC in the muc#user namespace and return a plist. -Return nil if X-MUC is nil." - ;; XXX: parse and tags? or maybe elsewhere? - (apply 'nconc (mapcar (lambda (prop) (list (car prop) (cdr prop))) - (jabber-xml-node-attributes - (car (jabber-xml-get-children x-muc 'item)))))) - -(defun jabber-muc-print-prompt (xml-data &optional local dont-print-nick-p) - "Print MUC prompt for message in XML-DATA." - (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from))) - (timestamp (jabber-message-timestamp xml-data))) - (if (stringp nick) - (insert (jabber-propertize - (format-spec jabber-groupchat-prompt-format - (list - (cons ?t (format-time-string - (if timestamp - jabber-chat-delayed-time-format - jabber-chat-time-format) - timestamp)) - (cons ?n (if dont-print-nick-p "" nick)) - (cons ?u nick) - (cons ?r nick) - (cons ?j (concat jabber-group "/" nick)))) - 'face (if local ;Message from you. - (if jabber-muc-colorize-local ;; If colorization enable... - ;; ...colorize nick - (list ':foreground (jabber-muc-nick-get-color nick)) - ;; otherwise, use default face. - 'jabber-chat-prompt-local) - ;; Message from other participant. - (if jabber-muc-colorize-foreign ;If colorization enable... - ;; ... colorize nick - (list ':foreground (jabber-muc-nick-get-color nick)) - ;; otherwise, use default face. - 'jabber-chat-prompt-foreign)) - 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group))) - (jabber-muc-system-prompt)))) - -(defun jabber-muc-private-print-prompt (xml-data) - "Print prompt for private MUC message in XML-DATA." - (let ((nick (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from))) - (group (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) - (timestamp (jabber-message-timestamp xml-data))) - (insert (jabber-propertize - (format-spec jabber-muc-private-foreign-prompt-format - (list - (cons ?t (format-time-string - (if timestamp - jabber-chat-delayed-time-format - jabber-chat-time-format) - timestamp)) - (cons ?n nick) - (cons ?g (or (jabber-jid-rostername group) - (jabber-jid-username group))))) - 'face 'jabber-chat-prompt-foreign - 'help-echo (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " nick " in " jabber-group))))) - -(defun jabber-muc-system-prompt (&rest ignore) - "Print system prompt for MUC." - (insert (jabber-propertize - (format-spec jabber-groupchat-prompt-format - (list - (cons ?t (format-time-string jabber-chat-time-format)) - (cons ?n "") - (cons ?u "") - (cons ?r "") - (cons ?j jabber-group))) - 'face 'jabber-chat-prompt-system - 'help-echo (format-time-string "System message on %Y-%m-%d %H:%M:%S")))) - -(add-to-list 'jabber-message-chain 'jabber-muc-process-message) - -(defun jabber-muc-process-message (jc xml-data) - "If XML-DATA is a groupchat message, handle it as such. - -JC is the Jabber connection." - (when (jabber-muc-message-p xml-data) - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (group (jabber-jid-user from)) - (nick (jabber-jid-resource from)) - (error-p (jabber-xml-get-children xml-data 'error)) - (type (cond - (error-p :muc-error) - ((string= nick (cdr (assoc group *jabber-active-groupchats*))) - :muc-local) - (t :muc-foreign))) - (body-text (car (jabber-xml-node-children - (car (jabber-xml-get-children - xml-data 'body))))) - - (printers (append jabber-muc-printers jabber-chat-printers))) - - (with-current-buffer (jabber-muc-create-buffer jc group) - (jabber-muc-snarf-topic xml-data) - ;; Call alert hooks only when something is output - (when (or error-p - (run-hook-with-args-until-success 'printers xml-data type :printp)) - (jabber-maybe-print-rare-time - (ewoc-enter-last jabber-chat-ewoc (list type xml-data :time (current-time)))) - - ;; ...except if the message is part of history, in which - ;; case we don't want an alert. - (let ((children-namespaces (mapcar (lambda (x) (when (listp x) (jabber-xml-get-attribute x 'xmlns))) - (jabber-xml-node-children xml-data)))) - (unless (or (member "urn:xmpp:delay" children-namespaces) - (member "jabber:x:delay" children-namespaces)) - (dolist (hook '(jabber-muc-hooks jabber-alert-muc-hooks)) - (run-hook-with-args hook - nick group (current-buffer) body-text - (funcall jabber-alert-muc-function - nick group (current-buffer) body-text)))))))))) - -(defun jabber-muc-process-presence (jc presence) - (let* ((from (jabber-xml-get-attribute presence 'from)) - (type (jabber-xml-get-attribute presence 'type)) - (x-muc (find-if - (lambda (x) (equal (jabber-xml-get-attribute x 'xmlns) - "http://jabber.org/protocol/muc#user")) - (jabber-xml-get-children presence 'x))) - (group (jabber-jid-user from)) - (nickname (jabber-jid-resource from)) - (symbol (jabber-jid-symbol from)) - (our-nickname (gethash symbol jabber-pending-groupchats)) - (item (car (jabber-xml-get-children x-muc 'item))) - (actor (jabber-xml-get-attribute (car (jabber-xml-get-children item 'actor)) 'jid)) - (reason (car (jabber-xml-node-children (car (jabber-xml-get-children item 'reason))))) - (error-node (car (jabber-xml-get-children presence 'error))) - (status-codes (if error-node - (list (jabber-xml-get-attribute error-node 'code)) - (mapcar - (lambda (status-element) - (jabber-xml-get-attribute status-element 'code)) - (jabber-xml-get-children x-muc 'status))))) - ;; handle leaving a room - (cond - ((or (string= type "unavailable") (string= type "error")) - ;; error from room itself? or are we leaving? - (if (or (null nickname) - (member "110" status-codes) - (string= nickname our-nickname)) - ;; Assume that an error means that we were thrown out of the - ;; room... - (let* ((leavingp t) - (message (cond - ((string= type "error") - (cond - ;; ...except for certain cases. - ((or (member "406" status-codes) - (member "409" status-codes)) - (setq leavingp nil) - (concat "Nickname change not allowed" - (when error-node - (concat ": " (jabber-parse-error error-node))))) - (t - (concat "Error entering room" - (when error-node - (concat ": " (jabber-parse-error error-node))))))) - ((member "301" status-codes) - (concat "You have been banned" - (when actor (concat " by " actor)) - (when reason (concat " - '" reason "'")))) - ((member "307" status-codes) - (concat "You have been kicked" - (when actor (concat " by " actor)) - (when reason (concat " - '" reason "'")))) - (t - "You have left the chatroom")))) - (when leavingp - (jabber-muc-remove-groupchat group)) - ;; If there is no buffer for this groupchat, don't bother - ;; creating one just to tell that user left the room. - (let ((buffer (get-buffer (jabber-muc-get-buffer group)))) - (if buffer - (with-current-buffer buffer - (jabber-maybe-print-rare-time - (ewoc-enter-last jabber-chat-ewoc - (list (if (string= type "error") - :muc-error - :muc-notice) - message - :time (current-time))))) - (message "%s: %s" (jabber-jid-displayname group) message)))) - ;; or someone else? - (let* ((plist (jabber-muc-participant-plist group nickname)) - (jid (plist-get plist 'jid)) - (name (concat nickname - (when jid - (concat " <" - (jabber-jid-user jid) - ">"))))) - (jabber-muc-remove-participant group nickname) - (with-current-buffer (jabber-muc-create-buffer jc group) - (jabber-maybe-print-rare-time - (ewoc-enter-last - jabber-chat-ewoc - (list :muc-notice - (cond - ((member "301" status-codes) - (concat name " has been banned" - (when actor (concat " by " actor)) - (when reason (concat " - '" reason "'")))) - ((member "307" status-codes) - (concat name " has been kicked" - (when actor (concat " by " actor)) - (when reason (concat " - '" reason "'")))) - ((member "303" status-codes) - (concat name " changes nickname to " - (jabber-xml-get-attribute item 'nick))) - (t - (concat name " has left the chatroom"))) - :time (current-time)))))))) - (t - ;; someone is entering - - (when (or (member "110" status-codes) (string= nickname our-nickname)) - ;; This is us. We just succeeded in entering the room. - ;; - ;; The MUC server is supposed to send a 110 code whenever this - ;; is our presence ("self-presence"), but at least one - ;; (ejabberd's mod_irc) doesn't, so check the nickname as well. - ;; - ;; This check might give incorrect results if the server - ;; changed our nickname to avoid collision with an existing - ;; participant, but even in this case the window where we have - ;; incorrect information should be very small, as we should be - ;; getting our own 110+210 presence shortly. - (let ((whichgroup (assoc group *jabber-active-groupchats*))) - (if whichgroup - (setcdr whichgroup nickname) - (add-to-list '*jabber-active-groupchats* (cons group nickname)))) - ;; The server may have changed our nick. Record the new one. - (puthash symbol nickname jabber-pending-groupchats)) - - ;; Whoever enters, we create a buffer (if it didn't already - ;; exist), and print a notice. This is where autojoined MUC - ;; rooms have buffers created for them. We also remember some - ;; metadata. - (let ((old-plist (jabber-muc-participant-plist group nickname)) - (new-plist (jabber-muc-parse-affiliation x-muc))) - (jabber-muc-modify-participant group nickname new-plist) - (let ((report (jabber-muc-report-delta nickname old-plist new-plist - reason actor))) - (when report - (with-current-buffer (jabber-muc-create-buffer jc group) - (jabber-maybe-print-rare-time - (ewoc-enter-last - jabber-chat-ewoc - (list :muc-notice report - :time (current-time)))) - ;; Did the server change our nick? - (when (member "210" status-codes) - (ewoc-enter-last - jabber-chat-ewoc - (list :muc-notice - (concat "Your nick was changed to " nickname " by the server") - :time (current-time)))) - ;; Was this room just created? If so, it's a locked - ;; room. Notify the user. - (when (member "201" status-codes) - (ewoc-enter-last - jabber-chat-ewoc - (list :muc-notice - (with-temp-buffer - (insert "This room was just created, and is locked to other participants.\n" - "To unlock it, ") - (insert-text-button - "configure the room" - 'action (apply-partially 'call-interactively 'jabber-muc-get-config)) - (insert " or ") - (insert-text-button - "accept the default configuration" - 'action (apply-partially 'call-interactively 'jabber-muc-instant-config)) - (insert ".") - (buffer-string)) - :time (current-time)))))))))))) - -(defcustom jabber-muc-completion-delimiter ": " - "String to add to end of completion line." - :type 'string - :group 'jabber-chat) - -(defcustom jabber-muc-looks-personaling-symbols '("," ":" ">") - "Symbols for personaling messages." - :type '(repeat string) - :group 'jabber-chat) - -(defcustom jabber-muc-personal-message-bonus (* 60 20) - "Bonus for personal message, in seconds." - :type 'integer - :group 'jabber-chat) - -(defcustom jabber-muc-all-string "all" - "String meaning all conference members (to insert in completion). -Note that \":\" or alike not needed (it appended in other string)" - :type 'string - :group 'jabber-chat) - -;;; History: -;; - -;;; Code: - -(require 'cl) -(require 'hippie-exp) - -(defvar *jabber-muc-participant-last-speaking* nil - "Global alist in form (group . ((member . time-of-last-speaking) ...) ...).") - -(defun jabber-my-nick (&optional group) - "Return my jabber nick in GROUP." - (let ((room (or group jabber-group))) - (cdr (or (assoc room *jabber-active-groupchats*) - (assoc room jabber-muc-default-nicknames))) - )) - -;;;###autoload -(defun jabber-muc-looks-like-personal-p (message &optional group) - "Return non-nil if jabber MESSAGE is addresed to me. -Optional argument GROUP to look." - (if message (string-match (concat - "^" - (jabber-my-nick group) - (regexp-opt jabber-muc-looks-personaling-symbols)) - message) - nil)) - -(defun jabber-muc-nicknames () - "List of conference participants, excluding self, or nil if we not in conference." - (delete-if '(lambda (nick) - (string= nick (jabber-my-nick))) - (append (mapcar 'car (cdr (assoc jabber-group jabber-muc-participants))) (list jabber-muc-all-string)))) - -(defun jabber-muc-participant-update-activity (group nick time) - "Update NICK's time of last speaking in GROUP to TIME." - (let* ((room (assoc group *jabber-muc-participant-last-speaking*)) - (room-activity (cdr room)) - (entry (assoc nick room-activity)) - (old-time (or (cdr entry) 0))) - (when (> time old-time) - ;; don't use put-alist for speed - (progn - (if entry (setcdr entry time) - (setq room-activity - (cons (cons nick time) room-activity))) - (if room (setcdr room room-activity) - (setq *jabber-muc-participant-last-speaking* - (cons (cons group room-activity) - *jabber-muc-participant-last-speaking*))))))) - -(defun jabber-muc-track-message-time (nick group buffer text &optional title) - "Tracks time of NICK's last speaking in GROUP." - (when nick - (let ((time (float-time))) - (jabber-muc-participant-update-activity - group - nick - (if (jabber-muc-looks-like-personal-p text group) - (+ time jabber-muc-personal-message-bonus) - time))))) - -(defun jabber-sort-nicks (nicks group) - "Return list of NICKS in GROUP, sorted." - (let ((times (cdr (assoc group *jabber-muc-participant-last-speaking*)))) - (flet ((fetch-time (nick) (or (assoc nick times) (cons nick 0))) - (cmp (nt1 nt2) - (let ((t1 (cdr nt1)) - (t2 (cdr nt2))) - (if (and (zerop t1) (zerop t2)) - (string< - (car nt1) - (car nt2)) - (> t1 t2))))) - (mapcar 'car (sort (mapcar 'fetch-time nicks) - 'cmp))))) - -(defun jabber-muc-beginning-of-line () - "Return position of line begining." - (save-excursion - (if (looking-back jabber-muc-completion-delimiter) - (backward-char (+ (length jabber-muc-completion-delimiter) 1))) - (skip-syntax-backward "^-") - (point))) - -;;; One big hack: -(defun jabber-muc-completion-delete-last-tried () - "Delete last tried competion variand from line." - (let ((last-tried (car he-tried-table))) - (when last-tried - (goto-char he-string-beg) - (delete-char (length last-tried)) - (ignore-errors (delete-char (length jabber-muc-completion-delimiter))) - ))) - -(defun try-expand-jabber-muc (old) - "Try to expand target nick in MUC according to last speaking time. -OLD is last tried nickname." - (unless jabber-chatting-with - (unless old - (let ((nicknames (jabber-muc-nicknames))) - (he-init-string (jabber-muc-beginning-of-line) (point)) - (setq he-expand-list (jabber-sort-nicks (all-completions he-search-string (mapcar 'list nicknames)) jabber-group)))) - - (setq he-expand-list - (delete-if '(lambda (x) - (he-string-member x he-tried-table)) - he-expand-list)) - (if (null he-expand-list) - (progn - (when old - ;; here and later : its hack to workaround - ;; he-substitute-string work which cant substitute empty - ;; lines - (if (string= he-search-string "") - (jabber-muc-completion-delete-last-tried) - (he-reset-string))) - ()) - (let ((subst (if (eq (line-beginning-position) (jabber-muc-beginning-of-line)) - (concat (car he-expand-list) jabber-muc-completion-delimiter) - (car he-expand-list)))) - (if (not (string= he-search-string "")) - (he-substitute-string subst) - (jabber-muc-completion-delete-last-tried) - (progn - (insert subst) - (if (looking-back (concat "^" (regexp-quote (car he-expand-list)))) - (unless (looking-back (concat "^" (regexp-quote (car he-expand-list)) jabber-muc-completion-delimiter)) - (insert jabber-muc-completion-delimiter))) - ) - )) - (setq he-tried-table (cons (car he-expand-list) (cdr he-tried-table))) - (setq he-expand-list (cdr he-expand-list)) - t))) - -(add-hook 'jabber-muc-hooks 'jabber-muc-track-message-time) -(fset 'jabber-muc-completion (make-hippie-expand-function '(try-expand-jabber-muc))) -(define-key jabber-chat-mode-map [?\t] 'jabber-muc-completion) - -(add-to-list 'jabber-jid-service-menu - (cons "Register with service" 'jabber-get-register)) -(defun jabber-get-register (jc to) - "Send IQ get request in namespace \"jabber:iq:register\". - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Register with: "))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:register"))) - #'jabber-process-data #'jabber-process-register-or-search - #'jabber-report-success "Registration")) - -(defun jabber-process-register-or-search (jc xml-data) - "Display results from jabber:iq:{register,search} query as a form. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let ((query (jabber-iq-query xml-data)) - (have-xdata nil) - (type (cond - ((string= (jabber-iq-xmlns xml-data) "jabber:iq:register") - 'register) - ((string= (jabber-iq-xmlns xml-data) "jabber:iq:search") - 'search) - (t - (error "Namespace %s not handled by jabber-process-register-or-search" (jabber-iq-xmlns xml-data))))) - (register-account - (plist-get (fsm-get-state-data jc) :registerp)) - (username - (plist-get (fsm-get-state-data jc) :username)) - (server - (plist-get (fsm-get-state-data jc) :server))) - - (cond - ((eq type 'register) - ;; If there is no `from' attribute, we are registering with the server - (jabber-init-widget-buffer (or (jabber-xml-get-attribute xml-data 'from) - server))) - - ((eq type 'search) - ;; no such thing here - (jabber-init-widget-buffer (jabber-xml-get-attribute xml-data 'from)))) - - (setq jabber-buffer-connection jc) - - (widget-insert (if (eq type 'register) "Register with " "Search ") jabber-submit-to "\n\n") - - (dolist (x (jabber-xml-get-children query 'x)) - (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") - (setq have-xdata t) - ;; If the registration form obeys XEP-0068, we know - ;; for sure how to put a default username in it. - (jabber-render-xdata-form x - (if (and register-account - (string= (jabber-xdata-formtype x) "jabber:iq:register")) - (list (cons "username" username)) - nil)))) - (if (not have-xdata) - (jabber-render-register-form query - (when register-account - username))) - - (widget-create 'push-button :notify (if (eq type 'register) - #'jabber-submit-register - #'jabber-submit-search) "Submit") - (when (eq type 'register) - (widget-insert "\t") - (widget-create 'push-button :notify #'jabber-remove-register "Cancel registration")) - (widget-insert "\n") - (widget-setup) - (widget-minor-mode 1))) - -(defun jabber-submit-register (&rest ignore) - "Submit registration input. See `jabber-process-register-or-search'." - - (let* ((registerp (plist-get (fsm-get-state-data jabber-buffer-connection) :registerp)) - (handler (if registerp - #'jabber-process-register-secondtime - #'jabber-report-success)) - (text (concat "Registration with " jabber-submit-to))) - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - - (cond - ((eq jabber-form-type 'register) - `(query ((xmlns . "jabber:iq:register")) - ,@(jabber-parse-register-form))) - ((eq jabber-form-type 'xdata) - `(query ((xmlns . "jabber:iq:register")) - ,(jabber-parse-xdata-form))) - (t - (error "Unknown form type: %s" jabber-form-type))) - handler (if registerp 'success text) - handler (if registerp 'failure text))) - - (message "Registration sent")) - -(defun jabber-process-register-secondtime (jc xml-data closure-data) - "Receive registration success or failure. -CLOSURE-DATA is either 'success or 'error. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (cond - ((eq closure-data 'success) - (message "Registration successful. You may now connect to the server.")) - (t - (jabber-report-success jc xml-data "Account registration"))) - (sit-for 3) - (jabber-disconnect-one jc)) - -(defun jabber-remove-register (&rest ignore) - "Cancel registration. See `jabber-process-register-or-search'." - - (if (or jabber-silent-mode (yes-or-no-p (concat "Are you sure that you want to cancel your registration to " jabber-submit-to "? "))) - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - '(query ((xmlns . "jabber:iq:register")) - (remove)) - #'jabber-report-success "Unregistration" - #'jabber-report-success "Unregistration"))) - -(add-to-list 'jabber-jid-service-menu - (cons "Search directory" 'jabber-get-search)) -(defun jabber-get-search (jc to) - "Send IQ get request in namespace \"jabber:iq:search\". - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Search what database: "))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:search"))) - #'jabber-process-data #'jabber-process-register-or-search - #'jabber-report-success "Search field retrieval")) - -(defun jabber-submit-search (&rest ignore) - "Submit search. See `jabber-process-register-or-search'." - - (let ((text (concat "Search at " jabber-submit-to))) - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - - (cond - ((eq jabber-form-type 'register) - `(query ((xmlns . "jabber:iq:search")) - ,@(jabber-parse-register-form))) - ((eq jabber-form-type 'xdata) - `(query ((xmlns . "jabber:iq:search")) - ,(jabber-parse-xdata-form))) - (t - (error "Unknown form type: %s" jabber-form-type))) - #'jabber-process-data #'jabber-process-search-result - #'jabber-report-success text)) - - (message "Search sent")) - -(defun jabber-process-search-result (jc xml-data) - "Receive and display search results. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - ;; This function assumes that all search results come in one packet, - ;; which is not necessarily the case. - (let ((query (jabber-iq-query xml-data)) - (have-xdata nil) - xdata fields (jid-fields 0)) - - ;; First, check for results in jabber:x:data form. - (dolist (x (jabber-xml-get-children query 'x)) - (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") - (setq have-xdata t) - (setq xdata x))) - - (if have-xdata - (jabber-render-xdata-search-results xdata) - - (insert (jabber-propertize "Search results" 'face 'jabber-title-medium) "\n") - - (setq fields '((first . (label "First name" column 0)) - (last . (label "Last name" column 15)) - (nick . (label "Nickname" column 30)) - (jid . (label "JID" column 45)) - (email . (label "E-mail" column 65)))) - (setq jid-fields 1) - - (dolist (field-cons fields) - (indent-to (plist-get (cdr field-cons) 'column) 1) - (insert (jabber-propertize (plist-get (cdr field-cons) 'label) 'face 'bold))) - (insert "\n\n") - - ;; Now, the items - (dolist (item (jabber-xml-get-children query 'item)) - (let ((start-of-line (point)) - jid) - - (dolist (field-cons fields) - (let ((field-plist (cdr field-cons)) - (value (if (eq (car field-cons) 'jid) - (setq jid (jabber-xml-get-attribute item 'jid)) - (car (jabber-xml-node-children (car (jabber-xml-get-children item (car field-cons)))))))) - (indent-to (plist-get field-plist 'column) 1) - (if value (insert value)))) - - (if jid - (put-text-property start-of-line (point) - 'jabber-jid jid)) - (insert "\n")))))) - -(add-to-list 'jabber-jid-info-menu - (cons "Send browse query" 'jabber-get-browse)) -(defun jabber-get-browse (jc to) - "Send a browse infoquery request to someone. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "browse: " nil nil nil nil t))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:browse"))) - #'jabber-process-data #'jabber-process-browse - #'jabber-process-data "Browse failed")) - -;; called from jabber-process-data -(defun jabber-process-browse (jc xml-data) - "Handle results from jabber:iq:browse requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (dolist (item (jabber-xml-node-children xml-data)) - (when (and (listp item) - (not (eq (jabber-xml-node-name item) 'ns))) - (let ((jid (jabber-xml-get-attribute item 'jid)) - (beginning (point))) - (cond - ((or - (eq (jabber-xml-node-name item) 'user) - (string= (jabber-xml-get-attribute item 'category) "user")) - (insert (jabber-propertize "$ USER" - 'face 'jabber-title-medium) - "\n\n")) - ((or - (eq (jabber-xml-node-name item) 'service) - (string= (jabber-xml-get-attribute item 'category) "service")) - (insert (jabber-propertize "* SERVICE" - 'face 'jabber-title-medium) - "\n\n")) - ((or - (eq (jabber-xml-node-name item) 'conference) - (string= (jabber-xml-get-attribute item 'category) "conference")) - (insert (jabber-propertize "@ CONFERENCE" - 'face 'jabber-title-medium) - "\n\n")) - (t - ;; So far I've seen "server" and "directory", both in the node-name. - ;; Those are actually service disco categories, but jabberd 2 seems - ;; to use them for browse results as well. It's not right (as in - ;; XEP-0011), but it's reasonable. - (let ((category (jabber-xml-get-attribute item 'category))) - (if (= (length category) 0) - (setq category (jabber-xml-node-name item))) - (insert (jabber-propertize (format "! OTHER: %s" category) - 'face 'jabber-title-medium) - "\n\n")))) - (dolist (attr '((type . "Type:\t\t") - (jid . "JID:\t\t") - (name . "Name:\t\t") - (version . "Version:\t"))) - (let ((data (jabber-xml-get-attribute item (car attr)))) - (if (> (length data) 0) - (insert (cdr attr) data "\n")))) - - (dolist (ns (jabber-xml-get-children item 'ns)) - (if (stringp (car (jabber-xml-node-children ns))) - (insert "Namespace:\t" (car (jabber-xml-node-children ns)) "\n"))) - - (insert "\n") - (put-text-property beginning (point) 'jabber-jid jid) - (put-text-property beginning (point) 'jabber-account jc) - - ;; XXX: Is this kind of recursion really needed? - (if (listp (car (jabber-xml-node-children item))) - (jabber-process-browse jc item)))))) - -(require 'jabber-ourversion) - -(defcustom jabber-version-show t - "Show our client version to others. Acts on loading." - :type 'boolean - :group 'jabber) - -(add-to-list 'jabber-jid-info-menu - (cons "Request software version" 'jabber-get-version)) -(defun jabber-get-version (jc to) - "Request software version. - -JC is the Jabber connection." - (interactive (list - (jabber-read-account) - (jabber-read-jid-completing "Request version of: " nil nil nil 'full t))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:version"))) - #'jabber-process-data #'jabber-process-version - #'jabber-process-data "Version request failed")) - -;; called by jabber-process-data -(defun jabber-process-version (jc xml-data) - "Handle results from jabber:iq:version requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let ((query (jabber-iq-query xml-data))) - (dolist (x '((name . "Name:\t\t") (version . "Version:\t") (os . "OS:\t\t"))) - (let ((data (car (jabber-xml-node-children (car (jabber-xml-get-children query (car x))))))) - (when data - (insert (cdr x) data "\n")))))) - -(if jabber-version-show - (and - (add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:version" 'jabber-return-version)) - (jabber-disco-advertise-feature "jabber:iq:version"))) - -(defun jabber-return-version (jc xml-data) - "Return client version as defined in XEP-0092. -Sender and ID are determined from the incoming packet passed in XML-DATA. - -JC is the Jabber connection." - ;; Things we might check: does this iq message really have type='get' and - ;; exactly one child, namely query with xmlns='jabber:iq:version'? - ;; Then again, jabber-process-iq should take care of that. - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id)) - (os (format "%s %d.%d (%s)" - (cond ((featurep 'xemacs) "XEmacs") - (t "Emacs")) - emacs-major-version emacs-minor-version - system-type))) - (jabber-send-iq jc to "result" - `(query ((xmlns . "jabber:iq:version")) - (name () "jabber.el") - (version () ,jabber-version) - ;; Booting... /vmemacs.el - ;; Shamelessly stolen from someone's sig. - (os () ,os)) - nil nil nil nil - id))) - -(defvar jabber-ahc-sessionid nil - "Session ID of Ad-Hoc Command session.") - -(defvar jabber-ahc-node nil - "Node to send commands to.") - -(defvar jabber-ahc-commands nil - "Commands provided. - -This is an alist, where the keys are node names as strings (which -means that they must not conflict). The values are plists having -following properties: - -acl - function taking connection object and JID of requester, - returning non-nil for access allowed. No function means - open for everyone. -name - name of command -func - function taking connection object and entire IQ stanza as - arguments and returning a node - -Use the function `jabber-ahc-add' to add a command to this list.") - -(add-to-list 'jabber-disco-info-nodes - (list "http://jabber.org/protocol/commands" - '((identity ((category . "automation") - (type . "command-list") - (name . "Ad-Hoc Command list"))) - (feature ((var . "http://jabber.org/protocol/commands"))) - (feature ((var . "http://jabber.org/protocol/disco#items"))) - (feature - ((var . "http://jabber.org/protocol/disco#info")))))) - -(defun jabber-ahc-add (node name func acl) - "Add a command to internal lists. -NODE is the node name to be used. It must be unique. -NAME is the natural-language name of the command. -FUNC is a function taking the entire IQ stanza as single argument when -this command is invoked, and returns a node. -ACL is a function taking JID as single argument, returning non-nil for -access allowed. nil means open for everyone." - (add-to-list 'jabber-ahc-commands (cons node (list 'name name - 'func func - 'acl acl))) - (add-to-list 'jabber-disco-info-nodes - (list node `((identity ((category . "automation") - (type . "command-node") - (name . ,name))) - (feature ((var . "http://jabber.org/protocol/commands"))) - (feature ((var . "http://jabber.org/protocol/disco#info"))) - (feature ((var . "jabber:x:data"))))))) - -(jabber-disco-advertise-feature "http://jabber.org/protocol/commands") -(add-to-list 'jabber-disco-items-nodes - (list "http://jabber.org/protocol/commands" #'jabber-ahc-disco-items nil)) -(defun jabber-ahc-disco-items (jc xml-data) - "Return commands in response to disco#items request. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((jid (jabber-xml-get-attribute xml-data 'from))) - (mapcar (function - (lambda (command) - (let ((node (car command)) - (plist (cdr command))) - (let ((acl (plist-get plist 'acl)) - (name (plist-get plist 'name)) - (func (plist-get plist 'func))) - (when (or (not (functionp acl)) - (funcall acl jc jid)) - `(item ((name . ,name) - (jid . ,(jabber-connection-jid jc)) - (node . ,node)))))))) - jabber-ahc-commands))) - -(add-to-list 'jabber-iq-set-xmlns-alist - (cons "http://jabber.org/protocol/commands" 'jabber-ahc-process)) -(defun jabber-ahc-process (jc xml-data) - - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id)) - (node (jabber-xml-get-attribute (jabber-iq-query xml-data) 'node))) - ;; find command - (let* ((plist (cdr (assoc node jabber-ahc-commands))) - (acl (plist-get plist 'acl)) - (func (plist-get plist 'func))) - (if plist - ;; found - (if (or (not (functionp acl)) - (funcall acl jc to)) - ;; access control passed - (jabber-send-iq jc to "result" - (funcall func jc xml-data) - nil nil nil nil id) - ;; ...or failed - (jabber-signal-error "Cancel" 'not-allowed)) - ;; No such node - (jabber-signal-error "Cancel" 'item-not-found))))) - -(add-to-list 'jabber-jid-service-menu - (cons "Request command list" 'jabber-ahc-get-list)) -(defun jabber-ahc-get-list (jc to) - "Request list of ad-hoc commands. - -See XEP-0050. -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Request command list from: " nil nil nil nil nil))) - (jabber-get-disco-items jc to "http://jabber.org/protocol/commands")) - -(add-to-list 'jabber-jid-service-menu - (cons "Execute command" 'jabber-ahc-execute-command)) -(defun jabber-ahc-execute-command (jc to node) - "Execute ad-hoc command. - -See XEP-0050. -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Execute command of: " nil nil nil nil nil) - (jabber-read-node "Node of command: "))) - (jabber-send-iq jc to - "set" - `(command ((xmlns . "http://jabber.org/protocol/commands") - (node . ,node) - (action . "execute"))) - #'jabber-process-data #'jabber-ahc-display - #'jabber-process-data "Command execution failed")) - -(defun jabber-ahc-display (jc xml-data) - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (query (jabber-iq-query xml-data)) - (node (jabber-xml-get-attribute query 'node)) - (notes (jabber-xml-get-children query 'note)) - (sessionid (jabber-xml-get-attribute query 'sessionid)) - (status (jabber-xml-get-attribute query 'status)) - (actions (car (jabber-xml-get-children query 'actions))) - xdata - (inhibit-read-only t)) - - (make-local-variable 'jabber-ahc-sessionid) - (setq jabber-ahc-sessionid sessionid) - (make-local-variable 'jabber-ahc-node) - (setq jabber-ahc-node node) - (make-local-variable 'jabber-buffer-connection) - (setq jabber-buffer-connection jc) - - (dolist (x (jabber-xml-get-children query 'x)) - (when (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:data") - (setq xdata x))) - - (cond - ((string= status "executing") - (insert "Executing command\n\n")) - ((string= status "completed") - (insert "Command completed\n\n")) - ((string= status "canceled") - (insert "Command canceled\n\n"))) - - (dolist (note notes) - (let ((note-type (jabber-xml-get-attribute note 'type))) - (cond - ((string= note-type "warn") - (insert "Warning: ")) - ((string= note-type "error") - (insert "Error: "))) - (insert (car (jabber-xml-node-children note)) "\n"))) - (insert "\n") - - (when xdata - (jabber-init-widget-buffer from) - - (let ((formtype (jabber-xml-get-attribute xdata 'type))) - (if (string= formtype "result") - (jabber-render-xdata-search-results xdata) - (jabber-render-xdata-form xdata) - - (when (string= status "executing") - (let ((button-titles - (cond - ((null actions) - '(complete cancel)) - (t - (let ((children (mapcar #'jabber-xml-node-name (jabber-xml-node-children actions))) - (default-action (jabber-xml-get-attribute actions 'execute))) - (if (or (null default-action) (memq (intern default-action) children)) - children - (cons (intern default-action) children))))))) - (dolist (button-title button-titles) - (widget-create 'push-button :notify `(lambda (&rest ignore) (jabber-ahc-submit (quote ,button-title))) (symbol-name button-title)) - (widget-insert "\t"))) - (widget-insert "\n")))) - - (widget-setup) - (widget-minor-mode 1)))) - -(defun jabber-ahc-submit (action) - "Submit Ad-Hoc Command." - - (jabber-send-iq jabber-buffer-connection jabber-submit-to - "set" - `(command ((xmlns . "http://jabber.org/protocol/commands") - (sessionid . ,jabber-ahc-sessionid) - (node . ,jabber-ahc-node) - (action . ,(symbol-name action))) - ,(if (and (not (eq action 'cancel)) - (eq jabber-form-type 'xdata)) - (jabber-parse-xdata-form))) - - #'jabber-process-data #'jabber-ahc-display - #'jabber-process-data "Command execution failed")) - -(defconst jabber-ahc-presence-node "http://jabber.org/protocol/rc#set-status" - "Node used by function `jabber-ahc-presence'.") - -(jabber-ahc-add jabber-ahc-presence-node "Set presence" 'jabber-ahc-presence - 'jabber-my-jid-p) - -(defun jabber-ahc-presence (jc xml-data) - "Process presence change command. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - - (let* ((query (jabber-iq-query xml-data)) - (sessionid (jabber-xml-get-attribute query 'sessionid)) - (action (jabber-xml-get-attribute query 'action))) - ;; No session state is kept; instead, lack of session-id is used - ;; as indication of first command. - (cond - ;; command cancelled - ((string= action "cancel") - `(command ((xmlns . "http://jabber.org/protocol/commands") - (sessionid . ,sessionid) - (node . ,jabber-ahc-presence-node) - (status . "canceled")))) - ;; return form - ((null sessionid) - `(command ((xmlns . "http://jabber.org/protocol/commands") - (sessionid . "jabber-ahc-presence") - (node . ,jabber-ahc-presence-node) - (status . "executing")) - (x ((xmlns . "jabber:x:data") - (type . "form")) - (title nil ,(format "Set presence of %s" (jabber-connection-jid jc))) - (instructions nil "Select new presence status.") - (field ((var . "FORM_TYPE") (type . "hidden")) - (value nil "http://jabber.org/protocol/rc")) - (field ((var . "status") - (label . "Status") - (type . "list-single")) - (value nil ,(if (string= *jabber-current-show* "") - "online" - *jabber-current-show*)) - (option ((label . "Online")) (value nil "online")) - (option ((label . "Chatty")) (value nil "chat")) - (option ((label . "Away")) (value nil "away")) - (option ((label . "Extended away")) (value nil "xa")) - (option ((label . "Do not disturb")) (value nil "dnd"))) - (field ((var . "status-message") - (label . "Message") - (type . "text-single")) - (value nil ,*jabber-current-status*)) - (field ((var . "status-priority") - (label . "Priority") - (type . "text-single")) - (value nil ,(int-to-string *jabber-current-priority*)))))) - ;; process form - (t - (let* ((x (car (jabber-xml-get-children query 'x))) - ;; we assume that the first is the jabber:x:data one - (fields (jabber-xml-get-children x 'field)) - (new-show *jabber-current-show*) - (new-status *jabber-current-status*) - (new-priority *jabber-current-priority*)) - (dolist (field fields) - (let ((var (jabber-xml-get-attribute field 'var)) - ;; notice that multi-value fields won't be handled properly - ;; by this - (value (car (jabber-xml-node-children (car (jabber-xml-get-children field 'value)))))) - (cond - ((string= var "status") - (setq new-show (if (string= value "online") - "" - value))) - ((string= var "status-message") - (setq new-status value)) - ((string= var "status-priority") - (setq new-priority (string-to-number value)))))) - (jabber-send-presence new-show new-status new-priority)) - `(command ((xmlns . "http://jabber.org/protocol/commands") - (sessionid . ,sessionid) - (node . ,jabber-ahc-presence-node) - (status . "completed")) - (note ((type . "info")) "Presence has been changed.")))))) - -(eval-when-compile (require 'cl)) - -(defgroup jabber-mode-line nil - "Display Jabber status in mode line" - :group 'jabber) - -(defcustom jabber-mode-line-compact t - "Count contacts in fewer categories for compact view." - :group 'jabber-mode-line - :type 'boolean) - -(defvar jabber-mode-line-string nil) - -(defvar jabber-mode-line-presence nil) - -(defvar jabber-mode-line-contacts nil) - -(defadvice jabber-send-presence (after jsp-update-mode-line - (show status priority)) - (jabber-mode-line-presence-update)) - -(defun jabber-mode-line-presence-update () - (setq jabber-mode-line-presence (if (and jabber-connections (not *jabber-disconnecting*)) - (cdr (assoc *jabber-current-show* jabber-presence-strings)) - "Offline"))) - -(defun jabber-mode-line-count-contacts (&rest ignore) - (let ((count (list (cons "chat" 0) - (cons "" 0) - (cons "away" 0) - (cons "xa" 0) - (cons "dnd" 0) - (cons nil 0)))) - (dolist (jc jabber-connections) - (dolist (buddy (plist-get (fsm-get-state-data jc) :roster)) - (when (assoc (get buddy 'show) count) - (incf (cdr (assoc (get buddy 'show) count)))))) - (setq jabber-mode-line-contacts - (if jabber-mode-line-compact - (format "(%d/%d/%d)" - (+ (cdr (assoc "chat" count)) - (cdr (assoc "" count))) - (+ (cdr (assoc "away" count)) - (cdr (assoc "xa" count)) - (cdr (assoc "dnd" count))) - (cdr (assoc nil count))) - (apply 'format "(%d/%d/%d/%d/%d/%d)" - (mapcar 'cdr count)))))) - -(define-minor-mode jabber-mode-line-mode - "Toggle display of Jabber status in mode lines. -Display consists of your own status, and six numbers -meaning the number of chatty, online, away, xa, dnd -and offline contacts, respectively." - :global t :group 'jabber-mode-line - (setq jabber-mode-line-string "") - (or global-mode-string (setq global-mode-string '(""))) - (if jabber-mode-line-mode - (progn - (add-to-list 'global-mode-string 'jabber-mode-line-string t) - - (setq jabber-mode-line-string (list " " - 'jabber-mode-line-presence - " " - 'jabber-mode-line-contacts)) - (put 'jabber-mode-line-string 'risky-local-variable t) - (put 'jabber-mode-line-presence 'risky-local-variable t) - (jabber-mode-line-presence-update) - (jabber-mode-line-count-contacts) - (ad-activate 'jabber-send-presence) - (add-hook 'jabber-post-disconnect-hook - 'jabber-mode-line-presence-update) - (add-hook 'jabber-presence-hooks - 'jabber-mode-line-count-contacts)))) - -(defun jabber-presence-watch (who oldstatus newstatus - statustext proposed-alert) - "Send a message if one of your extra-important buddies comes online. -The buddies are stored in `jabber-watch-alist' and are added and removed by -calling `jabber-watch-add' and `jabber-watch-remove'." - ;; check that buddy was previously offline and now online - (if (and (null oldstatus) - (not (null newstatus))) - (let ((entry (assq who jabber-watch-alist))) - (when entry - ;; Give an intrusive message. With a window system, - ;; that's easy. - (if window-system - (message-box "%s%s" proposed-alert - (if (cdr entry) (format ": %s" (cdr entry)) "")) - ;; Without a window system, yes-or-no-p should be - ;; sufficient. - (while (not - (yes-or-no-p (format "%s%s Got that? " proposed-alert - (if (cdr entry) (format ": %s" (cdr entry)) "")))))))))) - -(defun jabber-watch-add (buddy &optional comment) - (interactive (list (jabber-read-jid-completing "Add buddy to watch list: ") - (read-string "Comment: "))) - (unless (memq 'jabber-presence-watch jabber-presence-hooks) - (error "The jabber-presence-watch function is not in jabber-presence-hooks")) - (add-to-list 'jabber-watch-alist (cons - (jabber-jid-symbol buddy) - (and (not (zerop (length comment))) - comment)))) - -(defun jabber-watch-remove (buddy) - (interactive - (list (jabber-read-jid-completing "Remove buddy from watch list: " - (or (mapcar 'car jabber-watch-alist) - (error "Watch list is empty")) - t))) - (setq jabber-watch-alist - (delq (assq (jabber-jid-symbol buddy) jabber-watch-alist) - jabber-watch-alist))) - -(require 'cl) - -(defgroup jabber-activity nil - "Activity tracking options." - :group 'jabber) - -(defcustom jabber-activity-make-string 'jabber-activity-make-string-default - "Function to call to show a string in the modeline. -Function to call, for making the string to put in the mode -line. The default function returns the nick of the user." - :set #'(lambda (var val) - (custom-set-default var val) - (when (and (featurep 'jabber-activity) - (fboundp 'jabber-activity-make-name-alist)) - (jabber-activity-make-name-alist) - (jabber-activity-mode-line-update))) - :type 'function - :group 'jabber-activity) - -(defcustom jabber-activity-shorten-minimum 1 - "Length of the strings returned by `jabber-activity-make-strings-shorten'. -All strings returned by `jabber-activity-make-strings-shorten' will be -at least this long, when possible." - :group 'jabber-activity - :type 'number) - -(defcustom jabber-activity-make-strings 'jabber-activity-make-strings-default - "Function which should return an alist of JID -> string given a list of JIDs." - :set #'(lambda (var val) - (custom-set-default var val) - (when (and (featurep 'jabber-activity) - (fboundp 'jabber-activity-make-name-alist)) - (jabber-activity-make-name-alist) - (jabber-activity-mode-line-update))) - :type '(choice (function-item :tag "Keep strings" - :value jabber-activity-make-strings-default) - (function-item :tag "Shorten strings" - :value jabber-activity-make-strings-shorten) - (function :tag "Other function")) - :group 'jabber-activity) - -(defcustom jabber-activity-count-in-title nil - "If non-nil, display number of active JIDs in frame title." - :type 'boolean - :group 'jabber-activity - :set #'(lambda (var val) - (custom-set-default var val) - (when (and (featurep 'jabber-activity) - (bound-and-true-p jabber-activity-mode)) - (jabber-activity-mode -1) - (jabber-activity-mode 1)))) - -(defcustom jabber-activity-count-in-title-format - '(jabber-activity-jids ("[" jabber-activity-count-string "] ")) - "Format string used for displaying activity in frame titles. -Same syntax as `mode-line-format'." - :type 'sexp - :group 'jabber-activity - :set #'(lambda (var val) - (if (not (and (featurep 'jabber-activity) (bound-and-true-p jabber-activity-mode))) - (custom-set-default var val) - (jabber-activity-mode -1) - (custom-set-default var val) - (jabber-activity-mode 1)))) - -(defcustom jabber-activity-show-p 'jabber-activity-show-p-default - "Function that checks if the given JID should be shown on the mode line. -Predicate function to call to check if the given JID should be -shown in the mode line or not." - :type 'function - :group 'jabber-activity) - -(defcustom jabber-activity-query-unread t - "Cancel Emacs killing when there are unread messages? -Query the user as to whether killing Emacs should be cancelled when -there are unread messages which otherwise would be lost." - :type 'boolean - :group 'jabber-activity) - -(defcustom jabber-activity-banned nil - "List of regexps of banned JID." - :type '(repeat string) - :group 'jabber-activity) - -(defface jabber-activity-face - '((t (:foreground "red" :weight bold))) - "The face for displaying jabber-activity-string in the mode line." - :group 'jabber-activity) - -(defface jabber-activity-personal-face - '((t (:foreground "blue" :weight bold))) - "The face for displaying personal jabber-activity-string in the mode line." - :group 'jabber-activity) - -(defvar jabber-activity-jids nil - "A list of JIDs which have caused activity.") - -(defvar jabber-activity-personal-jids nil - "Subset of `jabber-activity-jids' for JIDs with \"personal\" activity.") - -(defvar jabber-activity-name-alist nil - "Alist of mode line names for bare JIDs.") - -(defvar jabber-activity-mode-string "" - "The mode string for jabber activity.") - -(defvar jabber-activity-count-string "0" - "Number of active JIDs as a string.") - -(defvar jabber-activity-update-hook nil - "Hook called when `jabber-activity-jids' changes. -It is called after `jabber-activity-mode-string' and -`jabber-activity-count-string' are updated.") - -;; Protect this variable from being set in Local variables etc. -(put 'jabber-activity-mode-string 'risky-local-variable t) -(put 'jabber-activity-count-string 'risky-local-variable t) - -(defun jabber-activity-make-string-default (jid) - "Return the nick of the JID. -If no nick is available, return -the user name part of the JID. In private MUC conversations, -return the user's nickname." - (if (jabber-muc-sender-p jid) - (jabber-jid-resource jid) - (let ((nick (jabber-jid-displayname jid)) - (user (jabber-jid-user jid)) - (username (jabber-jid-username jid))) - (if (and username (string= nick user)) - username - nick)))) - -(defun jabber-activity-make-strings-default (jids) - "Apply `jabber-activity-make-string' on JIDS." - (mapcar #'(lambda (jid) (cons jid (funcall jabber-activity-make-string jid))) - jids)) - -(defun jabber-activity-common-prefix (s1 s2) - "Return length of common prefix string shared by S1 and S2." - (let ((len (min (length s1) (length s2)))) - (or (dotimes (i len) - (when (not (eq (aref s1 i) (aref s2 i))) - (return i))) - ;; Substrings, equal, nil, or empty ("") - len))) - -(defun jabber-activity-make-strings-shorten (jids) - "Return an alist of (JID . short-names). -Return an alist of JID -> names acquired by running -`jabber-activity-make-string' on JIDS, and then shortening the names -as much as possible such that all strings still are unique and at -least `jabber-activity-shorten-minimum' long." - (let ((alist - (sort (mapcar - #'(lambda (x) (cons x (funcall jabber-activity-make-string x))) - jids) - #'(lambda (x y) (string-lessp (cdr x) (cdr y)))))) - (loop for ((prev-jid . prev) (cur-jid . cur) (next-jid . next)) - on (cons nil alist) - until (null cur) - collect - (cons - cur-jid - (substring - cur - 0 (min (length cur) - (max jabber-activity-shorten-minimum - (1+ (jabber-activity-common-prefix cur prev)) - (1+ (jabber-activity-common-prefix cur next))))))))) - -(defun jabber-activity-find-buffer-name (jid) - "Find the name of the buffer that messages from JID would use." - (or (and (jabber-jid-resource jid) - (get-buffer (jabber-muc-private-get-buffer - (jabber-jid-user jid) - (jabber-jid-resource jid)))) - (get-buffer (jabber-chat-get-buffer jid)) - (get-buffer (jabber-muc-get-buffer jid)))) - -(defun jabber-activity-show-p-default (jid) - "Return t only if there is an invisible buffer for JID. -And, JID is not in `jabber-activity-banned'." - (let ((buffer (jabber-activity-find-buffer-name jid))) - (and (buffer-live-p buffer) - (not (get-buffer-window buffer 'visible)) - (not (dolist (entry jabber-activity-banned) - (when (string-match entry jid) - (return t))))))) - -(defun jabber-activity-make-name-alist () - "Rebuild `jabber-activity-name-alist' based on currently known JIDs." - (let ((jids (or (mapcar #'car jabber-activity-name-alist) - (mapcar #'symbol-name *jabber-roster*)))) - (setq jabber-activity-name-alist - (funcall jabber-activity-make-strings jids)))) - -(defun jabber-activity-lookup-name (jid) - "Lookup name in `jabber-activity-name-alist' and return (jid . string). -Lookup name in `jabber-activity-name-alist', creates an entry -if needed, and returns a (jid . string) pair suitable for the mode line" - (let ((elm (assoc jid jabber-activity-name-alist))) - (if elm - elm - (progn - ;; Remake alist with the new JID - (setq jabber-activity-name-alist - (funcall jabber-activity-make-strings - (cons jid (mapcar #'car jabber-activity-name-alist)))) - (jabber-activity-lookup-name jid))))) - -(defun jabber-activity-mode-line-update () - "Update the string shown in the mode line using `jabber-activity-make-string'. -Update the string shown in the mode line using `jabber-activity-make-string' -on JIDs where `jabber-activity-show-p'. Optional not-nil GROUP mean that -message come from MUC. -Optional TEXT used with one-to-one or MUC chats and may be used to identify -personal MUC message. -Optional PRESENCE mean personal presence request or alert." - (setq jabber-activity-mode-string - (if jabber-activity-jids - (mapconcat - (lambda (x) - (let ((jump-to-jid (car x))) - (jabber-propertize - (cdr x) - 'face (if (member jump-to-jid jabber-activity-personal-jids) - 'jabber-activity-personal-face - 'jabber-activity-face) - ;; XXX: XEmacs doesn't have make-mode-line-mouse-map. - ;; Is there another way to make this work? - 'local-map (when (fboundp 'make-mode-line-mouse-map) - (make-mode-line-mouse-map - 'mouse-1 `(lambda () - (interactive "@") - (jabber-activity-switch-to - ,(car x))))) - 'help-echo (concat "Jump to " - (jabber-jid-displayname (car x)) - "'s buffer")))) - (mapcar #'jabber-activity-lookup-name - jabber-activity-jids) - ",") - "")) - (setq jabber-activity-count-string - (number-to-string (length jabber-activity-jids))) - (force-mode-line-update 'all) - (run-hooks 'jabber-activity-update-hook)) - -(defun jabber-activity-clean () - "Remove JIDs where `jabber-activity-show-p' no longer is true." - (setq jabber-activity-jids (delete-if-not jabber-activity-show-p - jabber-activity-jids)) - (setq jabber-activity-personal-jids - (delete-if-not jabber-activity-show-p - jabber-activity-personal-jids)) - (jabber-activity-mode-line-update)) - -(defun jabber-activity-add (from buffer text proposed-alert) - "Add a JID to mode line when `jabber-activity-show-p'." - (when (funcall jabber-activity-show-p from) - (add-to-list 'jabber-activity-jids from) - (add-to-list 'jabber-activity-personal-jids from) - (jabber-activity-mode-line-update))) - -(defun jabber-activity-add-muc (nick group buffer text proposed-alert) - "Add a JID to mode line when `jabber-activity-show-p'." - (when (funcall jabber-activity-show-p group) - (add-to-list 'jabber-activity-jids group) - (when (jabber-muc-looks-like-personal-p text group) - (add-to-list 'jabber-activity-personal-jids group)) - (jabber-activity-mode-line-update))) - -(defun jabber-activity-presence (who oldstatus newstatus statustext proposed-alert) - "Add a JID to mode line on subscription requests." - (when (string= newstatus "subscribe") - (add-to-list 'jabber-activity-jids (symbol-name who)) - (add-to-list 'jabber-activity-personal-jids (symbol-name who)) - (jabber-activity-mode-line-update))) - -(defun jabber-activity-kill-hook () - "Query the user if is sure to kill Emacs when there are unread messages. -Query the user as to whether killing Emacs should be cancelled -when there are unread messages which otherwise would be lost, if -`jabber-activity-query-unread' is t" - (if (and jabber-activity-jids - jabber-activity-query-unread) - (or jabber-silent-mode (yes-or-no-p - "You have unread Jabber messages, are you sure you want to quit?")) - t)) - -(defvar jabber-activity-last-buffer nil - "Last non-Jabber buffer used.") - -(defun jabber-activity-switch-to (&optional jid-param) - "If JID-PARAM is provided, switch to that buffer. -If JID-PARAM is nil and -there has been activity in another buffer, switch to that buffer. If no such -buffer exists, switch back to the last non Jabber chat buffer used." - (interactive) - (if (or jid-param jabber-activity-jids) - (let ((jid (or jid-param (car jabber-activity-jids)))) - (unless (eq major-mode 'jabber-chat-mode) - (setq jabber-activity-last-buffer (current-buffer))) - (switch-to-buffer (jabber-activity-find-buffer-name jid)) - (jabber-activity-clean)) - (if (eq major-mode 'jabber-chat-mode) - ;; Switch back to the buffer used last - (when (buffer-live-p jabber-activity-last-buffer) - (switch-to-buffer jabber-activity-last-buffer)) - (message "No new activity")))) - -(defvar jabber-activity-idle-timer nil "Idle timer used for activity cleaning.") - -;;;###autoload -(define-minor-mode jabber-activity-mode - "Toggle display of activity in hidden jabber buffers in the mode line. - -With a numeric arg, enable this display if arg is positive." - :global t - :group 'jabber-activity - :init-value t - (if jabber-activity-mode - (progn - ;; XEmacs compatibilty hack from erc-track - (if (featurep 'xemacs) - (defadvice switch-to-buffer (after jabber-activity-update (&rest args) activate) - (jabber-activity-clean)) - (add-hook 'window-configuration-change-hook - 'jabber-activity-clean)) - (add-hook 'jabber-message-hooks - 'jabber-activity-add) - (add-hook 'jabber-muc-hooks - 'jabber-activity-add-muc) - (add-hook 'jabber-presence-hooks - 'jabber-activity-presence) - (setq jabber-activity-idle-timer (run-with-idle-timer 2 t 'jabber-activity-clean)) - ;; XXX: reactivate - ;; (add-hook 'jabber-post-connect-hooks -;; 'jabber-activity-make-name-alist) - (add-to-list 'kill-emacs-query-functions - 'jabber-activity-kill-hook) - (add-to-list 'global-mode-string - '(t jabber-activity-mode-string)) - (when jabber-activity-count-in-title - ;; Be careful not to override specific meanings of the - ;; existing title format. In particular, if the car is - ;; a symbol, we can't just add our stuff at the beginning. - ;; If the car is "", we should be safe. - ;; - ;; In my experience, sometimes the activity count gets - ;; included twice in the title. I'm not sure exactly why, - ;; but it would be nice to replace the code below with - ;; something cleaner. - (if (equal (car-safe frame-title-format) "") - (add-to-list 'frame-title-format - jabber-activity-count-in-title-format) - (setq frame-title-format (list "" - jabber-activity-count-in-title-format - frame-title-format))) - (if (equal (car-safe icon-title-format) "") - (add-to-list 'icon-title-format - jabber-activity-count-in-title-format) - (setq icon-title-format (list "" - jabber-activity-count-in-title-format - icon-title-format))))) - (progn - (if (featurep 'xemacs) - (ad-disable-advice 'switch-to-buffer 'after 'jabber-activity-update) - (remove-hook 'window-configuration-change-hook - 'jabber-activity-remove-visible)) - (remove-hook 'jabber-message-hooks - 'jabber-activity-add) - (remove-hook 'jabber-muc-hooks - 'jabber-activity-add-muc) - (remove-hook 'jabber-presence-hooks - 'jabber-activity-presence) - (ignore-errors (cancel-timer jabber-activity-idle-timer)) - ;; XXX: reactivate -;; (remove-hook 'jabber-post-connect-hooks -;; 'jabber-activity-make-name-alist) - (setq global-mode-string (delete '(t jabber-activity-mode-string) - global-mode-string)) - (when (listp frame-title-format) - (setq frame-title-format - (delete jabber-activity-count-in-title-format - frame-title-format))) - (when (listp icon-title-format) - (setq icon-title-format - (delete jabber-activity-count-in-title-format - icon-title-format)))))) - -;; XXX: define-minor-mode should probably do this for us, but it doesn't. -(if jabber-activity-mode (jabber-activity-mode 1)) - -(require 'cl) - -(defgroup jabber-events nil - "Message events and notifications." - :group 'jabber) - -(defcustom jabber-events-request-these '(offline - delivered - displayed - composing) - "Request these kinds of event notifications from others." - :type '(set (const :tag "Delivered to offline storage" offline) - (const :tag "Delivered to user's client" delivered) - (const :tag "Displayed to user" displayed) - (const :tag "User is typing a reply" composing)) - :group 'jabber-events) - -(defvar jabber-events-composing-p nil - "Is the other person composing a message?") -(make-variable-buffer-local 'jabber-events-composing-p) - -(defvar jabber-events-arrived nil - "In what way has the message reached the recipient? -Possible values are nil (no information available), offline -\(queued for delivery when recipient is online), delivered -\(message has reached the client) and displayed (user is -probably reading the message).") -(make-variable-buffer-local 'jabber-events-arrived) - -(defvar jabber-events-message "" - "Human-readable presentation of event information.") -(make-variable-buffer-local 'jabber-events-message) - -(defun jabber-events-update-message () - (setq jabber-events-message - (concat (cdr (assq jabber-events-arrived - '((offline . "In offline storage") - (delivered . "Delivered") - (displayed . "Displayed")))) - (when jabber-events-composing-p - " (typing a message)")))) - -(add-hook 'jabber-chat-send-hooks 'jabber-events-when-sending) -(defun jabber-events-when-sending (text id) - (setq jabber-events-arrived nil) - (jabber-events-update-message) - `((x ((xmlns . "jabber:x:event")) - ,@(mapcar #'list jabber-events-request-these)))) - -(defcustom jabber-events-confirm-delivered t - "Send delivery confirmation if requested?" - :group 'jabber-events - :type 'boolean) - -(defcustom jabber-events-confirm-displayed t - "Send display confirmation if requested?" - :group 'jabber-events - :type 'boolean) - -(defcustom jabber-events-confirm-composing t - "Send notifications about typing a reply?" - :group 'jabber-events - :type 'boolean) - -(defvar jabber-events-requested () - "List of events requested.") -(make-variable-buffer-local 'jabber-events-requested) - -(defvar jabber-events-last-id nil - "Id of last message received, or nil if none.") -(make-variable-buffer-local 'jabber-events-last-id) - -(defvar jabber-events-delivery-confirmed nil - "Has delivery confirmation been sent?") -(make-variable-buffer-local 'jabber-events-delivery-confirmed) - -(defvar jabber-events-display-confirmed nil - "Has display confirmation been sent?") -(make-variable-buffer-local 'jabber-events-display-confirmed) - -(defvar jabber-events-composing-sent nil - "Has composing notification been sent? -It can be sent and cancelled several times.") - -(add-hook 'window-configuration-change-hook - 'jabber-events-confirm-display) -(defun jabber-events-confirm-display () - "Send display confirmation if appropriate. -That is, if user allows it, if the other user requested it, -and it hasn't been sent before." - (walk-windows #'jabber-events-confirm-display-in-window)) - -(defun jabber-events-confirm-display-in-window (window) - (with-current-buffer (window-buffer window) - (when (and jabber-events-confirm-displayed - (not jabber-events-display-confirmed) - (memq 'displayed jabber-events-requested) - ;; XXX: if jabber-events-requested is non-nil, how can - ;; jabber-chatting-with be nil? See - ;; http://sourceforge.net/tracker/index.php?func=detail&aid=1872560&group_id=88346&atid=586350 - jabber-chatting-with - ;; don't send to bare jids - (jabber-jid-resource jabber-chatting-with)) - (jabber-send-sexp - jabber-buffer-connection - `(message - ((to . ,jabber-chatting-with)) - (x ((xmlns . "jabber:x:event")) - (displayed) - (id () ,jabber-events-last-id)))) - (setq jabber-events-display-confirmed t)))) - -(defun jabber-events-after-change () - (let ((composing-now (not (= (point-max) jabber-point-insert)))) - (when (and jabber-events-confirm-composing - jabber-chatting-with - (not (eq composing-now jabber-events-composing-sent))) - (jabber-send-sexp - jabber-buffer-connection - `(message - ((to . ,jabber-chatting-with)) - (x ((xmlns . "jabber:x:event")) - ,@(if composing-now '((composing)) nil) - (id () ,jabber-events-last-id)))) - (setq jabber-events-composing-sent composing-now)))) - -(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-events t) - -(defun jabber-handle-incoming-message-events (jc xml-data) - (when (and (not (jabber-muc-message-p xml-data)) - (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))) - (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)) - (let ((x (find "jabber:x:event" - (jabber-xml-get-children xml-data 'x) - :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns)) - :test #'string=))) - (cond - ;; If we get an error message, we shouldn't report any - ;; events, as the requests are mirrored from us. - ((string= (jabber-xml-get-attribute xml-data 'type) "error") - (remove-hook 'post-command-hook 'jabber-events-after-change t) - (setq jabber-events-requested nil)) - - ;; If there's a body, it's not an incoming message event. - ((jabber-xml-get-children xml-data 'body) - ;; User is done composing, obviously. - (setq jabber-events-composing-p nil) - (jabber-events-update-message) - - ;; Reset variables - (setq jabber-events-display-confirmed nil) - (setq jabber-events-delivery-confirmed nil) - - ;; User requests message events - (setq jabber-events-requested - ;; There might be empty strings in the XML data, - ;; which car chokes on. Having nil values in - ;; the list won't hurt, therefore car-safe. - (mapcar #'car-safe - (jabber-xml-node-children x))) - (setq jabber-events-last-id (jabber-xml-get-attribute - xml-data 'id)) - - ;; Send notifications we already know about - (flet ((send-notification - (type) - (jabber-send-sexp - jc - `(message - ((to . ,(jabber-xml-get-attribute xml-data 'from))) - (x ((xmlns . "jabber:x:event")) - (,type) - (id () ,jabber-events-last-id)))))) - ;; Send delivery confirmation if appropriate - (when (and jabber-events-confirm-delivered - (memq 'delivered jabber-events-requested)) - (send-notification 'delivered) - (setq jabber-events-delivery-confirmed t)) - - ;; Send display confirmation if appropriate - (when (and jabber-events-confirm-displayed - (get-buffer-window (current-buffer) 'visible) - (memq 'displayed jabber-events-requested)) - (send-notification 'displayed) - (setq jabber-events-display-confirmed t)) - - ;; Set up hooks for composition notification - (when (and jabber-events-confirm-composing - (memq 'composing jabber-events-requested)) - (add-hook 'post-command-hook 'jabber-events-after-change - nil t)))) - (t - ;; So it has no body. If it's a message event, - ;; the node should be the only child of the - ;; message, and it should contain an node. - ;; We check the latter. - (when (and x (jabber-xml-get-children x 'id)) - ;; Currently we don't care about the node. - - ;; There's only one node except for the id. - (unless - (dolist (possible-node '(offline delivered displayed)) - (when (jabber-xml-get-children x possible-node) - (setq jabber-events-arrived possible-node) - (jabber-events-update-message) - (return t))) - ;; Or maybe even zero, which is a negative composing node. - (setq jabber-events-composing-p - (not (null (jabber-xml-get-children x 'composing)))) - (jabber-events-update-message))))))))) - -(require 'cl) - -(defgroup jabber-chatstates nil - "Chat state notifications." - :group 'jabber) - -(defconst jabber-chatstates-xmlns "http://jabber.org/protocol/chatstates" - "XML namespace for the chatstates feature.") - -(defcustom jabber-chatstates-confirm t - "Send notifications about chat states?" - :group 'jabber-chatstates - :type 'boolean) - -(defvar jabber-chatstates-requested 'first-time - "Whether or not chat states notification was requested. -This is one of the following: -first-time - send state in first stanza, then switch to nil -t - send states -nil - don't send states") -(make-variable-buffer-local 'jabber-chatstates-requested) - -(defvar jabber-chatstates-last-state nil - "The last seen chat state.") -(make-variable-buffer-local 'jabber-chatstates-last-state) - -(defvar jabber-chatstates-message "" - "Human-readable presentation of chat state information.") -(make-variable-buffer-local 'jabber-chatstates-message) - -(defun jabber-chatstates-update-message () - (setq jabber-chatstates-message - (if (and jabber-chatstates-last-state - (not (eq 'active jabber-chatstates-last-state))) - (format " (%s)" (symbol-name jabber-chatstates-last-state)) - ""))) - -(add-hook 'jabber-chat-send-hooks 'jabber-chatstates-when-sending) -(defun jabber-chatstates-when-sending (text id) - (jabber-chatstates-update-message) - (jabber-chatstates-stop-timer) - (when (and jabber-chatstates-confirm jabber-chatstates-requested) - (when (eq jabber-chatstates-requested 'first-time) - ;; don't send more notifications until we know that the other - ;; side wants them. - (setq jabber-chatstates-requested nil)) - (setq jabber-chatstates-composing-sent nil) - `((active ((xmlns . ,jabber-chatstates-xmlns)))))) - -(defvar jabber-chatstates-composing-sent nil - "Has composing notification been sent? -It can be sent and cancelled several times.") -(make-variable-buffer-local 'jabber-chatstates-composing-sent) - -(defvar jabber-chatstates-paused-timer nil - "Timer that counts down from 'composing state to 'paused.") -(make-variable-buffer-local 'jabber-chatstates-paused-timer) - -(defun jabber-chatstates-stop-timer () - "Stop the 'paused timer." - (when jabber-chatstates-paused-timer - (cancel-timer jabber-chatstates-paused-timer))) - -(defun jabber-chatstates-kick-timer () - "Start (or restart) the 'paused timer as approriate." - (jabber-chatstates-stop-timer) - (setq jabber-chatstates-paused-timer - (run-with-timer 5 nil 'jabber-chatstates-send-paused))) - -(defun jabber-chatstates-send-paused () - "Send an 'paused state notification." - (when (and jabber-chatstates-requested jabber-chatting-with) - (setq jabber-chatstates-composing-sent nil) - (jabber-send-sexp-if-connected - jabber-buffer-connection - `(message - ((to . ,jabber-chatting-with) - (type . "chat")) - (paused ((xmlns . ,jabber-chatstates-xmlns))))))) - -(defun jabber-chatstates-after-change () - (let* ((composing-now (not (= (point-max) jabber-point-insert))) - (state (if composing-now 'composing 'active))) - (when (and jabber-chatstates-confirm - jabber-chatting-with - jabber-chatstates-requested - (not (eq composing-now jabber-chatstates-composing-sent))) - (jabber-send-sexp-if-connected - jabber-buffer-connection - `(message - ((to . ,jabber-chatting-with) - (type . "chat")) - (,state ((xmlns . ,jabber-chatstates-xmlns))))) - (when (setq jabber-chatstates-composing-sent composing-now) - (jabber-chatstates-kick-timer))))) - -(defun jabber-handle-incoming-message-chatstates (jc xml-data) - (when (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from))) - (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)) - (cond - ;; If we get an error message, we shouldn't report any - ;; events, as the requests are mirrored from us. - ((string= (jabber-xml-get-attribute xml-data 'type) "error") - (remove-hook 'post-command-hook 'jabber-chatstates-after-change t) - (setq jabber-chatstates-requested nil)) - - (t - (let ((state - (or - (let ((node - (find jabber-chatstates-xmlns - (jabber-xml-node-children xml-data) - :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns)) - :test #'string=))) - (jabber-xml-node-name node)) - (let ((node - ;; XXX: this is how we interoperate with - ;; Google Talk. We should really use a - ;; namespace-aware XML parser. - (find jabber-chatstates-xmlns - (jabber-xml-node-children xml-data) - :key #'(lambda (x) (jabber-xml-get-attribute x 'xmlns:cha)) - :test #'string=))) - (when node - ;; Strip the "cha:" prefix - (let ((name (symbol-name (jabber-xml-node-name node)))) - (when (> (length name) 4) - (intern (substring name 4))))))))) - ;; Set up hooks for composition notification - (when (and jabber-chatstates-confirm state) - (setq jabber-chatstates-requested t) - (add-hook 'post-command-hook 'jabber-chatstates-after-change nil t)) - - (setq jabber-chatstates-last-state state) - (jabber-chatstates-update-message))))))) - -;; Add function last in chain, so a chat buffer is already created. -(add-to-list 'jabber-message-chain 'jabber-handle-incoming-message-chatstates t) - -(jabber-disco-advertise-feature "http://jabber.org/protocol/chatstates") - -(require 'mailcap) -(eval-when-compile (require 'cl)) - -(defgroup jabber-avatar nil - "Avatar related settings" - :group 'jabber) - -(defcustom jabber-avatar-cache-directory - (locate-user-emacs-file "jabber-avatar-cache" ".jabber-avatars") - "Directory to use for cached avatars." - :group 'jabber-avatar - :type 'directory) - -(defcustom jabber-avatar-verbose nil - "Display messages about irregularities with other people's avatars." - :group 'jabber-avatar - :type 'boolean) - -(defcustom jabber-avatar-max-width 96 - "Maximum width of avatars." - :group 'jabber-avatar - :type 'integer) - -(defcustom jabber-avatar-max-height 96 - "Maximum height of avatars." - :group 'jabber-avatar - :type 'integer) - -(defstruct avatar sha1-sum mime-type url base64-data height width bytes) - -(defun jabber-avatar-from-url (url) - "Construct an avatar structure from the given URL. -Retrieves the image to find info about it." - (with-current-buffer (let ((coding-system-for-read 'binary)) - (url-retrieve-synchronously url)) - (let* ((case-fold-search t) - (mime-type (ignore-errors - (search-forward-regexp "^content-type:[ \t]*\\(.*\\)$") - (match-string 1))) - (data (progn - (search-forward "\n\n") - (buffer-substring (point) (point-max))))) - (prog1 - (jabber-avatar-from-data data nil mime-type) - (kill-buffer nil))))) - -(defun jabber-avatar-from-file (filename) - "Construct an avatar structure from FILENAME." - (require 'mailcap) - (let ((data (with-temp-buffer - (insert-file-contents-literally filename) - (buffer-string))) - (mime-type (when (string-match "\\.[^.]+$" filename) - (mailcap-extension-to-mime (match-string 0 filename))))) - (jabber-avatar-from-data data nil mime-type))) - -(defun jabber-avatar-from-base64-string (base64-string &optional mime-type) - "Construct an avatar stucture from BASE64-STRING. -If MIME-TYPE is not specified, try to find it from the image data." - (jabber-avatar-from-data nil base64-string mime-type)) - -(defun jabber-avatar-from-data (raw-data base64-string &optional mime-type) - "Construct an avatar structure from RAW-DATA and/or BASE64-STRING. -If either is not provided, it is computed. -If MIME-TYPE is not specified, try to find it from the image data." - (let* ((data (or raw-data (base64-decode-string base64-string))) - (bytes (length data)) - (sha1-sum (sha1 data)) - (base64-data (or base64-string (base64-encode-string raw-data))) - (type (or mime-type - (cdr (assq (get :type (cdr (condition-case nil - (jabber-create-image data nil t) - (error nil)))) - '((png "image/png") - (jpeg "image/jpeg") - (gif "image/gif"))))))) - (jabber-avatar-compute-size - (make-avatar :mime-type mime-type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes)))) - -;; XXX: This function is based on an outdated version of XEP-0084. -;; (defun jabber-avatar-from-data-node (data-node) -;; "Construct an avatar structure from the given node." -;; (jabber-xml-let-attributes -;; (content-type id bytes height width) data-node -;; (let ((base64-data (car (jabber-xml-node-children data-node)))) -;; (make-avatar :mime-type content-type :sha1-sum id :bytes bytes -;; :height height :width width :base64-data base64-data)))) - -(defun jabber-avatar-image (avatar) - "Create an image from AVATAR. -Return nil if images of this type are not supported." - (condition-case nil - (jabber-create-image (with-temp-buffer - (set-buffer-multibyte nil) - (insert (avatar-base64-data avatar)) - (base64-decode-region (point-min) (point-max)) - (buffer-string)) - nil - t) - (error nil))) - -(defun jabber-avatar-compute-size (avatar) - "Compute and set the width and height fields of AVATAR. -Return AVATAR." - ;; image-size only works when there is a window system. - ;; But display-graphic-p doesn't exist on XEmacs... - (let ((size (and (fboundp 'display-graphic-p) - (display-graphic-p) - (let ((image (jabber-avatar-image avatar))) - (and image - (image-size image t)))))) - (when size - (setf (avatar-width avatar) (car size)) - (setf (avatar-height avatar) (cdr size))) - avatar)) - -(defun jabber-avatar-find-cached (sha1-sum) - "Return file name of cached image for avatar identified by SHA1-SUM. -If there is no cached image, return nil." - (let ((filename (expand-file-name sha1-sum jabber-avatar-cache-directory))) - (if (file-exists-p filename) - filename - nil))) - -(defun jabber-avatar-cache (avatar) - "Cache the AVATAR." - (let* ((id (avatar-sha1-sum avatar)) - (base64-data (avatar-base64-data avatar)) - (mime-type (avatar-mime-type avatar)) - (filename (expand-file-name id jabber-avatar-cache-directory))) - (unless (file-directory-p jabber-avatar-cache-directory) - (make-directory jabber-avatar-cache-directory t)) - - (if (file-exists-p filename) - (when jabber-avatar-verbose - (message "Caching avatar, but %s already exists" filename)) - (with-temp-buffer - (let ((require-final-newline nil) - (coding-system-for-write 'binary)) - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) - (insert base64-data) - (base64-decode-region (point-min) (point-max)) - (write-region (point-min) (point-max) filename nil 'silent)))))) - -;;;; Set avatar for contact -(defun jabber-avatar-set (jid avatar) - "Set the avatar of JID to be AVATAR. -JID is a string containing a bare JID. -AVATAR may be one of: - * An avatar structure. - * The SHA1 sum of a cached avatar. - * nil, meaning no avatar." - ;; We want to optimize for the case of same avatar. - ;; Loading an image is expensive, so do it lazily. - (let ((jid-symbol (jabber-jid-symbol jid)) - image hash) - (cond - ((avatar-p avatar) - (setq hash (avatar-sha1-sum avatar)) - (setq image (lambda () (jabber-avatar-image avatar)))) - ((stringp avatar) - (setq hash avatar) - (setq image (lambda () - (condition-case nil - (jabber-create-image (jabber-avatar-find-cached avatar)) - (error nil))))) - (t - (setq hash nil) - (setq image #'ignore))) - - (unless (string= hash (get jid-symbol 'avatar-hash)) - (put jid-symbol 'avatar (funcall image)) - (put jid-symbol 'avatar-hash hash) - (jabber-presence-update-roster jid-symbol)))) - -(defun jabber-create-image (file-or-data &optional type data-p) - "Create image, scaled down to jabber-avatar-max-width/height. -If width/height exceeds either of those, and ImageMagick is -available." - (let* ((image (create-image file-or-data type data-p)) - (size (image-size image t)) - (spec (cdr image))) - (when (and (functionp 'imagemagick-types) - (or (> (car size) jabber-avatar-max-width) - (> (cdr size) jabber-avatar-max-height))) - (plist-put spec :type 'imagemagick) - (plist-put spec :width jabber-avatar-max-width) - (plist-put spec :height jabber-avatar-max-height)) - image)) - -(defvar jabber-vcard-photo nil - "The avatar structure for the photo in the vCard edit buffer.") -(make-variable-buffer-local 'jabber-vcard-photo) - -(defun jabber-vcard-parse (vcard) - "Parse the vCard XML structure given in VCARD. -The top node should be the `vCard' node." - ;; Hm... stpeter has a as top node... - ;;(unless (eq (jabber-xml-node-name vcard) 'vCard) - ;; (error "Invalid vCard")) - (let (result) - (dolist (verbatim-node '(FN NICKNAME BDAY JABBERID MAILER TZ - TITLE ROLE NOTE PRODID REV SORT-STRING - UID URL DESC)) - ;; There should only be one of each of these. They are - ;; used verbatim. - (let ((node (car (jabber-xml-get-children vcard - verbatim-node)))) - ;; Some clients include the node, but without data - (when (car (jabber-xml-node-children node)) - (push (cons (jabber-xml-node-name node) - (car (jabber-xml-node-children node))) - result)))) - - ;; Name components - (let ((node (car (jabber-xml-get-children vcard 'N)))) - ;; Subnodes are FAMILY, GIVEN, MIDDLE, PREFIX, SUFFIX - (push (cons 'N - (let (name) - (dolist (subnode (jabber-xml-node-children node)) - (when (and (memq (jabber-xml-node-name subnode) - '(FAMILY GIVEN MIDDLE PREFIX SUFFIX)) - (not (zerop (length - (car (jabber-xml-node-children - subnode)))))) - (push (cons (jabber-xml-node-name subnode) - (car (jabber-xml-node-children - subnode))) - name))) - name)) - result)) - - ;; There can be several addresses - (let (addresses) - (dolist (adr (jabber-xml-get-children vcard 'ADR)) - ;; Find address type(s) - (let (types) - (dolist (possible-type '(HOME WORK POSTAL PARCEL DOM INTL PREF)) - (when (jabber-xml-get-children adr possible-type) - (push possible-type types))) - - (let (components) - (dolist (component (jabber-xml-node-children adr)) - (when (and (memq (jabber-xml-node-name component) - '(POBOX EXTADD STREET LOCALITY REGION - PCODE CTRY)) - (not (zerop (length - (car (jabber-xml-node-children - component)))))) - (push (cons (jabber-xml-node-name component) - (car (jabber-xml-node-children component))) - components))) - - (push (cons types components) addresses)))) - - (when addresses - (push (cons 'ADR addresses) result))) - - ;; Likewise for phone numbers - (let (phone-numbers) - (dolist (tel (jabber-xml-get-children vcard 'TEL)) - ;; Find phone type(s) - (let ((number (car (jabber-xml-node-children - (car (jabber-xml-get-children tel 'NUMBER))))) - types) - ;; Some clients put no NUMBER node. Avoid that. - (when number - (dolist (possible-type '(HOME WORK VOICE FAX PAGER MSG CELL - VIDEO BBS MODEM ISDN PCS PREF)) - (when (jabber-xml-get-children tel possible-type) - (push possible-type types))) - - (push (cons types number) phone-numbers)))) - - (when phone-numbers - (push (cons 'TEL phone-numbers) result))) - - ;; And for e-mail addresses - (let (e-mails) - (dolist (email (jabber-xml-get-children vcard 'EMAIL)) - (let ((userid (car (jabber-xml-node-children - (car (jabber-xml-get-children email 'USERID))))) - types) - ;; Some clients put no USERID node. Avoid that. - (when userid - (dolist (possible-type '(HOME WORK INTERNET PREF X400)) - (when (jabber-xml-get-children email possible-type) - (push possible-type types))) - (unless (or (memq 'INTERNET types) - (memq 'X400 types)) - (push 'INTERNET types)) - - (push (cons types userid) e-mails)))) - - (when e-mails - (push (cons 'EMAIL e-mails) result))) - - ;; XEP-0153: vCard-based avatars - (let ((photo-tag (car (jabber-xml-get-children vcard 'PHOTO)))) - (when photo-tag - (let ((type (jabber-xml-path photo-tag '(TYPE ""))) - (binval (jabber-xml-path photo-tag '(BINVAL "")))) - (when (and type binval) - (push (list 'PHOTO type binval) result))))) - - result)) - -(defun jabber-vcard-reassemble (parsed) - "Create a vCard XML structure from PARSED." - ;; Save photo in jabber-vcard-photo, to avoid excessive processing. - (let ((photo (cdr (assq 'PHOTO parsed)))) - (cond - ;; No photo - ((null photo) - (setq jabber-vcard-photo nil)) - ;; Existing photo - ((listp photo) - (setq jabber-vcard-photo - (jabber-avatar-from-base64-string - (nth 1 photo) (nth 0 photo)))) - ;; New photo from file - (t - (access-file photo "Avatar file not found") - ;; Maximum allowed size is 8 kilobytes - (when (> (nth 7 (file-attributes photo)) 8192) - (error "Avatar bigger than 8 kilobytes")) - (setq jabber-vcard-photo (jabber-avatar-from-file photo))))) - - `(vCard ((xmlns . "vcard-temp")) - ;; Put in simple fields - ,@(mapcar - (lambda (field) - (when (and (assq (car field) jabber-vcard-fields) - (not (zerop (length (cdr field))))) - (list (car field) nil (cdr field)))) - parsed) - ;; Put in decomposited name - (N nil - ,@(mapcar - (lambda (name-part) - (when (not (zerop (length (cdr name-part)))) - (list (car name-part) nil (cdr name-part)))) - (cdr (assq 'N parsed)))) - ;; Put in addresses - ,@(mapcar - (lambda (address) - (append '(ADR) '(()) - (mapcar 'list (nth 0 address)) - (mapcar (lambda (field) - (list (car field) nil (cdr field))) - (cdr address)))) - (cdr (assq 'ADR parsed))) - ;; Put in phone numbers - ,@(mapcar - (lambda (phone) - (append '(TEL) '(()) - (mapcar 'list (car phone)) - (list (list 'NUMBER nil (cdr phone))))) - (cdr (assq 'TEL parsed))) - ;; Put in e-mail addresses - ,@(mapcar - (lambda (email) - (append '(EMAIL) '(()) - (mapcar 'list (car email)) - (list (list 'USERID nil (cdr email))))) - (cdr (assq 'EMAIL parsed))) - ;; Put in photo - ,@(when jabber-vcard-photo - `((PHOTO () - (TYPE () ,(avatar-mime-type jabber-vcard-photo)) - (BINVAL () ,(avatar-base64-data jabber-vcard-photo))))))) - -(add-to-list 'jabber-jid-info-menu - (cons "Request vcard" 'jabber-vcard-get)) - -(defun jabber-vcard-get (jc jid) - "Request vcard from JID. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Request vcard from: " nil nil nil 'bare-or-muc))) - (jabber-send-iq jc jid - "get" - '(vCard ((xmlns . "vcard-temp"))) - #'jabber-process-data #'jabber-vcard-display - #'jabber-process-data "Vcard request failed")) - -(defun jabber-vcard-edit (jc) - "Edit your own vcard. - -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (jabber-send-iq jc nil - "get" - '(vCard ((xmlns . "vcard-temp"))) - #'jabber-vcard-do-edit nil - #'jabber-report-success "Vcard request failed")) - -(defconst jabber-vcard-fields '((FN . "Full name") - (NICKNAME . "Nickname") - (BDAY . "Birthday") - (URL . "URL") - (JABBERID . "JID") - (MAILER . "User agent") - (TZ . "Time zone") - (TITLE . "Title") - (ROLE . "Role") - (REV . "Last changed") - (DESC . "Description") - (NOTE . "Note"))) - -(defconst jabber-vcard-name-fields '((PREFIX . "Prefix") - (GIVEN . "Given name") - (MIDDLE . "Middle name") - (FAMILY . "Family name") - (SUFFIX . "Suffix"))) - -(defconst jabber-vcard-phone-types '((HOME . "Home") - (WORK . "Work") - (VOICE . "Voice") - (FAX . "Fax") - (PAGER . "Pager") - (MSG . "Message") - (CELL . "Cell phone") - (VIDEO . "Video") - (BBS . "BBS") - (MODEM . "Modem") - (ISDN . "ISDN") - (PCS . "PCS"))) - -(defconst jabber-vcard-email-types '((HOME . "Home") - (WORK . "Work") - (INTERNET . "Internet") - (X400 . "X400") - (PREF . "Preferred"))) - -(defconst jabber-vcard-address-types '((HOME . "Home") - (WORK . "Work") - (POSTAL . "Postal") - (PARCEL . "Parcel") - (DOM . "Domestic") - (INTL . "International") - (PREF . "Preferred"))) - -(defconst jabber-vcard-address-fields '((POBOX . "Post box") - (EXTADD . "Ext. address") - (STREET . "Street") - (LOCALITY . "Locality") - (REGION . "Region") - (PCODE . "Post code") - (CTRY . "Country"))) - -(defun jabber-vcard-display (jc xml-data) - "Display received vcard. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data)))) - (dolist (simple-field jabber-vcard-fields) - (let ((field (assq (car simple-field) parsed))) - (when field - (insert (cdr simple-field)) - (indent-to 20) - (insert (cdr field) "\n")))) - - (let ((names (cdr (assq 'N parsed)))) - (when names - (insert "\n") - (dolist (name-field jabber-vcard-name-fields) - (let ((field (assq (car name-field) names))) - (when field - (insert (cdr name-field)) - (indent-to 20) - (insert (cdr field) "\n")))))) - - (let ((email-addresses (cdr (assq 'EMAIL parsed)))) - (when email-addresses - (insert "\n") - (insert (jabber-propertize "E-mail addresses:\n" - 'face 'jabber-title-medium)) - (dolist (email email-addresses) - (insert (mapconcat (lambda (type) - (cdr (assq type jabber-vcard-email-types))) - (car email) - " ")) - (insert ": " (cdr email) "\n")))) - - (let ((phone-numbers (cdr (assq 'TEL parsed)))) - (when phone-numbers - (insert "\n") - (insert (jabber-propertize "Phone numbers:\n" - 'face 'jabber-title-medium)) - (dolist (number phone-numbers) - (insert (mapconcat (lambda (type) - (cdr (assq type jabber-vcard-phone-types))) - (car number) - " ")) - (insert ": " (cdr number) "\n")))) - - (let ((addresses (cdr (assq 'ADR parsed)))) - (when addresses - (insert "\n") - (insert (jabber-propertize "Addresses:\n" - 'face 'jabber-title-medium)) - (dolist (address addresses) - (insert (jabber-propertize - (mapconcat (lambda (type) - (cdr (assq type jabber-vcard-address-types))) - (car address) - " ") - 'face 'jabber-title-small)) - (insert "\n") - (dolist (address-field jabber-vcard-address-fields) - (let ((field (assq (car address-field) address))) - (when field - (insert (cdr address-field)) - (indent-to 20) - (insert (cdr field) "\n"))))))) - - ;; XEP-0153: vCard-based avatars - (let ((photo-type (nth 1 (assq 'PHOTO parsed))) - (photo-binval (nth 2 (assq 'PHOTO parsed)))) - (when (and photo-type photo-binval) - (condition-case nil - ;; ignore the type, let create-image figure it out. - (let ((image (jabber-create-image (base64-decode-string photo-binval) nil t))) - (insert-image image "[Photo]") - (insert "\n")) - (error (insert "Couldn't display photo\n"))))))) - -(defun jabber-vcard-do-edit (jc xml-data closure-data) - (let ((parsed (jabber-vcard-parse (jabber-iq-query xml-data))) - start-position) - (with-current-buffer (get-buffer-create "Edit vcard") - (jabber-init-widget-buffer nil) - - (setq jabber-buffer-connection jc) - - (setq start-position (point)) - - (dolist (simple-field jabber-vcard-fields) - (widget-insert (cdr simple-field)) - (indent-to 15) - (let ((default-value (cdr (assq (car simple-field) parsed)))) - (push (cons (car simple-field) - (widget-create 'editable-field (or default-value ""))) - jabber-widget-alist))) - - (widget-insert "\n") - (push (cons 'N - (widget-create - '(set :tag "Decomposited name" - (cons :tag "Prefix" :format "%t: %v" (const :format "" PREFIX) (string :format "%v")) - (cons :tag "Given name" :format "%t: %v" (const :format "" GIVEN) (string :format "%v")) - (cons :tag "Middle name" :format "%t: %v" (const :format "" MIDDLE) (string :format "%v")) - (cons :tag "Family name" :format "%t: %v" (const :format "" FAMILY) (string :format "%v")) - (cons :tag "Suffix" :format "%t: %v" (const :format "" SUFFIX) (string :format "%v"))) - :value (cdr (assq 'N parsed)))) - jabber-widget-alist) - - (widget-insert "\n") - (push (cons 'ADR - (widget-create - '(repeat :tag "Postal addresses" - (cons - :tag "Address" - (set :tag "Type" - (const :tag "Home" HOME) - (const :tag "Work" WORK) - (const :tag "Postal" POSTAL) - (const :tag "Parcel" PARCEL) - (const :tag "Domestic" DOM) - (const :tag "International" INTL) - (const :tag "Preferred" PREF)) - (set - :tag "Address" - (cons :tag "Post box" :format "%t: %v" - (const :format "" POBOX) (string :format "%v")) - (cons :tag "Ext. address" :format "%t: %v" - (const :format "" EXTADD) (string :format "%v")) - (cons :tag "Street" :format "%t: %v" - (const :format "" STREET) (string :format "%v")) - (cons :tag "Locality" :format "%t: %v" - (const :format "" LOCALITY) (string :format "%v")) - (cons :tag "Region" :format "%t: %v" - (const :format "" REGION) (string :format "%v")) - (cons :tag "Post code" :format "%t: %v" - (const :format "" PCODE) (string :format "%v")) - (cons :tag "Country" :format "%t: %v" - (const :format "" CTRY) (string :format "%v"))))) - :value (cdr (assq 'ADR parsed)))) - jabber-widget-alist) - - (widget-insert "\n") - (push (cons 'TEL - (widget-create - '(repeat :tag "Phone numbers" - (cons :tag "Number" - (set :tag "Type" - (const :tag "Home" HOME) - (const :tag "Work" WORK) - (const :tag "Voice" VOICE) - (const :tag "Fax" FAX) - (const :tag "Pager" PAGER) - (const :tag "Message" MSG) - (const :tag "Cell phone" CELL) - (const :tag "Video" VIDEO) - (const :tag "BBS" BBS) - (const :tag "Modem" MODEM) - (const :tag "ISDN" ISDN) - (const :tag "PCS" PCS)) - (string :tag "Number"))) - :value (cdr (assq 'TEL parsed)))) - jabber-widget-alist) - - (widget-insert "\n") - (push (cons 'EMAIL - (widget-create - '(repeat :tag "E-mail addresses" - (cons :tag "Address" - (set :tag "Type" - (const :tag "Home" HOME) - (const :tag "Work" WORK) - (const :tag "Internet" INTERNET) - (const :tag "X400" X400) - (const :tag "Preferred" PREF)) - (string :tag "Address"))) - :value (cdr (assq 'EMAIL parsed)))) - jabber-widget-alist) - - (widget-insert "\n") - (widget-insert "Photo/avatar:\n") - (let* ((photo (assq 'PHOTO parsed)) - (avatar (when photo - (jabber-avatar-from-base64-string (nth 2 photo) - (nth 1 photo))))) - (push (cons - 'PHOTO - (widget-create - `(radio-button-choice (const :tag "None" nil) - ,@(when photo - (list - `(const :tag - ,(concat - "Existing: " - (jabber-propertize " " - 'display (jabber-avatar-image avatar))) - ,(cdr photo)))) - (file :must-match t :tag "From file")) - :value (cdr photo))) - jabber-widget-alist)) - - (widget-insert "\n") - (widget-create 'push-button :notify #'jabber-vcard-submit "Submit") - - (widget-setup) - (widget-minor-mode 1) - (switch-to-buffer (current-buffer)) - (goto-char start-position)))) - -(defun jabber-vcard-submit (&rest ignore) - (let ((to-publish (jabber-vcard-reassemble - (mapcar (lambda (entry) - (cons (car entry) (widget-value (cdr entry)))) - jabber-widget-alist)))) - (jabber-send-iq jabber-buffer-connection nil - "set" - to-publish - #'jabber-report-success "Changing vCard" - #'jabber-report-success "Changing vCard") - (when (bound-and-true-p jabber-vcard-avatars-publish) - (jabber-vcard-avatars-update-current - jabber-buffer-connection - (and jabber-vcard-photo (avatar-sha1-sum jabber-vcard-photo)))))) - -(defcustom jabber-vcard-avatars-retrieve (and (fboundp 'display-images-p) - (display-images-p)) - "Automatically download vCard avatars?" - :group 'jabber-avatar - :type 'boolean) - -(defcustom jabber-vcard-avatars-publish t - "Publish your vCard photo as avatar?" - :group 'jabber-avatar - :type 'boolean) - -(defvar jabber-vcard-avatars-current-hash - (make-hash-table :test 'equal) - "For each connection, SHA1 hash of current avatar. -Keys are full JIDs.") - -(add-to-list 'jabber-presence-chain 'jabber-vcard-avatars-presence) -(defun jabber-vcard-avatars-presence (jc xml-data) - "Look for vCard avatar mark in stanza. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - ;; Only look at ordinary presence - (when (and jabber-vcard-avatars-retrieve - (null (jabber-xml-get-attribute xml-data 'type))) - (let* ((from (jabber-jid-user (jabber-xml-get-attribute xml-data 'from))) - (photo (jabber-xml-path xml-data '(("vcard-temp:x:update" . "x") photo))) - (sha1-hash (car (jabber-xml-node-children photo)))) - (cond - ((null sha1-hash) - ;; User has removed avatar - (jabber-avatar-set from nil)) - ((string= sha1-hash (get (jabber-jid-symbol from) 'avatar-hash)) - ;; Same avatar as before; do nothing - ) - ((jabber-avatar-find-cached sha1-hash) - ;; Avatar is cached - (jabber-avatar-set from sha1-hash)) - (t - ;; Avatar is not cached; retrieve it - (jabber-vcard-avatars-fetch jc from sha1-hash)))))) - -(defun jabber-vcard-avatars-fetch (jc who sha1-hash) - "Fetch WHO's vCard, and extract avatar. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Fetch whose vCard avatar: ") - nil)) - (jabber-send-iq jc who "get" '(vCard ((xmlns . "vcard-temp"))) - #'jabber-vcard-avatars-vcard (cons who sha1-hash) - #'ignore nil)) - -(defun jabber-vcard-avatars-vcard (jc iq closure) - "Get the photo from the vCard, and set the avatar." - (let ((from (car closure)) - (sha1-hash (cdr closure)) - (photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query iq))))) - (if photo - (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) - (nth 1 photo)))) - (unless (or (null sha1-hash) - (string= sha1-hash (avatar-sha1-sum avatar))) - (when jabber-avatar-verbose - (message "%s's avatar should have SHA1 sum %s, but has %s" - (jabber-jid-displayname from) - sha1-hash - (avatar-sha1-sum avatar)))) - (jabber-avatar-cache avatar) - (jabber-avatar-set from avatar)) - (jabber-avatar-set from nil)))) - -(defun jabber-vcard-avatars-find-current (jc) - "Request our own vCard, to find hash of avatar. - -JC is the Jabber connection." - (when jabber-vcard-avatars-publish - (jabber-send-iq jc nil "get" '(vCard ((xmlns . "vcard-temp"))) - #'jabber-vcard-avatars-find-current-1 t - #'jabber-vcard-avatars-find-current-1 nil))) - -(defun jabber-vcard-avatars-find-current-1 (jc xml-data success) - (jabber-vcard-avatars-update-current - jc - (and success - (let ((photo (assq 'PHOTO (jabber-vcard-parse (jabber-iq-query xml-data))))) - (when photo - (let ((avatar (jabber-avatar-from-base64-string (nth 2 photo) - (nth 1 photo)))) - (avatar-sha1-sum avatar))))))) - -(defun jabber-vcard-avatars-update-current (jc new-hash) - (let ((old-hash (gethash - (jabber-connection-bare-jid jc) - jabber-vcard-avatars-current-hash))) - (when (not (string= old-hash new-hash)) - (puthash (jabber-connection-bare-jid jc) - new-hash jabber-vcard-avatars-current-hash) - (jabber-send-current-presence jc)))) - -(add-to-list 'jabber-presence-element-functions 'jabber-vcard-avatars-presence-element) -(defun jabber-vcard-avatars-presence-element (jc) - (when jabber-vcard-avatars-publish - (let ((hash (gethash - (jabber-connection-bare-jid jc) - jabber-vcard-avatars-current-hash))) - (list - `(x ((xmlns . "vcard-temp:x:update")) - ;; if "not yet ready to advertise image", don't. - ;; that is, we haven't yet checked what avatar we have. - ,(when hash - `(photo () ,hash))))))) - -(eval-when-compile (require 'cl)) -(require 'time-date) - -(defgroup jabber-autoaway nil - "Change status to away after idleness." - :group 'jabber) - -(defcustom jabber-autoaway-methods - (if (fboundp 'jabber-autoaway-method) - (list jabber-autoaway-method) - (list 'jabber-current-idle-time - 'jabber-xprintidle-get-idle-time - 'jabber-termatime-get-idle-time)) - "Methods used to keep track of idleness. -This is a list of functions that takes no arguments, and returns the -number of seconds since the user was active, or nil on error." - :group 'jabber-autoaway - :options '(jabber-current-idle-time - jabber-xprintidle-get-idle-time - jabber-termatime-get-idle-time)) - -(defcustom jabber-autoaway-timeout 5 - "Minutes of inactivity before changing status to away." - :group 'jabber-autoaway - :type 'number) - -(defcustom jabber-autoaway-xa-timeout 10 - "Minutes of inactivity before changing status to xa. -Set to 0 to disable." - :group 'jabber-autoaway - :type 'number) - -(defcustom jabber-autoaway-status "Idle" - "Status string for autoaway." - :group 'jabber-autoaway - :type 'string) - -(defcustom jabber-autoaway-xa-status "Extended away" - "Status string for autoaway in xa state." - :group 'jabber-autoaway - :type 'string) - -(defcustom jabber-autoaway-priority nil - "Priority for autoaway. -If nil, don't change priority. See the manual for more -information about priority." - :group 'jabber-autoaway - :type '(choice (const :tag "Don't change") - (integer :tag "Priority")) - :link '(info-link "(jabber)Presence")) - -(defcustom jabber-autoaway-xa-priority nil - "Priority for autoaway in xa state. -If nil, don't change priority. See the manual for more -information about priority." - :group 'jabber-autoaway - :type '(choice (const :tag "Don't change") - (integer :tag "Priority")) - :link '(info-link "(jabber)Presence")) - -(defcustom jabber-xprintidle-program (executable-find "xprintidle") - "Name of the xprintidle program." - :group 'jabber-autoaway - :type 'string) - -(defcustom jabber-autoaway-verbose nil - "If nil, don't print autoaway status messages." - :group 'jabber-autoaway - :type 'boolean) - -(defvar jabber-autoaway-timer nil) - -(defvar jabber-autoaway-last-idle-time nil - "Seconds of idle time the last time we checked. -This is used to detect whether the user has become unidle.") - -(defun jabber-autoaway-message (&rest args) - (when jabber-autoaway-verbose - (apply #'message args))) - -;;;###autoload -(defun jabber-autoaway-start (&optional ignored) - "Start autoaway timer. -The IGNORED argument is there so you can put this function in -`jabber-post-connect-hooks'." - (interactive) - (unless jabber-autoaway-timer - (setq jabber-autoaway-timer - (run-with-timer (* jabber-autoaway-timeout 60) nil #'jabber-autoaway-timer)) - (jabber-autoaway-message "Autoaway timer started"))) - -(defun jabber-autoaway-stop () - "Stop autoaway timer." - (interactive) - (when jabber-autoaway-timer - (jabber-cancel-timer jabber-autoaway-timer) - (setq jabber-autoaway-timer nil) - (jabber-autoaway-message "Autoaway timer stopped"))) - -(defun jabber-autoaway-get-idle-time () - "Get idle time in seconds according to `jabber-autoaway-methods'. -Return nil on error." - (car (sort (mapcar 'funcall jabber-autoaway-methods) (lambda (a b) (if a (if b (< a b) t) nil))))) - -(defun jabber-autoaway-timer () - ;; We use one-time timers, so reset the variable. - (setq jabber-autoaway-timer nil) - (let ((idle-time (jabber-autoaway-get-idle-time))) - (when (numberp idle-time) - ;; Has "idle timeout" passed? - (if (> idle-time (* 60 jabber-autoaway-timeout)) - ;; If so, mark ourselves idle. - (jabber-autoaway-set-idle) - ;; Else, start a timer for the remaining amount. - (setq jabber-autoaway-timer - (run-with-timer (- (* 60 jabber-autoaway-timeout) idle-time) - nil #'jabber-autoaway-timer)))))) - -(defun jabber-autoaway-set-idle (&optional xa) - (jabber-autoaway-message "Autoaway triggered") - ;; Send presence, unless the user has set a custom presence - (unless (member *jabber-current-show* '("xa" "dnd")) - (jabber-send-presence - (if xa "xa" "away") - (if (or (string= *jabber-current-status* jabber-default-status) (string= *jabber-current-status* jabber-autoaway-status)) (if xa jabber-autoaway-xa-status jabber-autoaway-status) *jabber-current-status*) - (or (if xa jabber-autoaway-priority jabber-autoaway-xa-priority) *jabber-current-priority*))) - - (setq jabber-autoaway-last-idle-time (jabber-autoaway-get-idle-time)) - ;; Run unidle timer every 10 seconds (if xa specified, timer already running) - (unless xa - (setq jabber-autoaway-timer (run-with-timer 10 10 - #'jabber-autoaway-maybe-unidle)))) - -(defun jabber-autoaway-maybe-unidle () - (let ((idle-time (jabber-autoaway-get-idle-time))) - (jabber-autoaway-message "Idle for %d seconds" idle-time) - (if (member *jabber-current-show* '("xa" "away")) - ;; As long as idle time increases monotonically, stay idle. - (if (> idle-time jabber-autoaway-last-idle-time) - (progn - ;; Has "Xa timeout" passed? - (if (and (> jabber-autoaway-xa-timeout 0) (> idle-time (* 60 jabber-autoaway-xa-timeout))) - ;; iIf so, mark ourselves xa. - (jabber-autoaway-set-idle t)) - (setq jabber-autoaway-last-idle-time idle-time)) - ;; But if it doesn't, go back to unidle state. - (jabber-autoaway-message "Back to unidle") - ;; But don't mess with the user's custom presence. - (if (or (string= *jabber-current-status* jabber-autoaway-status) (string= *jabber-current-status* jabber-autoaway-xa-status)) - (jabber-send-default-presence) - (progn - (jabber-send-presence jabber-default-show *jabber-current-status* jabber-default-priority) - (jabber-autoaway-message "%S /= %S - not resetting presence" *jabber-current-status* jabber-autoaway-status))) - (jabber-autoaway-stop) - (jabber-autoaway-start))))) - -(defun jabber-xprintidle-get-idle-time () - "Get idle time through the xprintidle program." - (when jabber-xprintidle-program - (with-temp-buffer - (when (zerop (call-process jabber-xprintidle-program - nil t)) - (/ (string-to-number (buffer-string)) 1000.0))))) - -(defun jabber-termatime-get-idle-time () - "Get idle time through atime of terminal. -The method for finding the terminal only works on GNU/Linux." - (let ((terminal (cond - ((file-exists-p "/proc/self/fd/0") - "/proc/self/fd/0") - (t - nil)))) - (when terminal - (let* ((atime-of-tty (nth 4 (file-attributes terminal))) - (diff (time-to-seconds (time-since atime-of-tty)))) - (when (> diff 0) - diff))))) - -(defun jabber-current-idle-time () - "Get idle time through `current-idle-time'. -`current-idle-time' was introduced in Emacs 22." - (if (fboundp 'current-idle-time) - (let ((idle-time (current-idle-time))) - (if (null idle-time) - 0 - (float-time idle-time))))) - -(require 'time-date) - -(add-to-list 'jabber-jid-info-menu (cons "Request time" 'jabber-get-time)) - -(defun jabber-get-time (jc to) - "Request time. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Request time of: " - nil nil nil 'full t))) - - (jabber-send-iq jc to "get" - '(time ((xmlns . "urn:xmpp:time"))) - 'jabber-silent-process-data 'jabber-process-time - 'jabber-silent-process-data - (lambda (jc xml-data) - (let ((from (jabber-xml-get-attribute xml-data 'from))) - (jabber-get-legacy-time jc from))))) - -(defun jabber-get-legacy-time (jc to) - "Request legacy time. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Request time of: " - nil nil nil 'full t))) - - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:time"))) - 'jabber-silent-process-data 'jabber-process-legacy-time - 'jabber-silent-process-data "Time request failed")) - -;; called by jabber-process-data -(defun jabber-process-time (jc xml-data) - "Handle results from urn:xmpp:time requests. - -JC is the Jabber Connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (time (or (car (jabber-xml-get-children xml-data 'time)) - ;; adium response of qeury - (car (jabber-xml-get-children xml-data 'query)))) - (tzo (car (jabber-xml-node-children - (car (jabber-xml-get-children time 'tzo))))) - (utc (car (jabber-xml-node-children - (car (jabber-xml-get-children time 'utc)))))) - (when (and utc tzo) - (format "%s has time: %s %s" - from (format-time-string "%Y-%m-%d %T" (jabber-parse-time utc)) tzo)))) - -(defun jabber-process-legacy-time (jc xml-data) - "Handle results from jabber:iq:time requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (query (jabber-iq-query xml-data)) - (display - (car (jabber-xml-node-children - (car (jabber-xml-get-children - query 'display))))) - (utc - (car (jabber-xml-node-children - (car (jabber-xml-get-children - query 'utc))))) - (tz - (car (jabber-xml-node-children - (car (jabber-xml-get-children - query 'tz)))))) - (format "%s has time: %s" from - (cond - (display display) - (utc - (concat - (format-time-string "%Y-%m-%d %T" (jabber-parse-legacy-time utc)) - (when tz - (concat " " tz)))))))) -(defun jabber-get-last-online (jc to) - "Request time since a user was last online, or uptime of a component. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Get last online for: " - nil nil nil 'bare-or-muc))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:last"))) - #'jabber-silent-process-data #'jabber-process-last - #'jabber-silent-process-data "Last online request failed")) - -(defun jabber-get-idle-time (jc to) - "Request idle time of user. - -JC is the Jabber connection." - (interactive (list (jabber-read-account) - (jabber-read-jid-completing "Get idle time for: " - nil nil nil 'full t))) - (jabber-send-iq jc to - "get" - '(query ((xmlns . "jabber:iq:last"))) - #'jabber-silent-process-data #'jabber-process-last - #'jabber-silent-process-data "Idle time request failed")) - -(defun jabber-process-last (jc xml-data) - "Handle resultts from jabber:iq:last requests. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let* ((from (jabber-xml-get-attribute xml-data 'from)) - (query (jabber-iq-query xml-data)) - (seconds (jabber-xml-get-attribute query 'seconds)) - (message (car (jabber-xml-node-children query)))) - (cond - ((jabber-jid-resource from) - ;; Full JID: idle time - (format "%s idle for %s seconds" from seconds)) - ((jabber-jid-username from) - ;; Bare JID with username: time since online - (concat - (format "%s last online %s seconds ago" from seconds) - (let ((seconds (condition-case nil - (string-to-number seconds) - (error nil)))) - (when (numberp seconds) - (concat - " - that is, at " - (format-time-string "%Y-%m-%d %T" - (time-subtract (current-time) - (seconds-to-time seconds))) - "\n"))))) - (t - ;; Only hostname: uptime - (format "%s uptime: %s seconds" from seconds))))) - -(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:time" 'jabber-return-legacy-time)) -(jabber-disco-advertise-feature "jabber:iq:time") - -(defun jabber-return-legacy-time (jc xml-data) - "Return client time as defined in XEP-0090. -Sender and ID are determined from the incoming packet passed in XML-DATA. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id))) - (jabber-send-iq jc to "result" - `(query ((xmlns . "jabber:iq:time")) - ;; what is ``human-readable'' format? - ;; the same way as formating using by tkabber - (display () ,(format-time-string "%a %b %d %H:%M:%S %Z %Y")) - (tz () ,(format-time-string "%Z")) - (utc () ,(jabber-encode-legacy-time nil))) - nil nil nil nil - id))) - -(add-to-list 'jabber-iq-get-xmlns-alist (cons "urn:xmpp:time" 'jabber-return-time)) -(jabber-disco-advertise-feature "urn:xmpp:time") - -(defun jabber-return-time (jc xml-data) - "Return client time as defined in XEP-0202. -Sender and ID are determined from the incoming packet passed in XML-DATA. - -JC is the Jabber connection. -XML-DATA is the parsed tree data from the stream (stanzas) -obtained from `xml-parse-region'." - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id))) - (jabber-send-iq jc to "result" - `(time ((xmlns . "urn:xmpp:time")) - (utc () ,(jabber-encode-time nil)) - (tzo () ,(jabber-encode-timezone))) - nil nil nil nil - id))) - -(add-to-list 'jabber-iq-get-xmlns-alist (cons "jabber:iq:last" 'jabber-return-last)) -(jabber-disco-advertise-feature "jabber:iq:last") - -(defun jabber-return-last (jc xml-data) - (let ((to (jabber-xml-get-attribute xml-data 'from)) - (id (jabber-xml-get-attribute xml-data 'id))) - (jabber-send-iq jc to "result" - `(time ((xmlns . "jabber:iq:last") - ;; XEP-0012 specifies that this is an integer. - (seconds . ,(number-to-string - (floor (jabber-autoaway-get-idle-time)))))) - nil nil nil nil - id))) - -(require 'cl) - -(defvar jabber-log-lines-to-keep 1000 - "Maximum number of lines in chat buffer.") - -(defun jabber-truncate-top (buffer &optional ewoc) - "Clean old history from a chat BUFFER. -Optional EWOC is ewoc-widget to work. Default is `jabber-chat-ewoc' -`jabber-log-lines-to-keep' specifies the number of lines to -keep. - -Note that this might interfer with -`jabber-chat-display-more-backlog': you ask for more history, you -get it, and then it just gets deleted." - (interactive) - (let* ((inhibit-read-only t) - (work-ewoc (if ewoc ewoc jabber-chat-ewoc)) - (delete-before - ;; go back one node, to make this function "idempotent" - (ewoc-prev - work-ewoc - (ewoc-locate work-ewoc - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (forward-line (- jabber-log-lines-to-keep)) - (point)))))) - (while delete-before - (setq delete-before - (prog1 - (ewoc-prev work-ewoc delete-before) - (ewoc-delete work-ewoc delete-before)))))) - -(defun jabber-truncate-muc (nick group buffer text proposed-alert) - "Clean old history from MUC buffers. -`jabber-log-lines-to-keep' specifies the number of lines to -keep." - (jabber-truncate-top buffer)) - -(defun jabber-truncate-chat (from buffer text proposed-alert) - "Clean old history from chat buffers. -`jabber-log-lines-to-keep' specifies the number of lines to -keep. - -Note that this might interfer with -`jabber-chat-display-more-backlog': you ask for more history, you -get it, and then it just gets deleted." - (jabber-truncate-top buffer)) - -(defun jabber-carbon-success (jc xml-data context) - (when (equal "result" (jabber-xml-get-attribute xml-data 'type)) - (message "Carbons feature successfully enabled"))) - -(defun jabber-carbon-failure (jc xml-data context) - (message "Carbons feature could not be enabled: %S" xml-data)) - -(add-to-list 'jabber-jid-service-menu - (cons "Enable Carbons" 'jabber-enable-carbons)) -(defun jabber-enable-carbons (jc) - "Send request to enable XEP-0280 Message Carbons. - -JC is the Jabber connection." - (interactive (list (jabber-read-account))) - (jabber-send-iq jc - nil - "set" - `(enable ((xmlns . "urn:xmpp:carbons:2"))) - #'jabber-carbon-success "Carbons feature enablement" - #'jabber-carbon-failure "Carbons feature enablement")) - -(eval-when-compile (require 'cl)) -;;;###autoload -(eval-after-load "jabber-disco" - '(jabber-disco-advertise-feature "urn:xmpp:rtt:0")) -(defvar jabber-rtt-ewoc-node nil) -(make-variable-buffer-local 'jabber-rtt-ewoc-node) - -(defvar jabber-rtt-last-seq nil) -(make-variable-buffer-local 'jabber-rtt-last-seq) - -(defvar jabber-rtt-message nil) -(make-variable-buffer-local 'jabber-rtt-message) - -(defvar jabber-rtt-pending-events nil) -(make-variable-buffer-local 'jabber-rtt-pending-events) - -(defvar jabber-rtt-timer nil) -(make-variable-buffer-local 'jabber-rtt-timer) - -;;;###autoload -(eval-after-load "jabber-core" - '(add-to-list 'jabber-message-chain #'jabber-rtt-handle-message t)) - -;;;###autoload -(defun jabber-rtt-handle-message (jc xml-data) - ;; We could support this for MUC as well, if useful. - (when (and (not (jabber-muc-message-p xml-data)) - (get-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)))) - (with-current-buffer (jabber-chat-get-buffer (jabber-xml-get-attribute xml-data 'from)) - (let* ((rtt (jabber-xml-path xml-data '(("urn:xmpp:rtt:0" . "rtt")))) - (body (jabber-xml-path xml-data '(body))) - (seq (when rtt (jabber-xml-get-attribute rtt 'seq))) - (event (when rtt (or (jabber-xml-get-attribute rtt 'event) "edit"))) - (actions (when rtt (jabber-xml-node-children rtt))) - (inhibit-read-only t)) - (cond - ((or body (string= event "cancel")) - ;; A element supersedes real time text. - (jabber-rtt--reset)) - ((member event '("new" "reset")) - (jabber-rtt--reset) - (setq jabber-rtt-ewoc-node - (ewoc-enter-last jabber-chat-ewoc (list :notice "[typing...]")) - jabber-rtt-last-seq (string-to-number seq) - jabber-rtt-message "" - jabber-rtt-pending-events nil) - (jabber-rtt--enqueue-actions actions)) - ((string= event "edit") - ;; TODO: check whether this works properly in 32-bit Emacs - (cond - ((and jabber-rtt-last-seq - (equal (1+ jabber-rtt-last-seq) - (string-to-number seq))) - ;; We are in sync. - (setq jabber-rtt-last-seq (string-to-number seq)) - (jabber-rtt--enqueue-actions actions)) - (t - ;; TODO: show warning when not in sync - (message "out of sync! %s vs %s" - seq jabber-rtt-last-seq)) - )) - ;; TODO: handle event="init" - ))))) - -(defun jabber-rtt--reset () - (when jabber-rtt-ewoc-node - (ewoc-delete jabber-chat-ewoc jabber-rtt-ewoc-node)) - (when (timerp jabber-rtt-timer) - (cancel-timer jabber-rtt-timer)) - (setq jabber-rtt-ewoc-node nil - jabber-rtt-last-seq nil - jabber-rtt-message nil - jabber-rtt-pending-events nil - jabber-rtt-timer nil)) - -(defun jabber-rtt--enqueue-actions (new-actions) - (setq jabber-rtt-pending-events - ;; Ensure that the queue never contains more than 700 ms worth - ;; of wait events. - (jabber-rtt--fix-waits (append jabber-rtt-pending-events new-actions))) - (unless jabber-rtt-timer - (jabber-rtt--process-actions (current-buffer)))) - -(defun jabber-rtt--process-actions (buffer) - (with-current-buffer buffer - (setq jabber-rtt-timer nil) - (catch 'wait - (while jabber-rtt-pending-events - (let ((action (pop jabber-rtt-pending-events))) - (case (jabber-xml-node-name action) - ((t) - ;; insert text - (let* ((p (jabber-xml-get-attribute action 'p)) - (position (if p (string-to-number p) (length jabber-rtt-message)))) - (setq position (max position 0)) - (setq position (min position (length jabber-rtt-message))) - (setf (substring jabber-rtt-message position position) - (car (jabber-xml-node-children action))) - - (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) - (let ((inhibit-read-only t)) - (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node)))) - ((e) - ;; erase text - (let* ((p (jabber-xml-get-attribute action 'p)) - (position (if p (string-to-number p) (length jabber-rtt-message))) - (n (jabber-xml-get-attribute action 'n)) - (number (if n (string-to-number n) 1))) - (setq position (max position 0)) - (setq position (min position (length jabber-rtt-message))) - (setq number (max number 0)) - (setq number (min number position)) - ;; Now erase the NUMBER characters before POSITION. - (setf (substring jabber-rtt-message (- position number) position) - "") - - (ewoc-set-data jabber-rtt-ewoc-node (list :notice (concat "[typing...] " jabber-rtt-message))) - (let ((inhibit-read-only t)) - (ewoc-invalidate jabber-chat-ewoc jabber-rtt-ewoc-node)))) - ((w) - (setq jabber-rtt-timer - (run-with-timer - (/ (string-to-number (jabber-xml-get-attribute action 'n)) 1000.0) - nil - #'jabber-rtt--process-actions - buffer)) - (throw 'wait nil)))))))) - -(defun jabber-rtt--fix-waits (actions) - ;; Ensure that the sum of all wait events is no more than 700 ms. - (let ((sum 0)) - (dolist (action actions) - (when (eq (jabber-xml-node-name action) 'w) - (let ((n (jabber-xml-get-attribute action 'n))) - (setq n (string-to-number n)) - (when (>= n 0) - (setq sum (+ sum n)))))) - - (if (<= sum 700) - actions - (let ((scale (/ 700.0 sum))) - (mapcar - (lambda (action) - (if (eq (jabber-xml-node-name action) 'w) - (let ((n (jabber-xml-get-attribute action 'n))) - (setq n (string-to-number n)) - (setq n (max n 0)) - `(w ((n . ,(number-to-string (* scale n)))) nil)) - action)) - actions))))) - -(defvar jabber-rtt-send-timer nil) -(make-variable-buffer-local 'jabber-rtt-send-timer) - -(defvar jabber-rtt-send-seq nil) -(make-variable-buffer-local 'jabber-rtt-send-seq) - -(defvar jabber-rtt-outgoing-events nil) -(make-variable-buffer-local 'jabber-rtt-outgoing-events) - -(defvar jabber-rtt-send-last-timestamp nil) -(make-variable-buffer-local 'jabber-rtt-send-last-timestamp) - -;;;###autoload -(define-minor-mode jabber-rtt-send-mode - "Show text to recipient as it is being typed. -This lets the recipient see every change made to the message up -until it's sent. The recipient's client needs to implement -XEP-0301, In-Band Real Time Text." - nil " Real-Time" nil - (if (null jabber-rtt-send-mode) - (progn - (remove-hook 'after-change-functions #'jabber-rtt--queue-update t) - (remove-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent t) - (jabber-rtt--cancel-send)) - (unless (derived-mode-p 'jabber-chat-mode) - (error "Real Time Text only makes sense in chat buffers")) - (when (timerp jabber-rtt-send-timer) - (cancel-timer jabber-rtt-send-timer)) - (setq jabber-rtt-send-timer nil - jabber-rtt-send-seq nil - jabber-rtt-outgoing-events nil - jabber-rtt-send-last-timestamp nil) - (jabber-rtt--send-current-text nil) - (add-hook 'after-change-functions #'jabber-rtt--queue-update nil t) - (add-hook 'jabber-chat-send-hooks #'jabber-rtt--message-sent nil t))) - -(defun jabber-rtt--cancel-send () - (when (timerp jabber-rtt-send-timer) - (cancel-timer jabber-rtt-send-timer)) - (setq jabber-rtt-send-seq (1+ jabber-rtt-send-seq)) - (jabber-send-sexp jabber-buffer-connection - `(message ((to . ,jabber-chatting-with) - (type . "chat")) - (rtt ((xmlns . "urn:xmpp:rtt:0") - (seq . ,(number-to-string jabber-rtt-send-seq)) - (event . "cancel")) - nil))) - (setq jabber-rtt-send-timer nil - jabber-rtt-send-seq nil - jabber-rtt-outgoing-events nil - jabber-rtt-send-last-timestamp nil)) - -(defun jabber-rtt--send-current-text (resetp) - (let ((text (buffer-substring-no-properties jabber-point-insert (point-max)))) - ;; This should give us enough room to avoid wrap-arounds, even - ;; with just 28 bits... - (setq jabber-rtt-send-seq (random 100000)) - (jabber-send-sexp jabber-buffer-connection - `(message ((to . ,jabber-chatting-with) - (type . "chat")) - (rtt ((xmlns . "urn:xmpp:rtt:0") - (seq . ,(number-to-string jabber-rtt-send-seq)) - (event . ,(if resetp "reset" "new"))) - (t () ,text)))))) - -(defun jabber-rtt--queue-update (beg end pre-change-length) - (unless (or (< beg jabber-point-insert) - (< end jabber-point-insert)) - (let ((timestamp (current-time))) - (when jabber-rtt-send-last-timestamp - (let* ((time-difference (time-subtract timestamp jabber-rtt-send-last-timestamp)) - (interval (truncate (* 1000 (float-time time-difference))))) - (when (and (> interval 0) - ;; Don't send too long intervals - this should have - ;; been sent by our timer already. - (< interval 1000)) - (push `(w ((n . ,(number-to-string interval))) nil) - jabber-rtt-outgoing-events)))) - (setq jabber-rtt-send-last-timestamp timestamp)) - - (when (> pre-change-length 0) - ;; Some text was deleted. Let's check if we can use a shorter - ;; tag: - (let ((at-end (= end (point-max))) - (erase-one (= pre-change-length 1))) - (push `(e ( - ,@(unless at-end - `((p . ,(number-to-string - (+ beg - (- jabber-point-insert) - pre-change-length))))) - ,@(unless erase-one - `((n . ,(number-to-string pre-change-length)))))) - jabber-rtt-outgoing-events))) - - (when (/= beg end) - ;; Some text was inserted. - (let ((text (buffer-substring-no-properties beg end)) - (at-end (= end (point-max)))) - (push `(t ( - ,@(unless at-end - `((p . ,(number-to-string (- beg jabber-point-insert)))))) - ,text) - jabber-rtt-outgoing-events))) - - (when (null jabber-rtt-send-timer) - (setq jabber-rtt-send-timer - (run-with-timer 0.7 nil #'jabber-rtt--send-queued-events (current-buffer)))))) - -(defun jabber-rtt--send-queued-events (buffer) - (with-current-buffer buffer - (setq jabber-rtt-send-timer nil) - (when jabber-rtt-outgoing-events - (let ((event (if jabber-rtt-send-seq "edit" "new"))) - (setq jabber-rtt-send-seq - (if jabber-rtt-send-seq - (1+ jabber-rtt-send-seq) - (random 100000))) - (jabber-send-sexp jabber-buffer-connection - `(message ((to . ,jabber-chatting-with) - (type . "chat")) - (rtt ((xmlns . "urn:xmpp:rtt:0") - (seq . ,(number-to-string jabber-rtt-send-seq)) - (event . ,event)) - ,@(nreverse jabber-rtt-outgoing-events)))) - (setq jabber-rtt-outgoing-events nil))))) - -(defun jabber-rtt--message-sent (_text _id) - ;; We're sending a element; reset our state - (when (timerp jabber-rtt-send-timer) - (cancel-timer jabber-rtt-send-timer)) - (setq jabber-rtt-send-timer nil - jabber-rtt-send-seq nil - jabber-rtt-outgoing-events nil - jabber-rtt-send-last-timestamp nil)) - -;;; load Unicode tables if this needed -(when (and (featurep 'xemacs) (not (emacs-version>= 21 5 5))) - (require 'un-define)) -;;; these customize fields should come first -(defgroup jabber nil "Jabber instant messaging" - :group 'applications) -;;;###autoload -(defcustom jabber-account-list nil - "List of Jabber accounts. -Each element of the list is a cons cell describing a Jabber account, -where the car is a JID and the CDR is an alist. - -JID is a full Jabber ID string (e.g. foo@bar.tld). You can also -specify the resource (e.g. foo@bar.tld/emacs). -The following keys can be present in the alist: - - :password is a string to authenticate ourself against the server. - It can be empty. If you don't want to store your password in your - Emacs configuration, try auth-source (info node `(auth)Top'). - - :network-server is a string identifying the address to connect to, - if it's different from the server part of the JID. - - :port is the port to use (default depends on connection type). - - :connection-type is a symbol. Valid symbols are `starttls', - `network' and `ssl'. - -Only JID is mandatory. The rest can be guessed at run-time. - -Examples: - -Two accounts without any special configuration: -\((\"foo@example.com\") (\"bar@example.net\")) - -One disabled account with a non-standard port: -\((\"romeo@montague.net\" (:port . 5242) (:disabled . t))) - -If you don't have SRV and STARTTLS capabilities in your Emacs, -configure a Google Talk account like this: -\((\"username@gmail.com\" - (:network-server . \"talk.google.com\") - (:connection-type . ssl)))" - :type '(repeat - (cons :tag "Account information" - (string :tag "JID") - (set :format "%v" - (cons :format "%v" - (const :format "" :disabled) - (const :tag "Disabled" t)) - (cons :format "%v" - (const :format "" :password) - (string :tag "Password")) - (cons :format "%v" - (const :format "" :network-server) - (string :tag "Network server")) - (cons :format "%v" - (const :format "" :port) - (integer :tag "Port" 5222)) - (cons :format "%v" - (const :format "" :connection-type) - (choice :tag "Connection type" - ;; XXX: detect whether we have STARTTLS? option - ;; for enforcing encryption? - (const :tag "STARTTLS" starttls) - (const :tag "Unencrypted" network) - (const :tag "Legacy SSL/TLS" ssl)))))) - :group 'jabber) - -(defcustom jabber-default-show "" - "Default show state." - :type '(choice (const :tag "Online" "") - (const :tag "Chatty" "chat") - (const :tag "Away" "away") - (const :tag "Extended away" "xa") - (const :tag "Do not disturb" "dnd")) - :group 'jabber) - -(defcustom jabber-default-status "" - "Default status string." - :type 'string - :group 'jabber) - -(defcustom jabber-default-priority 10 - "Default priority." - :type 'integer - :group 'jabber) - -;;;###autoload -(defvar *jabber-current-status* nil - "The users current presence status.") - -;;;###autoload -(defvar *jabber-current-show* nil - "The users current presence show.") - -;;;###autoload -(defvar *jabber-current-priority* nil - "The user's current priority.") - -(defvar *jabber-status-history* nil - "History of status messages.") - -(defgroup jabber-faces nil "Faces for displaying jabber instant messaging." - :group 'jabber) - -(defface jabber-title-small - '((t (:weight bold :width semi-expanded :height 1.0 :inherit variable-pitch))) - "Face for small titles." - :group 'jabber-faces) - -(defface jabber-title-medium - '((t (:weight bold :width expanded :height 2.0 :inherit variable-pitch))) - "Face for medium titles." - :group 'jabber-faces) - -(defface jabber-title-large - '((t (:weight bold :width ultra-expanded :height 3.0 :inherit variable-pitch))) - "Face for large titles." - :group 'jabber-faces) - -(defgroup jabber-debug nil "debugging options" - :group 'jabber) - -(defcustom jabber-debug-log-xml nil - "Set to non-nil to log all XML i/o in *-jabber-console-JID-* buffer. -Set to string to also dump XML i/o in specified file." - :type '(choice (const :tag "Do not dump XML i/o" nil) - (const :tag "Dump XML i/o in console" t) - (string :tag "Dump XML i/o in console and this file")) - :group 'jabber-debug) - -(defcustom jabber-debug-keep-process-buffers nil - "If nil, kill process buffers when the process dies. -Contents of process buffers might be useful for debugging." - :type 'boolean - :group 'jabber-debug) - -(defcustom jabber-silent-mode nil - "If non-nil, do not ask for confirmation for some operations. DANGEROUS!" - :type 'boolean - :group 'jabber) - -;;;###autoload -(defconst jabber-presence-faces - '(("" . jabber-roster-user-online) - ("away" . jabber-roster-user-away) - ("xa" . jabber-roster-user-xa) - ("dnd" . jabber-roster-user-dnd) - ("chat" . jabber-roster-user-chatty) - ("error" . jabber-roster-user-error) - (nil . jabber-roster-user-offline)) - "Mapping from presence types to faces.") - -(defconst jabber-presence-strings - `(("" . ,(jabber-propertize "Online" 'face 'jabber-roster-user-online)) - ("away" . ,(jabber-propertize "Away" 'face 'jabber-roster-user-away)) - ("xa" . ,(jabber-propertize "Extended Away" 'face 'jabber-roster-user-xa)) - ("dnd" . ,(jabber-propertize "Do not Disturb" 'face 'jabber-roster-user-dnd)) - ("chat" . ,(jabber-propertize "Chatty" 'face 'jabber-roster-user-chatty)) - ("error" . ,(jabber-propertize "Error" 'face 'jabber-roster-user-error)) - (nil . ,(jabber-propertize "Offline" 'face 'jabber-roster-user-offline))) - "Mapping from presence types to readable, colorized strings.") - -;;;###autoload -(defun jabber-customize () - "Customize jabber options." - (interactive) - (customize-group 'jabber)) - -;;;###autoload -(defun jabber-info () - "Open jabber.el manual." - (interactive) - (info "jabber")) +(literate-elisp-load (format "%sjabber.org" (file-name-directory load-file-name))) (provide 'jabber) ;;; jabber.el ends here - diff --git a/jabber.org b/jabber.org index 1120a49..2016e40 100644 --- a/jabber.org +++ b/jabber.org @@ -44,7 +44,7 @@ Note that only the connection from you to the server is encrypted; there is no g *** Installation jabber.el can be installed using the commands: -#+BEGIN_SRC +#+BEGIN_SRC shell ./configure make make install @@ -149,11 +149,13 @@ It is possible to make various web browsers pass links starting with "xmpp:" to 3. [ ] hexrgb.el is not available on MELPA ** About this file -jabber.el is an Org literate program. +jabber.el is an Org literate program. We use =literate-elisp= to directly load/compile this Org file. The former is exactly what the file =jabber.el= does - this approach is also compatible with =use-package= and others. The advantages - +1. links to the source (e.g. =describe-*= buffers, byte-compilation messages) take the user directly to the Org file rather than to the tangled source +2. no waiting for =org-babel-tangle= (which takes ages) +3. no need to track tangled files files in VCS, nor ensure they are kept in sync with the Org file +4. no VCS hooks/CI required to automatically tangle the file -=org-babel-tangle= takes ages, so we use a little sed one-liner (in the file-local variables) to do the tangling, which is nearly instant. The sed script emits anything between lines matching the exact strings "#+BEGIN_SRC emacs-lisp" and "#+END_SRC". - -The sed script has the advantage that one can break a source block to insert Org commentary even within a =defun=, if desired - see =jabber-caps-ver-string= for a situation where such commentary may be desired. However, doing this may cause other tooling working on the s-expression level to break - =literate-elisp= definitely does. +Note that some tools, like =checkdoc=, still require a tangled file as of the time of this writing. If a source block does not have syntax highlighting, press =M-o M-o= (=font-lock-fontify-block=) in it. @@ -210,9 +212,13 @@ If a source block does not have syntax highlighting, press =M-o M-o= (=font-lock #+END_SRC ** Code +*** custom variables +#+BEGIN_SRC emacs-lisp +(defvar jabber-enable-legacy-features-p nil) +#+END_SRC *** XML functions :PROPERTIES: -:file: jabber-xml.el +:old-file: jabber-xml.el :END: #+BEGIN_SRC emacs-lisp @@ -522,7 +528,7 @@ ATTRIBUTES is a list of attribute names." #+END_SRC *** various utility functions :PROPERTIES: -:file: jabber-util.el +:old-file: jabber-util.el :END: #+BEGIN_SRC emacs-lisp @@ -1429,7 +1435,7 @@ FN is applied to the node and not to the data itself." #+END_SRC *** menu :PROPERTIES: -:file: jabber-menu.el +:old-file: jabber-menu.el :END: #+BEGIN_SRC emacs-lisp @@ -1664,7 +1670,7 @@ This used to be: =(define-key-after global-map [menu-bar jabber-menu] ...)= but #+END_SRC *** Network transport functions :PROPERTIES: -:file: jabber-conn.el +:old-file: jabber-conn.el :END: A collection of functions, that hide the details of transmitting to and fro a Jabber Server. Mostly inspired by Gnus. @@ -2114,7 +2120,7 @@ Use `*jabber-virtual-server-function*' as send function." #+END_SRC *** SASL authentication :PROPERTIES: -:file: jabber-sasl.el +:old-file: jabber-sasl.el :END: #+BEGIN_SRC emacs-lisp @@ -2271,7 +2277,7 @@ obtained from `xml-parse-region'." #+END_SRC *** common keymap for many modes :PROPERTIES: -:file: jabber-keymap.el +:old-file: jabber-keymap.el :END: #+BEGIN_SRC emacs-lisp ;; button.el was introduced in Emacs 22 @@ -2323,8 +2329,9 @@ obtained from `xml-parse-region'." #+END_SRC *** XML Console mode :PROPERTIES: -:file: jabber-console.el +:old-file: jabber-console.el :END: + #+BEGIN_SRC emacs-lisp (require 'ewoc) (require 'sgml-mode) ;we base on this mode to hightlight XML @@ -2489,7 +2496,7 @@ what kind of chat buffer is being created.") #+END_SRC *** core :PROPERTIES: -:file: jabber-core.el +:old-file: jabber-core.el :END: Standards (probably) involved - @@ -3647,7 +3654,7 @@ Return an fsm result list if it is." #+END_SRC *** logon :PROPERTIES: -:file: jabber-logon.el +:old-file: jabber-logon.el :END: In Emacs 24, sha1 is built in, so this =require= is only needed for earlier versions. It's supposed to be a noop in Emacs 24, but sometimes, for some people, it isn't, and fails with =(file-error "Cannot open load file" "sha1")=. @@ -3726,7 +3733,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Displaying the roster :PROPERTIES: -:file: jabber-roster.el +:old-file: jabber-roster.el :END: #+BEGIN_SRC emacs-lisp @@ -4768,7 +4775,7 @@ obtained from `xml-parse-region'." #+END_SRC *** export Jabber roster to file :PROPERTIES: -:file: jabber-export.el +:old-file: jabber-export.el :END: #+BEGIN_SRC emacs-lisp @@ -5039,7 +5046,7 @@ See `jabber-roster-to-sexp' for description of output format." *** infoquery (IQ) functions :PROPERTIES: -:file: jabber-iq.el +:old-file: jabber-iq.el :END: **** *jabber-open-info-queries* :variable: @@ -5286,7 +5293,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Alert hooks :PROPERTIES: -:file: jabber-alert.el +:old-file: jabber-alert.el :END: #+BEGIN_SRC emacs-lisp @@ -5941,7 +5948,7 @@ of `jabber-autoanswer-alist'." #+END_SRC *** FIXME Recording message history :PROPERTIES: -:file: jabber-history.el +:old-file: jabber-history.el :END: 1. [ ] when rotation is enabled, =jabber-history-query= won't look for older history files if the current history file doesn't contain enough backlog entries. @@ -6318,7 +6325,7 @@ applies, though." #+END_SRC *** Functions common to all chat buffers :PROPERTIES: -:file: jabber-chatbuffer.el +:old-file: jabber-chatbuffer.el :END: **** jabber-point-insert :variable: @@ -6472,7 +6479,7 @@ JC is the Jabber connection." #+END_SRC *** Compose a Jabber message in a buffer :PROPERTIES: -:file: jabber-compose.el +:old-file: jabber-compose.el :END: **** jabber-compose :command: #+BEGIN_SRC emacs-lisp @@ -6541,7 +6548,7 @@ JC is the Jabber connection." *** One-to-one chats :PROPERTIES: -:file: jabber-chat.el +:old-file: jabber-chat.el :END: #+BEGIN_SRC emacs-lisp @@ -7382,7 +7389,7 @@ With a prefix argument, open buffer in other window." #+END_SRC *** Roster and presence bookkeeping :PROPERTIES: -:file: jabber-presence.el +:old-file: jabber-presence.el :END: **** jabber-presence-element-functions :variable: @@ -8020,7 +8027,7 @@ JC is the Jabber connection." #+END_SRC *** Entity Capabilities ([[https://xmpp.org/extensions/xep-0115.html][XEP-0115]]) :PROPERTIES: -:file: jabber-disco.el +:old-file: jabber-disco.el :END: #+BEGIN_SRC emacs-lisp @@ -8376,7 +8383,7 @@ the right node." #+END_SRC *** Service Discovery ([[https://xmpp.org/extensions/xep-0030.html][XEP-0030]]) :PROPERTIES: -:file: jabber-disco.el +:old-file: jabber-disco.el :END: **** Respond to disco requests ***** jabber-advertised-features :variable: @@ -8786,7 +8793,7 @@ JC is the Jabber connection." *** XMPP Ping ([[https://xmpp.org/extensions/xep-0199.html][XEP-0199]]) :PROPERTIES: -:file: jabber-ping.el +:old-file: jabber-ping.el :END: #+BEGIN_SRC emacs-lisp @@ -8849,7 +8856,7 @@ obtained from `xml-parse-region'." *** keepalive - try to detect a lost connection :PROPERTIES: -:file: jabber-keepalive.el +:old-file: jabber-keepalive.el :END: Send something to the server and see if it answers. @@ -9049,7 +9056,7 @@ accounts." *** Feature Negotiation ([[https://xmpp.org/extensions/xep-0020.html][XEP-0020]]) :xep_deprecated: :PROPERTIES: -:file: jabber-feature-neg.el +:old-file: jabber-feature-neg.el :END: #+BEGIN_SRC emacs-lisp @@ -9168,7 +9175,7 @@ protocols." #+END_SRC *** widget - display various kinds of forms :PROPERTIES: -:file: jabber-widget.el +:old-file: jabber-widget.el :END: #+BEGIN_SRC emacs-lisp @@ -9561,7 +9568,7 @@ Return nil if no form type is specified." #+END_SRC *** Bookmarks ([[https://xmpp.org/extensions/xep-0048.html][XEP-0048]]) :xep_deprecated: :PROPERTIES: -:file: jabber-bookmarks.el +:old-file: jabber-bookmarks.el :END: #+BEGIN_SRC emacs-lisp @@ -9829,7 +9836,7 @@ JC is the Jabber connection." #+END_SRC *** Private XML Storage ([[https://xmpp.org/extensions/xep-0049.html][XEP-0049]]) :PROPERTIES: -:file: jabber-private.el +:old-file: jabber-private.el :END: **** jabber-private-get :function: @@ -9879,7 +9886,7 @@ JC is the Jabber connection." #+END_SRC *** muc-nick-coloring :PROPERTIES: -:file: jabber-muc-nick-coloring.el +:old-file: jabber-muc-nick-coloring.el :END: #+BEGIN_SRC emacs-lisp @@ -9964,7 +9971,7 @@ added in #RGB notation for unknown nicks." #+END_SRC *** Multi-User Chat (MUC) ([[https://xmpp.org/extensions/xep-0045.html][XEP-0045]]) :PROPERTIES: -:file: jabber-muc.el +:old-file: jabber-muc.el :END: #+BEGIN_SRC emacs-lisp @@ -11418,7 +11425,7 @@ JC is the Jabber connection." #+END_SRC *** muc-nick-completion :PROPERTIES: -:file: jabber-muc-nick-completion.el +:old-file: jabber-muc-nick-completion.el :END: **** jabber-muc-completion-delimiter :custom:variable: @@ -11629,7 +11636,7 @@ OLD is last tried nickname." #+END_SRC *** In-Band Registration ([[https://xmpp.org/extensions/xep-0077.html][XEP-0077]]) :PROPERTIES: -:file: jabber-register.el +:old-file: jabber-register.el :END: **** jabber-get-register :command: @@ -11776,7 +11783,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Jabber Search ([[https://xmpp.org/extensions/xep-0055.html][XEP-0055]]) :PROPERTIES: -:file: jabber-search.el +:old-file: jabber-search.el :END: **** jabber-get-search :command: @@ -11882,7 +11889,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Jabber Browsing ([[https://xmpp.org/extensions/xep-0011.html][XEP-0011]]) :xep_obsolete: :PROPERTIES: -:file: jabber-browse.el +:old-file: jabber-browse.el :END: jabber.el can perform browse requests, but will not answer them. @@ -11970,7 +11977,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Software Version ([[https://xmpp.org/extensions/xep-0092.html][XEP-0092]]) :PROPERTIES: -:file: jabber-version.el +:old-file: jabber-version.el :END: #+BEGIN_SRC emacs-lisp @@ -12058,7 +12065,7 @@ JC is the Jabber connection." #+END_SRC *** Ad Hoc Commands ([[https://xmpp.org/extensions/xep-0050.html][XEP-0050]]) :PROPERTIES: -:file: jabber-ahc.el +:old-file: jabber-ahc.el :END: **** jabber-ahc-sessionid :variable: @@ -12310,7 +12317,7 @@ JC is the Jabber connection." #+END_SRC *** ahc-presence - provide remote control of presence :PROPERTIES: -:file: jabber-ahc-presence.el +:old-file: jabber-ahc-presence.el :END: **** jabber-ahc-presence-node :constant: @@ -12409,7 +12416,7 @@ obtained from `xml-parse-region'." #+END_SRC *** Mode line :PROPERTIES: -:file: jabber-modeline.el +:old-file: jabber-modeline.el :END: #+BEGIN_SRC emacs-lisp @@ -12518,11 +12525,11 @@ and offline contacts, respectively." #+END_SRC *** watch - get notified when certain persons go online :PROPERTIES: -:file: jabber-watch.el +:old-file: jabber-watch.el :END: **** jabber-watch-alist :custom:variable: -#+BEGIN_QUOTE +#+BEGIN_SRC emacs-lisp (defcustom jabber-watch-alist nil "Alist of buddies for which an extra notification should be sent when they come online, with comment strings as values." @@ -12584,7 +12591,7 @@ calling `jabber-watch-add' and `jabber-watch-remove'." #+END_SRC *** activity - show Jabber activity in the mode line :PROPERTIES: -:file: jabber-activity.el +:old-file: jabber-activity.el :END: Allows tracking messages from buddies using the global mode line. See =(info "(jabber)Tracking activity")= @@ -13103,7 +13110,7 @@ With a numeric arg, enable this display if arg is positive." #+END_SRC *** Message Events ([[https://xmpp.org/extensions/xep-0022.html][XEP-0022]]) :xep_obsolete: :PROPERTIES: -:file: jabber-events.el +:old-file: jabber-events.el :END: #+BEGIN_SRC emacs-lisp @@ -13388,7 +13395,7 @@ Add function last in chain, so a chat buffer is already created. #+END_SRC *** Chat State Notifications ([[https://xmpp.org/extensions/xep-0085.html][XEP-0085]]) :PROPERTIES: -:file: jabber-chatstates.el +:old-file: jabber-chatstates.el :END: **** TODO @@ -13594,7 +13601,7 @@ It can be sent and cancelled several times.") #+END_SRC *** Generic functions for avatars :PROPERTIES: -:file: jabber-avatar.el +:old-file: jabber-avatar.el :END: There are several methods for transporting avatars in Jabber ([[https://xmpp.org/extensions/xep-0008.html][XEP-0008: IQ-Based Avatars]], [[https://xmpp.org/extensions/xep-0084.html][XEP-0084: User Avatar]], [[https://xmpp.org/extensions/xep-0153.html][XEP-0153: vCard-Based Avatars]]). They all have in common that they identify avatars by their SHA1 checksum, and (at least partially) use Base64-encoded image data. Thus this library of support functions for interpreting and caching avatars. @@ -13846,7 +13853,7 @@ available." #+END_SRC *** vCard ([[https://xmpp.org/extensions/xep-0054.html][XEP-0054]]) :PROPERTIES: -:file: jabber-vcard.el +:old-file: jabber-vcard.el :END: There are great variations in Jabber vcard implementations. This one adds some spice to the mix, while trying to follow the XEP closely. @@ -14417,7 +14424,7 @@ obtained from `xml-parse-region'." #+END_SRC *** vCard-Based Avatars ([[https://xmpp.org/extensions/xep-0153.html][XEP-0153]]) :PROPERTIES: -:file: jabber-vcard-avatars.el +:old-file: jabber-vcard-avatars.el :END: #+BEGIN_SRC emacs-lisp @@ -14565,7 +14572,7 @@ JC is the Jabber connection." #+END_SRC *** autoaway :PROPERTIES: -:file: jabber-autoaway.el +:old-file: jabber-autoaway.el :END: #+BEGIN_SRC emacs-lisp @@ -14825,7 +14832,7 @@ The method for finding the terminal only works on GNU/Linux." #+END_SRC *** Entity Time ([[https://xmpp.org/extensions/xep-0202.html][XEP-0202]]), Legacy Entity Time ([[https://xmpp.org/extensions/xep-0090.html][XEP-0090]]) :xep_obsolete: :PROPERTIES: -:file: jabber-time.el +:old-file: jabber-time.el :END: #+BEGIN_SRC emacs-lisp @@ -15071,7 +15078,7 @@ obtained from `xml-parse-region'." #+END_SRC *** truncate - cleanup top lines in chatbuffers :PROPERTIES: -:file: jabber-truncate.el +:old-file: jabber-truncate.el :END: #+BEGIN_SRC emacs-lisp @@ -15139,7 +15146,7 @@ get it, and then it just gets deleted." #+END_SRC *** Message Carbons ([[https://xmpp.org/extensions/xep-0280.html][XEP-0280]]) :PROPERTIES: -:file: jabber-carbons.el +:old-file: jabber-carbons.el :END: **** jabber-carbon-success :function: @@ -15171,10 +15178,1163 @@ JC is the Jabber connection." #'jabber-carbon-success "Carbons feature enablement" #'jabber-carbon-failure "Carbons feature enablement")) +#+END_SRC +*** Stream Initiation (SI) ([[https://xmpp.org/extensions/xep-0095.html][XEP-0095]]) :xep_deprecated: +**** common +:PROPERTIES: +:file: jabber-si-common.el +:END: + +***** jabber-si-stream-methods :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-si-stream-methods nil + "Supported SI stream methods. + +Each entry is a list, containing: + * The namespace URI of the stream method + * Active initiation function + * Passive initiation function + +The active initiation function should initiate the connection, +while the passive initiation function should wait for an incoming +connection. Both functions take the same arguments: + + * JID of peer + * SID + * \"connection established\" function + +The \"connection established\" function should be called when the +stream has been established and data can be transferred. It is part +of the profile, and takes the following arguments: + + * JID of peer + * SID + * Either: + - \"send data\" function, with one string argument + - an error message, when connection failed + +It returns an \"incoming data\" function. + +The \"incoming data\" function should be called when data arrives on +the stream. It takes these arguments: + + * JID of peer + * SID + * A string containing the received data, or nil on EOF + +If it returns nil, the stream should be closed.") + +#+END_SRC +**** client +:PROPERTIES: +:file: jabber-si-client.el +:END: + +***** jabber-si-initiate :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-si-initiate (jc jid profile-namespace profile-data profile-function &optional mime-type) + "Try to initiate a stream to JID. +PROFILE-NAMESPACE is, well, the namespace of the profile to use. +PROFILE-DATA is the XML data to send within the SI request. +PROFILE-FUNCTION is the \"connection established\" function. +See `jabber-si-stream-methods'. +MIME-TYPE is the MIME type to specify. +Returns the SID." + + (let ((sid (apply 'format "emacs-sid-%d.%d.%d" (current-time)))) + (jabber-send-iq jc jid "set" + `(si ((xmlns . "http://jabber.org/protocol/si") + (id . ,sid) + ,(if mime-type + (cons 'mime-type mime-type)) + (profile . ,profile-namespace)) + ,profile-data + (feature ((xmlns . "http://jabber.org/protocol/feature-neg")) + ,(jabber-fn-encode (list + (cons "stream-method" + (mapcar 'car jabber-si-stream-methods))) + 'request))) + #'jabber-si-initiate-process (cons profile-function sid) + ;; XXX: use other function here? + #'jabber-report-success "Stream initiation") + sid)) + +#+END_SRC +***** jabber-si-initiate-process :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-si-initiate-process (jc xml-data closure-data) + "Act on response to our SI query." + + (let* ((profile-function (car closure-data)) + (sid (cdr closure-data)) + (from (jabber-xml-get-attribute xml-data 'from)) + (query (jabber-iq-query xml-data)) + (feature-node (car (jabber-xml-get-children query 'feature))) + (feature-alist (jabber-fn-parse feature-node 'response)) + (chosen-method (cadr (assoc "stream-method" feature-alist))) + (method-data (assoc chosen-method jabber-si-stream-methods))) + ;; Our work is done. Hand it over to the stream method. + (let ((stream-negotiate (nth 1 method-data))) + (funcall stream-negotiate jc from sid profile-function)))) + +#+END_SRC +**** server +:PROPERTIES: +:file: jabber-si-server.el +:END: + +#+BEGIN_SRC emacs-lisp +(jabber-disco-advertise-feature "http://jabber.org/protocol/si") + +#+END_SRC +***** jabber-si-profiles :variable: +Now, stream methods push data to profiles. It could be the other way around; not sure which is better. + +#+BEGIN_SRC emacs-lisp +(defvar jabber-si-profiles nil + "Supported SI profiles. + +Each entry is a list, containing: + * The namespace URI of the profile + * Accept function, taking entire IQ stanza, and signalling a 'forbidden' + error if request is declined; returning an XML node to return in + response, or nil of none needed + * \"Connection established\" function. See `jabber-si-stream-methods'.") + +#+END_SRC +***** jabber-si-process :function: +#+BEGIN_SRC emacs-lisp +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "http://jabber.org/protocol/si" 'jabber-si-process)) +(defun jabber-si-process (jc xml-data) + + (let* ((to (jabber-xml-get-attribute xml-data 'from)) + (id (jabber-xml-get-attribute xml-data 'id)) + (query (jabber-iq-query xml-data)) + (profile (jabber-xml-get-attribute query 'profile)) + (si-id (jabber-xml-get-attribute query 'id)) + (feature (car (jabber-xml-get-children query 'feature)))) + (message "Receiving SI with profile '%s'" profile) + + (let (stream-method + ;; Find profile + (profile-data (assoc profile jabber-si-profiles))) + ;; Now, feature negotiation for stream type (errors + ;; don't match XEP-0095, so convert) + (condition-case err + (setq stream-method (jabber-fn-intersection + (jabber-fn-parse feature 'request) + (list (cons "stream-method" (mapcar 'car jabber-si-stream-methods))))) + (jabber-error + (jabber-signal-error "cancel" 'bad-request nil + '((no-valid-streams ((xmlns . "http://jabber.org/protocol/si"))))))) + (unless profile-data + ;; profile not understood + (jabber-signal-error "cancel" 'bad-request nil + '((bad-profile ((xmlns . "http://jabber.org/protocol/si")))))) + (let* ((profile-accept-function (nth 1 profile-data)) + ;; accept-function might throw a "forbidden" error + ;; on user cancel + (profile-response (funcall profile-accept-function jc xml-data)) + (profile-connected-function (nth 2 profile-data)) + (stream-method-id (nth 1 (assoc "stream-method" stream-method))) + (stream-data (assoc stream-method-id jabber-si-stream-methods)) + (stream-accept-function (nth 2 stream-data))) + ;; prepare stream for the transfer + (funcall stream-accept-function jc to si-id profile-connected-function) + ;; return result of feature negotiation of stream type + (jabber-send-iq jc to "result" + `(si ((xmlns . "http://jabber.org/protocol/si")) + ,@profile-response + (feature ((xmlns . "http://jabber.org/protocol/feature-neg")) + ,(jabber-fn-encode stream-method 'response))) + nil nil nil nil + id) + )))) + +#+END_SRC +*** SI File Transfer ([[https://xmpp.org/extensions/xep-0096.html][XEP-0096]]) :xep_deprecated: +**** common +:PROPERTIES: +:file: jabber-ft-common.el +:END: + +***** jabber-ft-md5sum-program :custom:variable: +#+BEGIN_SRC emacs-lisp +(defcustom jabber-ft-md5sum-program (or (when (executable-find "md5") + (list (executable-find "md5") "-n")) + (when (executable-find "md5sum") + (list (executable-find "md5sum")))) + "The program to use to calculate MD5 sums of files. +The first item should be the name of the program, and the remaing +items the arguments. The file name is appended as the last +argument." + :type '(repeat string) + :group 'jabber) + +#+END_SRC +***** jabber-ft-get-md5 :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-get-md5 (file-name) + "Get MD5 sum of FILE-NAME, and return as hex string. +Return nil if no MD5 summing program is available." + (when jabber-ft-md5sum-program + (with-temp-buffer + (apply 'call-process (car jabber-ft-md5sum-program) nil t nil + (append (cdr jabber-ft-md5sum-program) (list file-name))) + ;; Output is "hexsum filename" + (goto-char (point-min)) + (forward-word 1) + (buffer-substring (point-min) (point))))) + +#+END_SRC +**** client +:PROPERTIES: +:file: jabber-ft-client.el +:END: + +#+BEGIN_SRC emacs-lisp +(eval-when-compile (require 'cl)) + +#+END_SRC +***** jabber-ft-send :command: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-send (jc jid filename desc) + "Attempt to send FILENAME to JID." + (interactive (list (jabber-read-account) + (jabber-read-jid-completing "Send file to: " nil nil nil 'full t) + (read-file-name "Send which file: " nil nil t) + (jabber-read-with-input-method "Description (optional): "))) + (if (zerop (length desc)) (setq desc nil)) + (setq filename (expand-file-name filename)) + (access-file filename "Couldn't open file") + + (let* ((attributes (file-attributes filename)) + (size (nth 7 attributes)) + (date (nth 5 attributes)) + (hash (jabber-ft-get-md5 filename))) + (jabber-si-initiate jc jid "http://jabber.org/protocol/si/profile/file-transfer" + `(file ((xmlns . "http://jabber.org/protocol/si/profile/file-transfer") + (name . ,(file-name-nondirectory filename)) + (size . ,size) + (date . ,(jabber-encode-time date)) + ,@(when hash + (list (cons 'hash hash)))) + (desc () ,desc)) + (lexical-let ((filename filename)) + (lambda (jc jid sid send-data-function) + (jabber-ft-do-send + jid sid send-data-function filename)))))) + +#+END_SRC +***** jabber-ft-do-send :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-do-send (jid sid send-data-function filename) + (if (stringp send-data-function) + (message "File sending failed: %s" send-data-function) + (with-temp-buffer + (insert-file-contents-literally filename) + + ;; Ever heard of buffering? + (funcall send-data-function (buffer-string)) + (message "File transfer completed"))) + ;; File transfer is monodirectional, so ignore received data. + #'ignore) + +#+END_SRC +**** server +:PROPERTIES: +:file: jabber-ft-server.el +:END: + +***** jabber-ft-sessions :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-ft-sessions nil + "Alist, where keys are (sid jid), and values are buffers of the files.") + +#+END_SRC +***** jabber-ft-size :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-ft-size nil + "Size of the file that is being downloaded") + +#+END_SRC +***** jabber-ft-md5-hash :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-ft-md5-hash nil + "MD5 hash of the file that is being downloaded") + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(jabber-disco-advertise-feature "http://jabber.org/protocol/si/profile/file-transfer") + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(add-to-list 'jabber-si-profiles + (list "http://jabber.org/protocol/si/profile/file-transfer" + 'jabber-ft-accept + 'jabber-ft-server-connected)) + +#+END_SRC +***** jabber-ft-accept :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-accept (jc xml-data) + "Receive IQ stanza containing file transfer request, ask user" + (let* ((from (jabber-xml-get-attribute xml-data 'from)) + (query (jabber-iq-query xml-data)) + (si-id (jabber-xml-get-attribute query 'id)) + ;; TODO: check namespace + (file (car (jabber-xml-get-children query 'file))) + (name (jabber-xml-get-attribute file 'name)) + (size (jabber-xml-get-attribute file 'size)) + (date (jabber-xml-get-attribute file 'date)) + (md5-hash (jabber-xml-get-attribute file 'hash)) + (desc (car (jabber-xml-node-children + (car (jabber-xml-get-children file 'desc))))) + (range (car (jabber-xml-get-children file 'range)))) + (unless (and name size) + ;; both name and size must be present + (jabber-signal-error "modify" 'bad-request)) + + (let ((question (format + "%s is sending you the file %s (%s bytes).%s Accept? " + (jabber-jid-displayname from) + name + size + (if (not (zerop (length desc))) + (concat " Description: '" desc "'") + "")))) + (unless (yes-or-no-p question) + (jabber-signal-error "cancel" 'forbidden))) + + ;; default is to save with given name, in current directory. + ;; maybe that's bad; maybe should be customizable. + (let* ((file-name (read-file-name "Download to: " nil nil nil name)) + (buffer (create-file-buffer file-name))) + (message "Starting download of %s..." (file-name-nondirectory file-name)) + (with-current-buffer buffer + (kill-all-local-variables) + (setq buffer-file-coding-system 'binary) + ;; For Emacs, switch buffer to unibyte _before_ anything goes into it, + ;; otherwise binary files are corrupted. For XEmacs, it isn't needed, + ;; and it also doesn't have set-buffer-multibyte. + (if (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil)) + (set-visited-file-name file-name t) + (set (make-local-variable 'jabber-ft-size) + (string-to-number size)) + (set (make-local-variable 'jabber-ft-md5-hash) + md5-hash)) + (add-to-list 'jabber-ft-sessions + (cons (list si-id from) buffer))) + + ;; to support range, return something sensible here + nil)) + +#+END_SRC +***** jabber-ft-server-connected :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-server-connected (jc jid sid send-data-function) + ;; We don't really care about the send-data-function. But if it's + ;; a string, it means that we have no connection. + (if (stringp send-data-function) + (message "File receiving failed: %s" send-data-function) + ;; On success, we just return our data receiving function. + 'jabber-ft-data)) + +#+END_SRC +***** jabber-ft-data :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-ft-data (jc jid sid data) + "Receive chunk of transferred file." + (let ((buffer (cdr (assoc (list sid jid) jabber-ft-sessions)))) + (with-current-buffer buffer + ;; If data is nil, there is no more data. + ;; But maybe the remote entity doesn't close the stream - + ;; then we have to keep track of file size to know when to stop. + ;; Return value is whether to keep connection open. + (when data + (insert data)) + (if (and data (< (buffer-size) jabber-ft-size)) + t + (basic-save-buffer) + (if (and jabber-ft-md5-hash + (let ((file-hash (jabber-ft-get-md5 buffer-file-name))) + (and file-hash + (not (string= file-hash jabber-ft-md5-hash))))) + ;; hash mismatch! + (progn + (message "%s downloaded - CHECKSUM MISMATCH!" + (file-name-nondirectory buffer-file-name)) + (sleep-for 5)) + ;; all is fine + (message "%s downloaded" (file-name-nondirectory buffer-file-name))) + (kill-buffer buffer) + nil)))) + +#+END_SRC +*** SOCKS5 Bytestreams ([[https://xmpp.org/extensions/xep-0065.html][XEP-0065]]) +:PROPERTIES: +:file: jabber-socks5.el +:header-args: :tangle jabber-socks5.el :load jabber-enable-legacy-features-p +:END: + +#+BEGIN_SRC emacs-lisp +(eval-when-compile (require 'cl)) + +#+END_SRC +**** jabber-socks5-pending-sessions :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-socks5-pending-sessions nil + "List of pending sessions. + +Each entry is a list, containing: + * Stream ID + * Full JID of initiator + * State machine managing the session") + +#+END_SRC +**** jabber-socks5-active-sessions :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-socks5-active-sessions nil + "List of active sessions. + +Each entry is a list, containing: + * Network connection + * Stream ID + * Full JID of initiator + * Profile data function") + +#+END_SRC +**** jabber-socks5-proxies :custom:variable: +#+BEGIN_SRC emacs-lisp +(defcustom jabber-socks5-proxies nil + "JIDs of XEP-0065 proxies to use for file transfer. +Put preferred ones first." + :type '(repeat string) + :group 'jabber +; :set 'jabber-socks5-set-proxies) + ) + +#+END_SRC +**** jabber-socks5-proxies-data :variable: +#+BEGIN_SRC emacs-lisp +(defvar jabber-socks5-proxies-data nil + "Alist containing information about proxies. +Keys of the alist are strings, the JIDs of the proxies. +Values are \"streamhost\" XML nodes.") + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(jabber-disco-advertise-feature "http://jabber.org/protocol/bytestreams") + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(add-to-list 'jabber-si-stream-methods + (list "http://jabber.org/protocol/bytestreams" + 'jabber-socks5-client-1 + 'jabber-socks5-accept)) + +#+END_SRC +**** jabber-socks5-set-proxies :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-set-proxies (symbol value) + "Set `jabber-socks5-proxies' and query proxies. +This is the set function of `jabber-socks5-proxies-data'." + (set-default symbol value) + (when jabber-connections + (jabber-socks5-query-all-proxies))) + +#+END_SRC +**** jabber-socks5-query-all-proxies :command: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-query-all-proxies (jc &optional callback) + "Ask all proxies in `jabber-socks5-proxies' for connection information. +If CALLBACK is non-nil, call it with no arguments when all +proxies have answered." + (interactive (list (jabber-read-account))) + (setq jabber-socks5-proxies-data nil) + (dolist (proxy jabber-socks5-proxies) + (jabber-socks5-query-proxy jc proxy callback))) + +#+END_SRC +**** jabber-socks5-query-proxy :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-query-proxy (jc jid &optional callback) + "Query the SOCKS5 proxy specified by JID for IP and port number." + (jabber-send-iq jc jid "get" + '(query ((xmlns . "http://jabber.org/protocol/bytestreams"))) + #'jabber-socks5-process-proxy-response (list callback t) + #'jabber-socks5-process-proxy-response (list callback nil))) + +#+END_SRC +**** jabber-socks5-process-proxy-response :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-process-proxy-response (jc xml-data closure-data) + "Process response from proxy query." + (let* ((query (jabber-iq-query xml-data)) + (from (jabber-xml-get-attribute xml-data 'from)) + (streamhosts (jabber-xml-get-children query 'streamhost))) + + (let ((existing-entry (assoc from jabber-socks5-proxies-data))) + (when existing-entry + (setq jabber-socks5-proxies-data + (delq existing-entry jabber-socks5-proxies-data)))) + + (destructuring-bind (callback successp) closure-data + (when successp + (setq jabber-socks5-proxies-data + (cons (cons from streamhosts) + jabber-socks5-proxies-data))) + (message "%s from %s. %d of %d proxies have answered." + (if successp "Response" "Error") from + (length jabber-socks5-proxies-data) (length jabber-socks5-proxies)) + (when (and callback (= (length jabber-socks5-proxies-data) (length jabber-socks5-proxies))) + (funcall callback))))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state-machine jabber-socks5 + :start ((jc jid sid profile-function role) + "Start XEP-0065 bytestream with JID. +SID is the session ID used. +PROFILE-FUNCTION is the function to call upon success. See `jabber-si-stream-methods'. +ROLE is either :initiator or :target. The initiator sends an IQ +set; the target waits for one." + (let ((new-state-data (list :jc jc + :jid jid + :sid sid + :profile-function profile-function + :role role)) + (new-state + ;; We want information about proxies; it might be needed in + ;; various situations. + (cond + ((null jabber-socks5-proxies) + ;; We know no proxy addresses. Try to find them by disco. + 'seek-proxies) + ((null jabber-socks5-proxies-data) + ;; We need to query the proxies for addresses. + 'query-proxies) + ;; So, we have our proxies. + (t + 'initiate)))) + (list new-state new-state-data nil)))) + +#+END_SRC +**** jabber-socks5-accept :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-accept (jc jid sid profile-function) + "Remember that we are waiting for connection from JID, with stream id SID" + ;; asking the user for permission is done in the profile + (add-to-list 'jabber-socks5-pending-sessions + (list sid jid (start-jabber-socks5 jc jid sid profile-function :target)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5 seek-proxies (fsm state-data) + ;; Look for items at the server. + (let* ((jc (plist-get state-data :jc)) + (server (jabber-jid-server (jabber-connection-jid jc)))) + (jabber-disco-get-items jc + server + nil + (lambda (jc fsm result) + (fsm-send-sync fsm (cons :items result))) + fsm)) + ;; Spend no more than five seconds looking for a proxy. + (list state-data 5)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5 seek-proxies (fsm state-data event callback) + "Collect disco results, looking for a bytestreams proxy." + ;; We put the number of outstanding requests as :remaining-info in + ;; the state-data plist. + (cond + ;; We're not ready to handle the IQ stanza yet + ((eq (car-safe event) :iq) + :defer) + + ;; Got list of items at the server. + ((eq (car-safe event) :items) + (dolist (entry (cdr event)) + ;; Each entry is ["name" "jid" "node"]. We send a disco info + ;; request to everything without a node. + (when (null (aref entry 2)) + (lexical-let ((jid (aref entry 1))) + (jabber-disco-get-info + (plist-get state-data :jc) + jid nil + (lambda (jc fsm result) + (fsm-send-sync fsm (list :info jid result))) + fsm)))) + ;; Remember number of requests sent. But if none, we just go on. + (if (cdr event) + (list 'seek-proxies (plist-put state-data :remaining-info (length (cdr event))) :keep) + (list 'initiate state-data nil))) + + ;; Got disco info from an item at the server. + ((eq (car-safe event) :info) + (fsm-debug-output "got disco event") + ;; Count the response. + (plist-put state-data :remaining-info (1- (plist-get state-data :remaining-info))) + (unless (eq (first (third event)) 'error) + (let ((identities (first (third event)))) + ;; Is it a bytestream proxy? + (when (dolist (identity identities) + (when (and (string= (aref identity 1) "proxy") + (string= (aref identity 2) "bytestreams")) + (return t))) + ;; Yes, it is. Add it to the list. + (push (second event) jabber-socks5-proxies)))) + + ;; Wait for more responses, if any are to be expected. + (if (zerop (plist-get state-data :remaining-info)) + ;; No more... go on to querying the proxies. + (list 'query-proxies state-data nil) + ;; We expect more responses... + (list 'seek-proxies state-data :keep))) + + ((eq event :timeout) + ;; We can't wait anymore... + (list 'query-proxies state-data nil)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5 query-proxies (fsm state-data) + (jabber-socks5-query-all-proxies + (plist-get state-data :jc) + (lexical-let ((fsm fsm)) + (lambda () (fsm-send-sync fsm :proxies)))) + (list state-data 5)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5 query-proxies (fsm state-data event callback) + "Query proxies in `jabber-socks5-proxies'." + (cond + ;; Can't handle the iq stanza yet... + ((eq (car-safe event) :iq) + :defer) + + ((eq (car-safe event) :info) + ;; stray event... do nothing + (list 'query-proxies state-data :keep)) + + ;; Got response/error from all proxies, or timeout + ((memq event '(:proxies :timeout)) + (list 'initiate state-data nil)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5 initiate (fsm state-data) + ;; Sort the alist jabber-socks5-proxies-data such that the + ;; keys are in the same order as in jabber-socks5-proxies. + (setq jabber-socks5-proxies-data + (sort jabber-socks5-proxies-data + #'(lambda (a b) + (> (length (member (car a) jabber-socks5-proxies)) + (length (member (car b) jabber-socks5-proxies)))))) + + ;; If we're the initiator, send initiation stanza. + (when (eq (plist-get state-data :role) :initiator) + ;; This is where initiation of server sockets would go + + (jabber-send-iq + (plist-get state-data :jc) + (plist-get state-data :jid) "set" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams") + (sid . ,(plist-get state-data :sid))) + ,@(mapcar + #'(lambda (proxy) + (mapcar + #'(lambda (streamhost) + (list 'streamhost + (list (cons 'jid (jabber-xml-get-attribute streamhost 'jid)) + (cons 'host (jabber-xml-get-attribute streamhost 'host)) + (cons 'port (jabber-xml-get-attribute streamhost 'port))) + ;; (proxy ((xmlns . "http://affinix.com/jabber/stream"))) + )) + (cdr proxy))) + jabber-socks5-proxies-data) + ;; (fast ((xmlns . "http://affinix.com/jabber/stream"))) + ) + (lexical-let ((fsm fsm)) + (lambda (jc xml-data closure-data) + (fsm-send-sync fsm (list :iq xml-data)))) + nil + ;; TODO: error handling + #'jabber-report-success "SOCKS5 negotiation")) + + ;; If we're the target, we just wait for an incoming stanza. + (list state-data nil)) + +#+END_SRC +**** jabber-socks5-process :function: +#+BEGIN_SRC emacs-lisp +(add-to-list 'jabber-iq-set-xmlns-alist + (cons "http://jabber.org/protocol/bytestreams" 'jabber-socks5-process)) +(defun jabber-socks5-process (jc xml-data) + "Accept IQ get for SOCKS5 bytestream" + (let* ((jid (jabber-xml-get-attribute xml-data 'from)) + (id (jabber-xml-get-attribute xml-data 'id)) + (query (jabber-iq-query xml-data)) + (sid (jabber-xml-get-attribute query 'sid)) + (session (dolist (pending-session jabber-socks5-pending-sessions) + (when (and (equal sid (nth 0 pending-session)) + (equal jid (nth 1 pending-session))) + (return pending-session))))) + ;; check that we really are expecting this session + (unless session + (jabber-signal-error "auth" 'not-acceptable)) + + (setq jabber-socks5-pending-sessions (delq session jabber-socks5-pending-sessions)) + (fsm-send-sync (nth 2 session) (list :iq xml-data)) + + ;; find streamhost to connect to +;; (let* ((streamhosts (jabber-xml-get-children query 'streamhost)) +;; (streamhost (dolist (streamhost streamhosts) +;; (let ((connection (jabber-socks5-connect streamhost sid jid (concat jabber-username "@" jabber-server "/" jabber-resource)))) +;; (when connection +;; ;; We select the first streamhost that we are able to connect to. +;; (push (list connection sid jid profile-data-function) +;; jabber-socks5-active-sessions) +;; ;; Now set the filter, for the rest of the output +;; (set-process-filter connection #'jabber-socks5-filter) +;; (set-process-sentinel connection #'jabber-socks5-sentinel) +;; (return streamhost)))))) +;; (unless streamhost +;; (jabber-signal-error "cancel" 'item-not-found)) + +;; ;; tell initiator which streamhost we use +;; (jabber-send-iq jid "result" +;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams")) +;; (streamhost-used ((jid . ,(jabber-xml-get-attribute streamhost 'jid))))) +;; nil nil nil nil id) +;; ;; now, as data is sent, it will be passed to the profile. +;; ) + )) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5 initiate (fsm state-data event callback) + (let* ((jc (plist-get state-data :jc)) + (jc-data (fsm-get-state-data jc)) + (our-jid (concat (plist-get jc-data :username) "@" + (plist-get jc-data :server) "/" + (plist-get jc-data :resource))) + (their-jid (plist-get state-data :jid)) + (initiator-jid (if (eq (plist-get state-data :role) :initiator) our-jid their-jid)) + (target-jid (if (eq (plist-get state-data :role) :initiator) their-jid our-jid))) + (cond + ;; Stray event... + ((memq (car-safe event) '(:proxy :info)) + (list 'initiate state-data :keep)) + + ;; Incoming IQ + ((eq (car-safe event) :iq) + (let ((xml-data (second event))) + ;; This is either type "set" (with a list of streamhosts to + ;; use), or a "result" (indicating the streamhost finally used + ;; by the other party). + (cond + ((string= (jabber-xml-get-attribute xml-data 'type) "set") + ;; A "set" makes sense if we're the initiator and offered + ;; Psi's "fast mode". We don't yet, though, so this is only + ;; for target. + (dolist (streamhost (jabber-xml-get-children (jabber-iq-query xml-data) 'streamhost)) + (jabber-xml-let-attributes + (jid host port) streamhost + ;; This is where we would attempt to support zeroconf + (when (and jid host port) + (start-jabber-socks5-connection + jc initiator-jid target-jid jid + (plist-get state-data :sid) host port fsm)))) + + (list 'wait-for-connection (plist-put state-data :iq-id (jabber-xml-get-attribute xml-data 'id)) 30)) + + ((string= (jabber-xml-get-attribute xml-data 'type) "result") + ;; The other party has decided what streamhost to use. + (let* ((proxy-used (jabber-xml-get-attribute (jabber-xml-path xml-data '(query streamhost-used)) 'jid)) + ;; If JID is our own JID, we have probably already detected + ;; what connection to use. But that is a later problem... + (streamhosts (cdr (assoc proxy-used jabber-socks5-proxies-data)))) + ;; Try to connect to all addresses of this proxy... + (dolist (streamhost streamhosts) + (jabber-xml-let-attributes + (jid host port) streamhost + (when (and jid host port) + (start-jabber-socks5-connection + jc initiator-jid target-jid jid + (plist-get state-data :sid) host port fsm))))) + + (list 'wait-for-connection state-data 30)))))))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state-machine jabber-socks5-connection + :start + ((jc initiator-jid target-jid streamhost-jid sid host port socks5-fsm) + "Connect to a single XEP-0065 streamhost." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + ;; make-network-process, which we really want, for asynchronous + ;; connection and such, was introduced in Emacs 22. + (if (fboundp 'make-network-process) + (let ((connection + (make-network-process + :name "socks5" + :buffer nil + :host host + :service (string-to-number port) + :nowait t + :filter (fsm-make-filter fsm) + :sentinel (fsm-make-sentinel fsm)))) + (list 'wait-for-connection + (list :jc jc + :connection connection + :initiator-jid initiator-jid + :target-jid target-jid + :streamhost-jid streamhost-jid + :sid sid + :socks5-fsm socks5-fsm) + 30)) + ;; So we open a stream, and wait for the connection to succeed. + (condition-case nil + (let ((connection + (open-network-stream "socks5" nil + host (string-to-number port)))) + (set-process-filter connection (fsm-make-filter fsm)) + (set-process-sentinel connection (fsm-make-sentinel fsm)) + (list 'authenticate + (list :jc jc + :connection connection + :initiator-jid initiator-jid + :target-jid target-jid + :streamhost-jid streamhost-jid + :sid sid + :socks5-fsm socks5-fsm) + nil)) + (error (list 'fail '() nil))))))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5-connection wait-for-connection + (fsm state-data event callback) + (cond + ((eq (car-safe event) :sentinel) + (let ((string (third event))) + (cond + ;; Connection succeeded + ((string= (substring string 0 4) "open") + (list 'authenticate state-data nil)) + ;; Connection failed + (t + (list 'fail state-data nil))))))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5-connection authenticate + (fsm state-data) + "Send authenticate command." + ;; version: 5. number of auth methods supported: 1. + ;; which one: no authentication. + (process-send-string (plist-get state-data :connection) (string 5 1 0)) + (list state-data 30)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5-connection authenticate + (fsm state-data event callback) + "Receive response to authenticate command." + (cond + ((eq (car-safe event) :filter) + (let ((string (third event))) + ;; should return: + ;; version: 5. auth method to use: none + (if (string= string (string 5 0)) + ;; Authenticated. Send connect command. + (list 'connect state-data nil) + ;; Authentication failed... + (delete-process (second event)) + (list 'fail state-data nil)))) + + ((eq (car-safe event) :sentinel) + (list 'fail state-data nil)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5-connection connect (fsm state-data) + "Send connect command." + (let* ((sid (plist-get state-data :sid)) + (initiator (plist-get state-data :initiator-jid)) + (target (plist-get state-data :target-jid)) + (hash (sha1 (concat sid initiator target)))) + (process-send-string + (plist-get state-data :connection) + (concat (string 5 1 0 3 (length hash)) + hash + (string 0 0))) + (list state-data 30))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5-connection connect + (fsm state-data event callback) + "Receive response to connect command." + (cond + ((eq (car-safe event) :filter) + (let ((string (third event))) + (if (string= (substring string 0 2) (string 5 0)) + ;; connection established + (progn + (fsm-send (plist-get state-data :socks5-fsm) + (list :connected + (plist-get state-data :connection) + (plist-get state-data :streamhost-jid))) + ;; Our work is done + (list 'done nil)) + (list 'fail state-data nil)))) + ((eq (car-safe event) :sentinel) + (list 'fail state-data nil)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5-connection done + (fsm state-data event callback) + ;; ignore all events + (list 'done nil nil)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5-connection fail (fsm state-data) + ;; Notify parent fsm about failure + (fsm-send (plist-get state-data :socks5-fsm) + :not-connected) + (list nil nil)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5-connection fail + (fsm state-data event callback) + ;; ignore all events + (list 'fail nil nil)) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5 wait-for-connection + (fsm state-data event callback) + (cond + ((eq (car-safe event) :connected) + (destructuring-bind (ignored connection streamhost-jid) event + (setq state-data (plist-put state-data :connection connection)) + ;; If we are expected to tell which streamhost we chose, do so. + (let ((iq-id (plist-get state-data :iq-id))) + (when iq-id + (jabber-send-iq + (plist-get state-data :jc) + (plist-get state-data :jid) "result" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams")) + (streamhost-used ((jid . ,streamhost-jid)))) + nil nil nil nil + iq-id))) + + ;; If we are the initiator, we should activate the bytestream. + (if (eq (plist-get state-data :role) :initiator) + (progn + (jabber-send-iq + (plist-get state-data :jc) + streamhost-jid "set" + `(query ((xmlns . "http://jabber.org/protocol/bytestreams") + (sid . ,(plist-get state-data :sid))) + (activate nil ,(plist-get state-data :jid))) + (lambda (jc xml-data fsm) (fsm-send-sync fsm :activated)) fsm + (lambda (jc xml-data fsm) (fsm-send-sync fsm :activation-failed)) fsm) + (list 'wait-for-activation state-data 10)) + ;; Otherwise, we just let the data flow. + (list 'stream-activated state-data nil)))) + + ((eq event :not-connected) + ;; If we were counting the streamhosts, we would know when there + ;; are no more chances left. + (list 'wait-for-connection state-data :keep)) + + ((eq event :timeout) + (list 'fail (plist-put state-data :error "Timeout when connecting to streamhosts") nil)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-state jabber-socks5 wait-for-activation + (fsm state-data event callback) + (cond + ((eq event :activated) + (list 'stream-activated state-data nil)) + ((eq event :activation-failed) + (list 'fail (plist-put state-data :error "Proxy activation failed") nil)) + + ;; Stray events from earlier state + ((eq (car-safe event) :connected) + ;; We just close the connection + (delete-process (second event)) + (list 'wait-for-activation state-data :keep)) + ((eq event :not-connected) + (list 'wait-for-activation state-data :keep)))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5 stream-activated + (fsm state-data) + (let ((connection (plist-get state-data :connection)) + (jc (plist-get state-data :jc)) + (jid (plist-get state-data :jid)) + (sid (plist-get state-data :sid)) + (profile-function (plist-get state-data :profile-function))) + (set-process-filter connection (fsm-make-filter fsm)) + (set-process-sentinel connection (fsm-make-sentinel fsm)) + ;; Call the profile function, passing the data send function, and + ;; receiving the data receiving function. Put the data receiving + ;; function in the plist. + (list (plist-put state-data + :profile-data-function + (funcall profile-function + jc jid sid + (lexical-let ((fsm fsm)) + (lambda (data) + (fsm-send fsm (list :send data)))))) + nil))) + + +(define-state jabber-socks5 stream-activated + (fsm state-data event callback) + (let ((jc (plist-get state-data :jc)) + (connection (plist-get state-data :connection)) + (profile-data-function (plist-get state-data :profile-data-function)) + (sid (plist-get state-data :sid)) + (jid (plist-get state-data :jid))) + (cond + ((eq (car-safe event) :send) + (process-send-string connection (second event)) + (list 'stream-activated state-data nil)) + + ((eq (car-safe event) :filter) + ;; Pass data from connection to profile data function + ;; If the data function requests it, tear down the connection. + (unless (funcall profile-data-function jc jid sid (third event)) + (fsm-send fsm (list :sentinel (second event) "shutdown"))) + + (list 'stream-activated state-data nil)) + + ((eq (car-safe event) :sentinel) + ;; Connection terminated. Shuffle together the remaining data, + ;; and kill the buffer. + (delete-process (second event)) + (funcall profile-data-function jc jid sid nil) + (list 'closed nil nil)) + + ;; Stray events from earlier state + ((eq (car-safe event) :connected) + ;; We just close the connection + (delete-process (second event)) + (list 'stream-activated state-data nil)) + ((eq event :not-connected) + (list 'stream-activated state-data nil))))) + +#+END_SRC + +#+BEGIN_SRC emacs-lisp +(define-enter-state jabber-socks5 fail (fsm state-data) + "Tell our caller that we failed." + (let ((jc (plist-get state-data :jc)) + (jid (plist-get state-data :jid)) + (sid (plist-get state-data :sid)) + (profile-function (plist-get state-data :profile-function)) + (iq-id (plist-get state-data :iq-id))) + (funcall profile-function jc jid sid (plist-get state-data :error)) + + (when iq-id + (jabber-send-iq-error jc jid iq-id nil "cancel" + 'remote-server-not-found))) + (list nil nil)) + +#+END_SRC +**** jabber-socks5-client-1 :function: +#+BEGIN_SRC emacs-lisp +(defun jabber-socks5-client-1 (jc jid sid profile-function) + "Negotiate a SOCKS5 connection with JID. +This function simply starts a state machine." + (add-to-list 'jabber-socks5-pending-sessions + (list sid jid (start-jabber-socks5 jc jid sid profile-function :initiator)))) + +#+END_SRC +**** +jabber-socks5-client-2+ :function: +#+BEGIN_SRC emacs-lisp +;; (defun jabber-socks5-client-2 (xml-data jid sid profile-function) +;; "Contact has selected a streamhost to use. Connect to the proxy." +;; (let* ((query (jabber-iq-query xml-data)) +;; (streamhost-used (car (jabber-xml-get-children query 'streamhost-used))) +;; (proxy-used (jabber-xml-get-attribute streamhost-used 'jid)) +;; connection) +;; (let ((streamhosts-left (cdr (assoc proxy-used jabber-socks5-proxies-data)))) +;; (while (and streamhosts-left (not connection)) +;; (setq connection +;; (jabber-socks5-connect (car streamhosts-left) +;; sid +;; (concat jabber-username "@" jabber-server "/" jabber-resource) +;; jid)) +;; (setq streamhosts-left (cdr streamhosts-left)))) +;; (unless connection +;; (error "Couldn't connect to proxy %s" proxy-used)) + +;; ;; Activation is only needed for proxies. +;; (jabber-send-iq proxy-used "set" +;; `(query ((xmlns . "http://jabber.org/protocol/bytestreams") +;; (sid . ,sid)) +;; (activate () ,jid)) +;; (lexical-let ((jid jid) (sid sid) (profile-function profile-function) +;; (connection connection)) +;; (lambda (xml-data closure-data) +;; (jabber-socks5-client-3 xml-data jid sid profile-function connection))) nil +;; ;; TODO: report error to contact? +;; #'jabber-report-success "Proxy activation"))) + +;; (defun jabber-socks5-client-3 (xml-data jid sid profile-function proxy-connection) +;; "Proxy is activated. Start the transfer." +;; ;; The response from the proxy does not contain any interesting +;; ;; information, beyond success confirmation. + +;; (funcall profile-function jid sid +;; (lexical-let ((proxy-connection proxy-connection)) +;; (lambda (data) +;; (process-send-string proxy-connection data))))) + #+END_SRC *** In-Band Real Time Text (RTT) ([[https://xmpp.org/extensions/xep-0301.html][XEP-0301]]) :PROPERTIES: -:file: jabber-rtt.el +:old-file: jabber-rtt.el :END: #+BEGIN_SRC emacs-lisp @@ -15539,7 +16699,7 @@ XEP-0301, In-Band Real Time Text." *** Jabber :PROPERTIES: -:file: jabber.el +:old-file: jabber.el :END: #+BEGIN_SRC emacs-lisp @@ -15790,8 +16950,3 @@ Contents of process buffers might be useful for debugging." ;;; jabber.el ends here #+END_SRC - -** local variables -# Local Variables: -# eval: (progn (make-local-variable 'after-save-hook) (add-hook 'after-save-hook (lambda () (start-process-shell-command "jabber-sed-tangle" "jabber-sed-tangle" "sed -n -e '/#+BEGIN_SRC emacs-lisp$/,/#+END_SRC$/{//!p;}' jabber.org > jabber.el")))) -# End: