jabber-export.el

   1 ;;; jabber-export.el --- export Jabber roster to file
   2
   3 ;; Copyright (C) 2005, 2007  Magnus Henoch
   4
   5 ;; Author: Magnus Henoch <mange@freemail.hu>
   6
   7 ;; This file is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; This file is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 (require 'cl)
  23
  24 (defvar jabber-export-roster-widget nil)
  25
  26 (defvar jabber-import-subscription-p-widget nil)
  27
  28 ;;;###autoload
  29 (defun jabber-export-roster (jc)
  30   "Export roster for connection JC."
  31   (interactive (list (jabber-read-account)))
  32   (let ((state-data (fsm-get-state-data jc)))
  33     (jabber-export-roster-do-it
  34      (jabber-roster-to-sexp (plist-get state-data :roster)))))
  35
  36 (defun jabber-export-roster-do-it (roster)
  37   "Create buffer from which ROSTER can be exported to a file."
  38   (interactive)
  39   (with-current-buffer (get-buffer-create "Export roster")
  40     (jabber-init-widget-buffer nil)
  41
  42     (widget-insert (jabber-propertize "Export roster\n"
  43                                       'face 'jabber-title-large))
  44     (widget-insert "You are about to save your roster to a file.  Here
  45 you can edit it before saving.  Changes done here will
  46 not affect your actual roster.
  47
  48 ")
  49
  50     (widget-create 'push-button :notify #'jabber-export-save "Save to file")
  51     (widget-insert " ")
  52     (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
  53     (widget-insert "\n\n")
  54     (make-local-variable 'jabber-export-roster-widget)
  55
  56     (jabber-export-display roster)
  57
  58     (widget-setup)
  59     (widget-minor-mode 1)
  60     (goto-char (point-min))
  61     (switch-to-buffer (current-buffer))))
  62
  63 ;;;###autoload
  64 (defun jabber-import-roster (jc file)
  65   "Create buffer for roster import for connection JC from FILE."
  66   (interactive (list (jabber-read-account)
  67                      (read-file-name "Import roster from file: ")))
  68   (let ((roster
  69          (with-temp-buffer
  70            (let ((coding-system-for-read 'utf-8))
  71              (jabber-roster-xml-to-sexp
  72               (car (xml-parse-file file)))))))
  73     (with-current-buffer (get-buffer-create "Import roster")
  74       (setq jabber-buffer-connection jc)
  75
  76       (jabber-init-widget-buffer nil)
  77
  78       (widget-insert (jabber-propertize "Import roster\n"
  79                                         'face 'jabber-title-large))
  80       (widget-insert "You are about to import the contacts below to your roster.
  81
  82 ")
  83
  84       (make-local-variable 'jabber-import-subscription-p-widget)
  85       (setq jabber-import-subscription-p-widget
  86             (widget-create 'checkbox))
  87       (widget-insert " Adjust subscriptions\n")
  88
  89       (widget-create 'push-button :notify #'jabber-import-doit "Import to roster")
  90       (widget-insert " ")
  91       (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp")
  92       (widget-insert "\n\n")
  93       (make-local-variable 'jabber-export-roster-widget)
  94
  95       (jabber-export-display roster)
  96
  97       (widget-setup)
  98       (widget-minor-mode 1)
  99       (goto-char (point-min))
 100       (switch-to-buffer (current-buffer)))))
 101
 102 (defun jabber-export-remove-regexp (&rest ignore)
 103   (let* ((value (widget-value jabber-export-roster-widget))
 104          (length-before (length value))
 105          (regexp (read-string "Remove JIDs matching regexp: ")))
 106     (setq value (delete-if
 107                  #'(lambda (a)
 108                      (string-match regexp (nth 0 a)))
 109                  value))
 110     (widget-value-set jabber-export-roster-widget value)
 111     (widget-setup)
 112     (message "%d items removed" (- length-before (length value)))))
 113
 114 (defun jabber-export-save (&rest ignore)
 115   "Export roster to file."
 116   (let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget)))
 117         (coding-system-for-write 'utf-8))
 118     (with-temp-file (read-file-name "Export roster to file: ")
 119       (insert "<iq xmlns='jabber:client'><query xmlns='jabber:iq:roster'>\n")
 120       (dolist (item items)
 121         (insert (jabber-sexp2xml item) "\n"))
 122       (insert "</query></iq>\n"))
 123     (message "Roster saved")))
 124
 125 (defun jabber-import-doit (&rest ignore)
 126   "Import roster being edited in widget."
 127   (let* ((state-data (fsm-get-state-data jabber-buffer-connection))
 128          (jabber-roster (plist-get state-data :roster))
 129          roster-delta)
 130
 131     (dolist (n (widget-value jabber-export-roster-widget))
 132       (let* ((jid (nth 0 n))
 133              (name (and (not (zerop (length (nth 1 n))))
 134                         (nth 1 n)))
 135              (subscription (nth 2 n))
 136              (groups (nth 3 n))
 137              (jid-symbol (jabber-jid-symbol jid))
 138              (in-roster-p (memq jid-symbol jabber-roster))
 139              (jid-name (and in-roster-p (get jid-symbol 'name)))
 140              (jid-subscription (and in-roster-p (get jid-symbol 'subscription)))
 141              (jid-groups (and in-roster-p (get jid-symbol 'groups))))
 142         ;; Do we need to change the roster?
 143         (when (or
 144                ;; If the contact is not in the roster already,
 145                (not in-roster-p)
 146                ;; or if the import introduces a name,
 147                (and name (not jid-name))
 148                ;; or changes a name,
 149                (and name jid-name (not (string= name jid-name)))
 150                ;; or introduces new groups.
 151                (set-difference groups jid-groups :test #'string=))
 152           (push (jabber-roster-sexp-to-xml
 153                  (list jid (or name jid-name) nil (union groups jid-groups :test #'string=))
 154                  t)
 155                 roster-delta))
 156         ;; And adujst subscription.
 157         (when (widget-value jabber-import-subscription-p-widget)
 158           (let ((want-to (member subscription '("to" "both")))
 159                 (want-from (member subscription '("from" "both")))
 160                 (have-to (member jid-subscription '("to" "both")))
 161                 (have-from (member jid-subscription '("from" "both"))))
 162             (flet ((request-subscription
 163                     (type)
 164                     (jabber-send-sexp jabber-buffer-connection
 165                                       `(presence ((to . ,jid)
 166                                                   (type . ,type))))))
 167               (cond
 168                ((and want-to (not have-to))
 169                 (request-subscription "subscribe"))
 170                ((and have-to (not want-to))
 171                 (request-subscription "unsubscribe")))
 172               (cond
 173                ((and want-from (not have-from))
 174                 ;; not much to do here
 175                 )
 176                ((and have-from (not want-from))
 177                 (request-subscription "unsubscribed"))))))))
 178     (when roster-delta
 179       (jabber-send-iq jabber-buffer-connection
 180                       nil "set"
 181                       `(query ((xmlns . "jabber:iq:roster")) ,@roster-delta)
 182                       #'jabber-report-success "Roster import"
 183                       #'jabber-report-success "Roster import"))))
 184
 185 (defun jabber-roster-to-sexp (roster)
 186   "Convert ROSTER to simpler sexp format.
 187 Return a list, where each item is a vector:
 188 \[jid name subscription groups]
 189 where groups is a list of strings."
 190   (mapcar
 191    #'(lambda (n)
 192        (list
 193         (symbol-name n)
 194         (or (get n 'name) "")
 195         (get n 'subscription)
 196         (get n 'groups)))
 197    roster))
 198
 199 (defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription)
 200   "Convert SEXP to XML format.
 201 Return an XML node."
 202   `(item ((jid . ,(nth 0 sexp))
 203           ,@(let ((name (nth 1 sexp)))
 204               (unless (zerop (length name))
 205                 `((name . ,name))))
 206           ,@(unless omit-subscription
 207               `((subscription . ,(nth 2 sexp)))))
 208          ,@(mapcar
 209             #'(lambda (g)
 210                 (list 'group nil g))
 211             (nth 3 sexp))))
 212
 213 (defun jabber-roster-xml-to-sexp (xml-data)
 214   "Convert XML-DATA to simpler sexp format.
 215 XML-DATA is an <iq> node with a <query xmlns='jabber:iq:roster'> child.
 216 See `jabber-roster-to-sexp' for description of output format."
 217   (assert (eq (jabber-xml-node-name xml-data) 'iq))
 218   (let ((query (car (jabber-xml-get-children xml-data 'query))))
 219     (assert query)
 220     (mapcar
 221      #'(lambda (n)
 222          (list
 223           (jabber-xml-get-attribute n 'jid)
 224           (or (jabber-xml-get-attribute n 'name) "")
 225           (jabber-xml-get-attribute n 'subscription)
 226           (mapcar
 227            #'(lambda (g)
 228                (car (jabber-xml-node-children g)))
 229            (jabber-xml-get-children n 'group))))
 230      (jabber-xml-get-children query 'item))))
 231
 232 (defun jabber-export-display (roster)
 233   (setq jabber-export-roster-widget
 234         (widget-create
 235          '(repeat
 236            :tag "Roster"
 237            (list :format "%v"
 238                    (string :tag "JID")
 239                    (string :tag "Name")
 240                    (choice :tag "Subscription"
 241                            (const "none")
 242                            (const "both")
 243                            (const "to")
 244                            (const "from"))
 245                    (repeat :tag "Groups"
 246                            (string :tag "Group"))))
 247          :value roster)))
 248
 249 (provide 'jabber-export)
 250
 251 ;;; arch-tag: 9c6b94a9-290a-4c0f-9286-72bd9c1fb8a3