jabber-util.el

   1 ;; jabber-util.el - various utility functions    -*- coding: utf-8; -*-
   2
   3 ;; Copyright (C) 2003, 2004, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5 ;; Copyright (C) 2008, 2010 - Terechkov Evgenii - evg@altlinux.org
   6 ;; Copyright (C) 2010 - Kirill A. Korinskiy - catap@catap.ru
   7
   8 ;; This file is a part of jabber.el.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; if not, write to the Free Software
  22 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  23
  24 (eval-when-compile (require 'cl))
  25 (condition-case nil
  26     (require 'password)
  27   (error nil))
  28
  29 (defvar jabber-jid-history nil
  30   "History of entered JIDs")
  31
  32 ;; Define `jabber-replace-in-string' somehow.
  33 (cond
  34  ;; Emacs 21 has replace-regexp-in-string.
  35  ((fboundp 'replace-regexp-in-string)
  36   (defsubst jabber-replace-in-string (str regexp newtext)
  37     (replace-regexp-in-string regexp newtext str t t)))
  38  ;; XEmacs has replace-in-string.  However, color-theme defines it as
  39  ;; well on Emacs 2x, so this check must be last.
  40  ((fboundp 'replace-in-string)
  41   ;; And the version in color-theme takes only three arguments.  Check
  42   ;; just to be sure.
  43   (condition-case nil
  44       (replace-in-string "foobar" "foo" "bar" t)
  45     (wrong-number-of-arguments
  46      (error "`replace-in-string' doesn't accept fourth argument")))
  47   (defsubst jabber-replace-in-string (str regexp newtext)
  48     (replace-in-string str regexp newtext t)))
  49  (t
  50   (error "No implementation of `jabber-replace-in-string' available")))
  51
  52 ;;; XEmacs compatibility.  Stolen from ibuffer.el
  53 (if (fboundp 'propertize)
  54     (defalias 'jabber-propertize 'propertize)
  55   (defun jabber-propertize (string &rest properties)
  56     "Return a copy of STRING with text properties added.
  57
  58  [Note: this docstring has been copied from the Emacs 21 version]
  59
  60 First argument is the string to copy.
  61 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
  62 properties to add to the result."
  63     (let ((str (copy-sequence string)))
  64       (add-text-properties 0 (length str)
  65                            properties
  66                            str)
  67       str)))
  68
  69 (unless (fboundp 'bound-and-true-p)
  70   (defmacro bound-and-true-p (var)
  71     "Return the value of symbol VAR if it is bound, else nil."
  72     `(and (boundp (quote ,var)) ,var)))
  73
  74 ;;; more XEmacs compatibility
  75 ;;; Preserve input method when entering a minibuffer
  76 (if (featurep 'xemacs)
  77     ;; I don't know how to do this
  78     (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
  79       (read-string prompt initial-contents history default-value))
  80   (defsubst jabber-read-with-input-method (prompt &optional initial-contents history default-value)
  81     (read-string prompt initial-contents history default-value t)))
  82
  83 (unless (fboundp 'delete-and-extract-region)
  84   (defsubst delete-and-extract-region (start end)
  85     (prog1
  86         (buffer-substring start end)
  87       (delete-region start end))))
  88
  89 (unless (fboundp 'access-file)
  90   (defsubst access-file (filename error-message)
  91     (unless (file-readable-p filename)
  92       (error error-message))))
  93
  94 (if (fboundp 'float-time)
  95     (defalias 'jabber-float-time 'float-time)
  96   (defun jabber-float-time (&optional specified-time)
  97     (unless specified-time
  98       (setq specified-time (current-time)))
  99     ;; second precision is good enough for us
 100     (+ (* 65536.0 (car specified-time))
 101        (cadr specified-time))))
 102
 103 (cond
 104  ((fboundp 'cancel-timer)
 105   (defalias 'jabber-cancel-timer 'cancel-timer))
 106  ((fboundp 'delete-itimer)
 107   (defalias 'jabber-cancel-timer 'delete-itimer))
 108  (t
 109   (error "No `cancel-timer' function found")))
 110
 111 (defun jabber-concat-rosters ()
 112   "Concatenate the rosters of all connected accounts."
 113   (apply #'append
 114          (mapcar
 115           (lambda (jc)
 116             (plist-get (fsm-get-state-data jc) :roster))
 117           jabber-connections)))
 118
 119 (defun jabber-concat-rosters-full ()
 120   "Concatenate the rosters of all connected accounts. Show full jids (with resources)"
 121   (let ((jids (apply #'append
 122                      (mapcar
 123                       (lambda (jc)
 124                         (plist-get (fsm-get-state-data jc) :roster))
 125                       jabber-connections))))
 126     (apply #'append
 127            (mapcar (lambda (jid)
 128                      (mapcar (lambda (res) (intern (format "%s/%s" jid (car res))))
 129                              (get (jabber-jid-symbol jid) 'resources)))
 130                    jids))))
 131
 132 (defun jabber-connection-jid (jc)
 133   "Return the full JID of the given connection."
 134   (let ((sd (fsm-get-state-data jc)))
 135     (concat (plist-get sd :username) "@"
 136             (plist-get sd :server) "/"
 137             (plist-get sd :resource))))
 138
 139 (defun jabber-connection-bare-jid (jc)
 140   "Return the bare JID of the given connection."
 141   (let ((sd (fsm-get-state-data jc)))
 142     (concat (plist-get sd :username) "@"
 143             (plist-get sd :server))))
 144
 145 (defun jabber-find-connection (bare-jid)
 146   "Find the connection to the account named by BARE-JID.
 147 Return nil if none found."
 148   (dolist (jc jabber-connections)
 149     (when (string= bare-jid (jabber-connection-bare-jid jc))
 150       (return jc))))
 151
 152 (defun jabber-find-active-connection (dead-jc)
 153   "Given a dead connection, find an active connection to the same account.
 154 Return nil if none found."
 155   (let ((jid (jabber-connection-bare-jid dead-jc)))
 156     (jabber-find-connection jid)))
 157
 158 (defun jabber-jid-username (string)
 159   "return the username portion of a JID, or nil if no username"
 160   (when (string-match "\\(.*\\)@.*\\(/.*\\)?" string)
 161     (match-string 1 string)))
 162
 163 (defun jabber-jid-user (string)
 164   "return the user (username@server) portion of a JID"
 165   ;;transports don't have @, so don't require it
 166   ;;(string-match ".*@[^/]*" string)
 167   (string-match "[^/]*" string)
 168   (match-string 0 string))
 169
 170 (defun jabber-jid-server (string)
 171   "Return the server portion of a JID."
 172   (string-match "^\\(.*@\\)?\\([^@/]+\\)\\(/.*\\)?$" string)
 173   (match-string 2 string))
 174
 175 (defun jabber-jid-rostername (string)
 176   "return the name of the user, if given in roster, else nil"
 177   (let ((user (jabber-jid-symbol string)))
 178     (if (> (length (get user 'name)) 0)
 179         (get user 'name))))
 180
 181 (defun jabber-jid-displayname (string)
 182   "return the name of the user, if given in roster, else username@server"
 183   (or (jabber-jid-rostername string)
 184       (jabber-jid-user (if (symbolp string)
 185                            (symbol-name string)
 186                          string))))
 187
 188 (defun jabber-jid-bookmarkname (string)
 189   "Return the conference name from boomarks or displayname from roster, or JID if none set"
 190   (or (loop for conference in (first (loop for value being the hash-values of jabber-bookmarks
 191                                            collect value))
 192             do (let ((ls (cadr conference)))
 193                  (if (string= (cdr (assoc 'jid ls)) string)
 194                      (return (cdr (assoc 'name ls))))))
 195       (jabber-jid-displayname string)))
 196
 197 (defun jabber-jid-resource (string)
 198   "return the resource portion of a JID, or nil if there is none."
 199   (when (string-match "^\\(\\([^/]*@\\)?[^/]*\\)/\\(.*\\)" string)
 200     (match-string 3 string)))
 201
 202 (defun jabber-jid-symbol (string)
 203   "return the symbol for the given JID"
 204   ;; If it's already a symbol, just return it.
 205   (if (symbolp string)
 206       string
 207     ;; XXX: "downcase" is poor man's nodeprep.  See XMPP CORE.
 208     (intern (downcase (jabber-jid-user string)) jabber-jid-obarray)))
 209
 210 (defun jabber-my-jid-p (jc jid)
 211   "Return non-nil if the specified JID is in jabber-account-list (modulo resource).
 212 Also return non-nil if JID matches JC, modulo resource."
 213   (or
 214    (equal (jabber-jid-user jid)
 215           (jabber-connection-bare-jid jc))
 216    (member (jabber-jid-user jid) (mapcar (lambda (x) (jabber-jid-user (car x))) jabber-account-list))))
 217
 218 (defun jabber-read-jid-completing (prompt &optional subset require-match default resource fulljids)
 219   "read a jid out of the current roster from the minibuffer.
 220 If SUBSET is non-nil, it should be a list of symbols from which
 221 the JID is to be selected, instead of using the entire roster.
 222 If REQUIRE-MATCH is non-nil, the JID must be in the list used.
 223 If DEFAULT is non-nil, it's used as the default value, otherwise
 224 the default is inferred from context.
 225 RESOURCE is one of the following:
 226
 227 nil         Accept full or bare JID, as entered
 228 full        Turn bare JIDs to full ones with highest-priority resource
 229 bare-or-muc Turn full JIDs to bare ones, except for in MUC
 230
 231 If FULLJIDS is non-nil, complete jids with resources."
 232   (let ((jid-at-point (or
 233                        (and default
 234                             ;; default can be either a symbol or a string
 235                             (if (symbolp default)
 236                                 (symbol-name default)
 237                               default))
 238                        (let* ((jid (get-text-property (point) 'jabber-jid))
 239                               (res (get (jabber-jid-symbol jid) 'resource)))
 240                          (when jid
 241                            (if (and fulljids res (not (jabber-jid-resource jid)))
 242                                (format "%s/%s" jid res)
 243                              jid)))
 244                        (bound-and-true-p jabber-chatting-with)
 245                        (bound-and-true-p jabber-group)))
 246         (completion-ignore-case t)
 247         (jid-completion-table (mapcar #'(lambda (item)
 248                                           (cons (symbol-name item) item))
 249                                       (or subset (funcall (if fulljids
 250                                                               'jabber-concat-rosters-full
 251                                                             'jabber-concat-rosters)))))
 252         chosen)
 253     (dolist (item (or subset (jabber-concat-rosters)))
 254       (if (get item 'name)
 255           (push (cons (get item 'name) item) jid-completion-table)))
 256     ;; if the default is not in the allowed subset, it's not a good default
 257     (if (and subset (not (assoc jid-at-point jid-completion-table)))
 258         (setq jid-at-point nil))
 259     (let ((input
 260            (completing-read (concat prompt
 261                                     (if jid-at-point
 262                                         (format "(default %s) " jid-at-point)))
 263                             jid-completion-table
 264                             nil require-match nil 'jabber-jid-history jid-at-point)))
 265       (setq chosen
 266             (if (and input (assoc-ignore-case input jid-completion-table))
 267                 (symbol-name (cdr (assoc-ignore-case input jid-completion-table)))
 268               (and (not (zerop (length input)))
 269                    input))))
 270
 271     (when chosen
 272       (case resource
 273         (full
 274          ;; If JID is bare, add the highest-priority resource.
 275          (if (jabber-jid-resource chosen)
 276              chosen
 277            (let ((highest-resource (get (jabber-jid-symbol chosen) 'resource)))
 278              (if highest-resource
 279                  (concat chosen "/" highest-resource)
 280                chosen))))
 281         (bare-or-muc
 282          ;; If JID is full and non-MUC, remove resource.
 283          (if (null (jabber-jid-resource chosen))
 284              chosen
 285            (let ((bare (jabber-jid-user chosen)))
 286              (if (assoc bare *jabber-active-groupchats*)
 287                  chosen
 288                bare))))
 289         (t
 290          chosen)))))
 291
 292 (defun jabber-read-node (prompt)
 293   "Read node name, taking default from disco item at point."
 294   (let ((node-at-point (get-text-property (point) 'jabber-node)))
 295     (read-string (concat prompt
 296                          (if node-at-point
 297                              (format "(default %s) " node-at-point)))
 298                  node-at-point)))
 299
 300 (defun jabber-password-key (bare-jid)
 301   "Construct key for `password' library from BARE-JID."
 302   (concat "xmpp:" bare-jid))
 303
 304 (defun jabber-read-password (bare-jid)
 305   "Read Jabber password from minibuffer."
 306   (let ((prompt (format "Jabber password for %s: " bare-jid)))
 307     (if (require 'password-cache nil t)
 308         ;; Need to copy the password, as sasl.el wants to erase it.
 309         (copy-sequence
 310          (password-read prompt (jabber-password-key bare-jid)))
 311       (read-passwd prompt))))
 312
 313 (defun jabber-cache-password (bare-jid password)
 314   "Cache PASSWORD for BARE-JID."
 315   (when (fboundp 'password-cache-add)
 316     (password-cache-add (jabber-password-key bare-jid) password)))
 317
 318 (defun jabber-uncache-password (bare-jid)
 319   "Uncache cached password for BARE-JID.
 320 Useful if the password proved to be wrong."
 321   (interactive (list (jabber-jid-user
 322                       (completing-read "Forget password of account: " jabber-account-list nil nil nil 'jabber-account-history))))
 323   (when (fboundp 'password-cache-remove)
 324     (password-cache-remove (jabber-password-key bare-jid))))
 325
 326 (defun jabber-read-account (&optional always-ask)
 327   "Ask for which connected account to use.
 328 If ALWAYS-ASK is nil and there is only one account, return that
 329 account."
 330   (let ((completions
 331          (mapcar (lambda (c)
 332                    (cons
 333                     (jabber-connection-bare-jid c)
 334                     c))
 335                  jabber-connections)))
 336     (cond
 337      ((null jabber-connections)
 338       (error "Not connected to Jabber"))
 339      ((and (null (cdr jabber-connections)) (not always-ask))
 340       ;; only one account
 341       (car jabber-connections))
 342      (t
 343       (or
 344        ;; if there is a jabber-account property at point,
 345        ;; present it as default value
 346        (cdr (assoc (let ((at-point (get-text-property (point) 'jabber-account)))
 347                      (when (and at-point
 348                                 (memq at-point jabber-connections))
 349                        (jabber-connection-bare-jid at-point))) completions))
 350        (let* ((default
 351                 (or
 352                  ;; if the buffer is associated with a connection, use it
 353                  (when (and jabber-buffer-connection
 354                             (memq jabber-buffer-connection jabber-connections))
 355                    (jabber-connection-bare-jid jabber-buffer-connection))
 356                  ;; else, use the first connection in the list
 357                  (caar completions)))
 358               (input (completing-read
 359                       (concat "Select Jabber account (default "
 360                               default
 361                               "): ")
 362                       completions nil t nil 'jabber-account-history
 363                       default)))
 364          (cdr (assoc input completions))))))))
 365
 366 (defun jabber-iq-query (xml-data)
 367   "Return the query part of an IQ stanza.
 368 An IQ stanza may have zero or one query child, and zero or one <error/> child.
 369 The query child is often but not always <query/>."
 370   (let (query)
 371     (dolist (x (jabber-xml-node-children xml-data))
 372       (if (and
 373            (listp x)
 374            (not (eq (jabber-xml-node-name x) 'error)))
 375           (setq query x)))
 376     query))
 377
 378 (defun jabber-iq-error (xml-data)
 379   "Return the <error/> part of an IQ stanza, if any."
 380   (car (jabber-xml-get-children xml-data 'error)))
 381
 382 (defun jabber-iq-xmlns (xml-data)
 383   "Return the namespace of an IQ stanza, i.e. the namespace of its query part."
 384   (jabber-xml-get-attribute (jabber-iq-query xml-data) 'xmlns))
 385
 386 (defun jabber-x-delay (xml-data)
 387   "Return timestamp given a <x/> tag in namespace jabber:x:delay.
 388 Return nil if no such data available."
 389   (when (and (eq (jabber-xml-node-name xml-data) 'x)
 390              (string= (jabber-xml-get-attribute xml-data 'xmlns) "jabber:x:delay"))
 391     (let ((stamp (jabber-xml-get-attribute xml-data 'stamp)))
 392       (if (and (stringp stamp)
 393                (= (length stamp) 17))
 394           (jabber-parse-legacy-time stamp)))))
 395
 396 (defun jabber-parse-legacy-time (timestamp)
 397   "Parse timestamp in ccyymmddThh:mm:ss format (UTC) and return as internal time value."
 398   (let ((year (string-to-number (substring timestamp 0 4)))
 399         (month (string-to-number (substring timestamp 4 6)))
 400         (day (string-to-number (substring timestamp 6 8)))
 401         (hour (string-to-number (substring timestamp 9 11)))
 402         (minute (string-to-number (substring timestamp 12 14)))
 403         (second (string-to-number (substring timestamp 15 17))))
 404     (encode-time second minute hour day month year 0)))
 405
 406 (defun jabber-encode-legacy-time (timestamp)
 407   "Parse TIMESTAMP as internal time value and encode as ccyymmddThh:mm:ss (UTC)."
 408   (if (featurep 'xemacs)
 409       ;; XEmacs doesn't have `universal' argument to format-time-string,
 410       ;; so we have to do it ourselves.
 411       (format-time-string "%Y%m%dT%H:%M:%S"
 412                           (time-subtract timestamp
 413                                          (list 0 (car (current-time-zone)))))
 414     (format-time-string "%Y%m%dT%H:%M:%S" timestamp t)))
 415
 416 (defun jabber-encode-time (time)
 417   "Convert TIME to a string by JEP-0082.
 418 TIME is in a format accepted by `format-time-string'."
 419   (format-time-string "%Y-%m-%dT%H:%M:%SZ" nil t))
 420
 421 (defun jabber-encode-timezone ()
 422   (let ((time-zone-offset (nth 0 (current-time-zone))))
 423     (if (null time-zone-offset)
 424         "Z"
 425       (let* ((positivep (>= time-zone-offset 0))
 426              (hours (/ (abs time-zone-offset) 3600))
 427              (minutes (/ (% (abs time-zone-offset) 3600) 60)))
 428         (format "%s%02d:%02d"(if positivep "+" "-") hours minutes)))))
 429
 430 (defun jabber-parse-time (raw-time)
 431   "Parse the DateTime encoded in TIME according to JEP-0082."
 432   (let* ((time (if (string= (substring raw-time 4 5) "-")
 433                    raw-time
 434                  (concat
 435                   (substring raw-time 0 4) "-"
 436                   (substring raw-time 4 6) "-"
 437                   (substring raw-time 6 (length raw-time)))))
 438          (year (string-to-number (substring time 0 4)))
 439          (month (string-to-number (substring time 5 7)))
 440          (day (string-to-number (substring time 8 10)))
 441          (hour (string-to-number (substring time 11 13)))
 442          (minute (string-to-number (substring time 14 16)))
 443          (second (string-to-number (substring time 17 19)))
 444          ;; fractions are optional
 445          (fraction (if (eq (aref time 19) ?.)
 446                        (string-to-number (substring time 20 23))))
 447          (timezone (substring time (if fraction 23 19))))
 448     ;; timezone is either Z (UTC) or [+-]HH:MM
 449     (let ((timezone-seconds
 450            (if (string= timezone "Z")
 451                0
 452              (* (if (eq (aref timezone 0) ?+) 1 -1)
 453                 (* 60 (+ (* 60 (string-to-number (substring timezone 1 3)))
 454                          (string-to-number (substring timezone 4 6))))))))
 455       (encode-time second minute hour day month year timezone-seconds))))
 456
 457 (defun jabber-report-success (jc xml-data context)
 458   "IQ callback reporting success or failure of the operation.
 459 CONTEXT is a string describing the action.
 460 \"CONTEXT succeeded\" or \"CONTEXT failed: REASON\" is displayed in
 461 the echo area."
 462   (let ((type (jabber-xml-get-attribute xml-data 'type)))
 463     (message (concat context
 464                      (if (string= type "result")
 465                          " succeeded"
 466                        (concat
 467                         " failed: "
 468                         (let ((the-error (jabber-iq-error xml-data)))
 469                           (if the-error
 470                               (jabber-parse-error the-error)
 471                             "No error message given"))))))))
 472
 473 (defconst jabber-error-messages
 474   (list
 475    (cons 'bad-request "Bad request")
 476    (cons 'conflict "Conflict")
 477    (cons 'feature-not-implemented "Feature not implemented")
 478    (cons 'forbidden "Forbidden")
 479    (cons 'gone "Gone")
 480    (cons 'internal-server-error "Internal server error")
 481    (cons 'item-not-found "Item not found")
 482    (cons 'jid-malformed "JID malformed")
 483    (cons 'not-acceptable "Not acceptable")
 484    (cons 'not-allowed "Not allowed")
 485    (cons 'not-authorized "Not authorized")
 486    (cons 'payment-required "Payment required")
 487    (cons 'recipient-unavailable "Recipient unavailable")
 488    (cons 'redirect "Redirect")
 489    (cons 'registration-required "Registration required")
 490    (cons 'remote-server-not-found "Remote server not found")
 491    (cons 'remote-server-timeout "Remote server timeout")
 492    (cons 'resource-constraint "Resource constraint")
 493    (cons 'service-unavailable "Service unavailable")
 494    (cons 'subscription-required "Subscription required")
 495    (cons 'undefined-condition "Undefined condition")
 496    (cons 'unexpected-request "Unexpected request"))
 497   "String descriptions of XMPP stanza errors")
 498
 499 (defconst jabber-legacy-error-messages
 500   (list
 501    (cons 302 "Redirect")
 502    (cons 400 "Bad request")
 503    (cons 401 "Unauthorized")
 504    (cons 402 "Payment required")
 505    (cons 403 "Forbidden")
 506    (cons 404 "Not found")
 507    (cons 405 "Not allowed")
 508    (cons 406 "Not acceptable")
 509    (cons 407 "Registration required")
 510    (cons 408 "Request timeout")
 511    (cons 409 "Conflict")
 512    (cons 500 "Internal server error")
 513    (cons 501 "Not implemented")
 514    (cons 502 "Remote server error")
 515    (cons 503 "Service unavailable")
 516    (cons 504 "Remote server timeout")
 517    (cons 510 "Disconnected"))
 518   "String descriptions of legacy errors (JEP-0086)")
 519
 520 (defun jabber-parse-error (error-xml)
 521   "Parse the given <error/> tag and return a string fit for human consumption.
 522 See secton 9.3, Stanza Errors, of XMPP Core, and JEP-0086, Legacy Errors."
 523   (let ((error-type (jabber-xml-get-attribute error-xml 'type))
 524         (error-code (jabber-xml-get-attribute error-xml 'code))
 525         condition text)
 526     (if error-type
 527         ;; If the <error/> tag has a type element, it is new-school.
 528         (dolist (child (jabber-xml-node-children error-xml))
 529           (when (string=
 530                  (jabber-xml-get-attribute child 'xmlns)
 531                  "urn:ietf:params:xml:ns:xmpp-stanzas")
 532             (if (eq (jabber-xml-node-name child) 'text)
 533                 (setq text (car (jabber-xml-node-children child)))
 534               (setq condition
 535                     (or (cdr (assq (jabber-xml-node-name child) jabber-error-messages))
 536                         (symbol-name (jabber-xml-node-name child)))))))
 537       (setq condition (or (cdr (assq (string-to-number error-code) jabber-legacy-error-messages))
 538                           error-code))
 539       (setq text (car (jabber-xml-node-children error-xml))))
 540     (concat condition
 541             (if text (format ": %s" text)))))
 542
 543 (defun jabber-error-condition (error-xml)
 544   "Parse the given <error/> tag and return the condition symbol."
 545   (catch 'condition
 546     (dolist (child (jabber-xml-node-children error-xml))
 547       (when (string=
 548                  (jabber-xml-get-attribute child 'xmlns)
 549                  "urn:ietf:params:xml:ns:xmpp-stanzas")
 550         (throw 'condition (jabber-xml-node-name child))))))
 551
 552 (defvar jabber-stream-error-messages
 553   (list
 554    (cons 'bad-format "Bad XML format")
 555    (cons 'bad-namespace-prefix "Bad namespace prefix")
 556    (cons 'conflict "Conflict")
 557    (cons 'connection-timeout "Connection timeout")
 558    (cons 'host-gone "Host gone")
 559    (cons 'host-unknown "Host unknown")
 560    (cons 'improper-addressing "Improper addressing") ; actually only s2s
 561    (cons 'internal-server-error "Internal server error")
 562    (cons 'invalid-from "Invalid from")
 563    (cons 'invalid-id "Invalid id")
 564    (cons 'invalid-namespace "Invalid namespace")
 565    (cons 'invalid-xml "Invalid XML")
 566    (cons 'not-authorized "Not authorized")
 567    (cons 'policy-violation "Policy violation")
 568    (cons 'remote-connection-failed "Remote connection failed")
 569    (cons 'resource-constraint "Resource constraint")
 570    (cons 'restricted-xml "Restricted XML")
 571    (cons 'see-other-host "See other host")
 572    (cons 'system-shutdown "System shutdown")
 573    (cons 'undefined-condition "Undefined condition")
 574    (cons 'unsupported-encoding "Unsupported encoding")
 575    (cons 'unsupported-stanza-type "Unsupported stanza type")
 576    (cons 'unsupported-version "Unsupported version")
 577    (cons 'xml-not-well-formed "XML not well formed"))
 578   "String descriptions of XMPP stream errors")
 579
 580 (defun jabber-stream-error-condition (error-xml)
 581   "Return the condition of a <stream:error/> tag."
 582   ;; as we don't know the node name of the condition, we have to
 583   ;; search for it.
 584   (dolist (node (jabber-xml-node-children error-xml))
 585     (when (and (string= (jabber-xml-get-attribute node 'xmlns)
 586                         "urn:ietf:params:xml:ns:xmpp-streams")
 587                (assq (jabber-xml-node-name node)
 588                      jabber-stream-error-messages))
 589       (return (jabber-xml-node-name node)))))
 590
 591 (defun jabber-parse-stream-error (error-xml)
 592   "Parse the given <stream:error/> tag and return a sting fit for human consumption."
 593   (let ((text-node (car (jabber-xml-get-children error-xml 'text)))
 594         (condition (jabber-stream-error-condition error-xml)))
 595     (concat (if condition (cdr (assq condition jabber-stream-error-messages))
 596               "Unknown stream error")
 597             (if (and text-node (stringp (car (jabber-xml-node-children text-node))))
 598                 (concat ": " (car (jabber-xml-node-children text-node)))))))
 599
 600 (put 'jabber-error
 601      'error-conditions
 602      '(error jabber-error))
 603 (put 'jabber-error
 604      'error-message
 605      "Jabber error")
 606
 607 (defun jabber-signal-error (error-type condition &optional text app-specific)
 608   "Signal an error to be sent by Jabber.
 609 ERROR-TYPE is one of \"cancel\", \"continue\", \"modify\", \"auth\"
 610 and \"wait\".
 611 CONDITION is a symbol denoting a defined XMPP condition.
 612 TEXT is a string to be sent in the error message, or nil for no text.
 613 APP-SPECIFIC is a list of extra XML tags.
 614
 615 See section 9.3 of XMPP Core."
 616   (signal 'jabber-error
 617           (list error-type condition text app-specific)))
 618
 619 (defun jabber-unhex (string)
 620   "Convert a hex-encoded UTF-8 string to Emacs representation.
 621 For example, \"ji%C5%99i@%C4%8Dechy.example/v%20Praze\" becomes
 622 \"jiři@čechy.example/v Praze\"."
 623   (decode-coding-string (url-unhex-string string) 'utf-8))
 624
 625 (defun jabber-handle-uri (uri &rest ignored-args)
 626   "Handle XMPP links according to draft-saintandre-xmpp-iri-04.
 627 See Info node `(jabber)XMPP URIs'."
 628   (interactive "sEnter XMPP URI: ")
 629
 630   (when (string-match "//" uri)
 631     (error "URIs with authority part are not supported"))
 632
 633   ;; This regexp handles three cases:
 634   ;; xmpp:romeo@montague.net
 635   ;; xmpp:romeo@montague.net?roster
 636   ;; xmpp:romeo@montague.net?roster;name=Romeo%20Montague;group=Lovers
 637   (unless (string-match "^xmpp:\\([^?]+\\)\\(\\?\\([a-z]+\\)\\(;\\(.*\\)\\)?\\)?" uri)
 638     (error "Invalid XMPP URI '%s'" uri))
 639
 640   ;; We start by raising the Emacs frame.
 641   (raise-frame)
 642
 643   (let ((jid (jabber-unhex (match-string 1 uri)))
 644         (method (match-string 3 uri))
 645         (args (let ((text (match-string 5 uri)))
 646                 ;; If there are arguments...
 647                 (when text
 648                   ;; ...split the pairs by ';'...
 649                   (let ((pairs (split-string text ";")))
 650                     (mapcar (lambda (pair)
 651                               ;; ...and split keys from values by '='.
 652                               (destructuring-bind (key value)
 653                                   (split-string pair "=")
 654                                 ;; Values can be hex-coded.
 655                                 (cons key (jabber-unhex value))))
 656                             pairs))))))
 657     ;; The full list of methods is at
 658     ;; <URL:http://www.jabber.org/registrar/querytypes.html>.
 659     (cond
 660      ;; Join an MUC.
 661      ((string= method "join")
 662       (let ((account (jabber-read-account)))
 663         (jabber-muc-join
 664          account jid (jabber-muc-read-my-nickname account jid) t)))
 665      ;; Register with a service.
 666      ((string= method "register")
 667       (jabber-get-register (jabber-read-account) jid))
 668      ;; Run an ad-hoc command
 669      ((string= method "command")
 670       ;; XXX: does the 'action' attribute make sense?
 671       (jabber-ahc-execute-command
 672        (jabber-read-account) jid (cdr (assoc "node" args))))
 673      ;; Everything else: open a chat buffer.
 674      (t
 675       (jabber-chat-with (jabber-read-account) jid)))))
 676
 677 (defun url-xmpp (url)
 678   "Handle XMPP URLs from internal Emacs functions."
 679   ;; XXX: This parsing roundtrip is redundant, and the parser of the
 680   ;; url package might lose information.
 681   (jabber-handle-uri (url-recreate-url url)))
 682
 683 (defun string>-numerical (s1 s2)
 684   "Return t if first arg string is more than second in numerical order."
 685   (cond ((string= s1 s2) nil)
 686         ((> (length s1) (length s2)) t)
 687         ((< (length s1) (length s2)) nil)
 688         ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil)
 689         ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t)
 690         (t (string>-numerical (substring s1 1) (substring s2 1)))))
 691
 692 (defun jabber-append-string-to-file (string file &optional func &rest args)
 693   "Append STRING (may be nil) to FILE. Create FILE if needed.
 694 If FUNC is non-nil, then call FUNC with ARGS at beginning of
 695 temporaly buffer _before_ inserting STRING."
 696   (when (or (stringp string) (functionp func))
 697     (with-temp-buffer
 698       (when (functionp func) (apply func args))
 699       (when (stringp string) (insert string))
 700       (write-region (point-min) (point-max) file t (list t)))))
 701
 702 (defun jabber-tree-map (fn tree)
 703   "Apply FN to all nodes in the TREE starting with root. FN is
 704 applied to the node and not to the data itself."
 705   (let ((result (cons nil nil)))
 706     (do ((tail tree (cdr tail))
 707          (prev result end)
 708          (end result (let* ((x (car tail))
 709                             (val (if (atom x)
 710                                      (funcall fn x)
 711                                    (jabber-tree-map fn x))))
 712                        (setf (car end) val (cdr end) (cons nil
 713                                                            nil)))))
 714         ((atom tail)
 715          (progn
 716            (setf (cdr prev) (if tail (funcall fn tail) nil))
 717            result)))))
 718
 719 (provide 'jabber-util)
 720
 721 ;;; arch-tag: cfbb73ac-e2d7-4652-a08d-dc789bcded8a