wl/wl-acap.el

   1 ;;; wl-acap.el -- ACAP support for Wanderlust.
   2
   3 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   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, or (at your option)
  13 ;; 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 GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29 ;;
  30
  31 (cond
  32  ((and (not (featurep 'utf-2000))
  33        (module-installed-p 'un-define))
  34   (require 'un-define))
  35  ((and (featurep 'xemacs)
  36        (not (featurep 'utf-2000))
  37        (module-installed-p 'xemacs-ucs))
  38   (require 'xemacs-ucs)))
  39 (require 'custom)
  40 (require 'cus-edit)
  41 (require 'wl-vars)
  42 (require 'wl)
  43 (require 'elmo-vars)
  44 (require 'acap)
  45 (require 'slp)
  46
  47 (defconst wl-acap-dataset-class "vendor.wanderlust")
  48 (defconst wl-acap-entry-name "settings")
  49
  50 (defcustom wl-acap-user (or (getenv "USER")
  51                             (getenv "LOGNAME")
  52                             (user-login-name))
  53   "ACAP user."
  54   :type 'string
  55   :group 'wl)
  56
  57 (defcustom wl-acap-server nil
  58   "ACAP server.
  59 If nil, SLP is used to find ACAP server.
  60 If nil and SLP is not available, localhost is assumed."
  61   :type 'string
  62   :group 'wl)
  63
  64 (defcustom wl-acap-port nil
  65   "ACAP server port.
  66 Only valid when `wl-acap-server' is non-nil.
  67 If nil, default acap port is used."
  68   :type 'string
  69   :group 'wl)
  70
  71 (defcustom wl-acap-authenticate-type 'cram-md5
  72   "ACAP authenticate type."
  73   :type 'symbol
  74   :group 'wl)
  75
  76 (defcustom wl-acap-stream-type nil
  77   "ACAP stream type."
  78   :type 'symbol
  79   :group 'wl)
  80
  81 (defcustom wl-acap-extra-options nil
  82   "Extra options to be saved on ACAP server."
  83   :type '(repeat symbol)
  84   :group 'wl)
  85
  86 ;; Encoding string as BASE64 is temporal solution.
  87 ;; As far as I know, current implementation of ACAP server
  88 ;; (cyrus-smlacapd 0.5) does not accept literal argument for STORE.
  89 (defvar wl-acap-base64-encode-options
  90   '(wl-template-alist
  91     wl-draft-config-alist)
  92   "Options which should be encoded with base64 to store ACAP server.")
  93
  94 (defcustom wl-acap-coding-system 'utf-8
  95   "Coding system for ACAP."
  96   :type 'symbol
  97   :group 'wl)
  98
  99 (defun wl-acap-init ()
 100   "A candidate for `wl-folder-init-function'."
 101   (let ((service (wl-acap-find-acap-service))
 102         proc entries settings folder-top type)
 103     (setq proc (acap-open (car service)
 104                           wl-acap-user
 105                           (upcase (symbol-name wl-acap-authenticate-type))
 106                           (cdr service)))
 107     (setq entries (acap-response-entries
 108                    (acap-search proc (concat "/"
 109                                              wl-acap-dataset-class
 110                                              "/~/")
 111                                 '((RETURN ("*"))))))
 112     (while entries
 113       (when (string= (acap-response-entry-entry (car entries))
 114                      wl-acap-entry-name)
 115         (setq settings (car (acap-response-entry-return-data-list
 116                              (car entries)))
 117               entries nil))
 118       (setq entries (cdr entries)))
 119     (setq settings
 120           (delq
 121            'wl-acap-ignored
 122            (mapcar (lambda (x)
 123                      (let ((sym (wl-acap-symbol (car x))))
 124                        (cond
 125                         ((and sym (eq sym 'wl-folders))
 126                          ;; Folders.
 127                          (setq wl-folder-entity
 128                                (wl-acap-create-folder-entity (cadr x)))
 129                          'wl-acap-ignored)
 130                         ((and sym (boundp sym))
 131                          (setq type (custom-variable-type sym))
 132                          (cons
 133                           sym
 134                           (when (cadr x)
 135                             (cond
 136                              ((or (eq (car type) 'string)
 137                                   (and (eq (car type) 'choice)
 138                                        (memq 'string type)))
 139                               (if (memq sym wl-acap-base64-encode-options)
 140                                   (wl-acap-base64-decode-string (cadr x))
 141                                 (cadr x)))
 142                              (t
 143                               (if (cadr x)
 144                                   (read
 145                                    (if (memq sym
 146                                              wl-acap-base64-encode-options)
 147                                        (wl-acap-base64-decode-string (cadr x))
 148                                      (read (concat "\"" (cadr x) "\""))))))))))
 149                         (t 'wl-acap-ignored))))
 150                    settings)))
 151     ;; Setup options.
 152     (dolist (setting settings)
 153       (set (car setting) (cdr setting)))
 154     ;; Database directory becomes specific to the ACAP server.
 155     (setq elmo-msgdb-dir (expand-file-name
 156                           (concat "acap/" (car service) "/" wl-acap-user)
 157                           elmo-msgdb-dir))
 158     (acap-close proc)))
 159
 160 (defun wl-acap-create-folder-entity (string)
 161   (with-temp-buffer
 162     (message "Initializing folder...")
 163     (let (folders)
 164       (setq string (elmo-base64-decode-string string))
 165       (setq string (decode-coding-string string wl-acap-coding-system))
 166       (insert string)
 167       (goto-char (point-min))
 168       (while (and (not (eobp))
 169                   (setq entity (wl-create-folder-entity-from-buffer)))
 170         (unless (eq entity 'ignore)
 171           (wl-append folders (list entity))))
 172       (message "Initializing folder...done")
 173       (list wl-folder-desktop-name 'group folders))))
 174
 175 (defun wl-acap-find-acap-service ()
 176   (or (and wl-acap-server
 177            (cons wl-acap-server wl-acap-port))
 178       (with-temp-buffer
 179         (message "Searching ACAP server...")
 180         (prog1 (let ((response (condition-case nil
 181                                    (slp-findsrvs "acap")
 182                                  (error))))
 183                  (when response
 184                    ;; Only the first service entry is used.
 185                    (setq response (car (slp-response-body response)))
 186                    (cons (slp-response-srv-url-host response)
 187                          (slp-response-srv-url-port response))))
 188           (message "Searching ACAP server...done.")))
 189       (cons "localhost" nil)))
 190
 191 (defun wl-acap-name (option)
 192   (let ((name (symbol-name option))
 193         prefix)
 194     (cond ((string-match "^wl-" name)
 195            (setq name (substring name (match-end 0))
 196                  prefix "wl"))
 197           ((string-match "^elmo-" name)
 198            (setq name (substring name (match-end 0))
 199                  prefix "elmo")))
 200     (concat
 201      wl-acap-dataset-class "." prefix "."
 202      (mapconcat 'capitalize (split-string name "-") ""))))
 203
 204 (defun wl-acap-symbol (name)
 205   (let (case-fold-search li)
 206     (when (string-match (concat "^" (regexp-quote wl-acap-dataset-class)
 207                                 "\\.\\([^\\.]+\\)\\.") name)
 208       (setq li (list (match-string 1 name))
 209             name (substring name (match-end 0)))
 210       (while (string-match "^[A-Z][a-z0-9]*" name)
 211         (setq li (cons (match-string 0 name) li))
 212         (setq name (substring name (match-end 0))))
 213       (intern (mapconcat 'downcase (nreverse li) "-")))))
 214
 215 (defun wl-acap-list-options ()
 216   (nconc (mapcar 'car (append (custom-group-members 'wl-setting nil)
 217                               (custom-group-members 'elmo-setting nil)))
 218          wl-acap-extra-options))
 219
 220 (defun wl-acap-store-folders (proc)
 221   (with-temp-buffer
 222     (insert-file-contents wl-folders-file)
 223     (acap-store
 224      proc
 225      (list (concat "/" wl-acap-dataset-class "/~/"
 226                    wl-acap-entry-name)
 227            (concat wl-acap-dataset-class ".wl.Folders")
 228            (wl-acap-base64-encode-string (buffer-string))))))
 229
 230 (defun wl-acap-base64-encode-string (string)
 231   (elmo-base64-encode-string
 232    (encode-coding-string string wl-acap-coding-system)
 233    'no-line-break))
 234
 235 (defun wl-acap-base64-decode-string (string)
 236   (decode-coding-string
 237    (elmo-base64-decode-string string )
 238    wl-acap-coding-system))
 239
 240 (defun wl-acap-store ()
 241   "Store Wanderlust configuration to the ACAP server."
 242   (interactive)
 243   (wl-load-profile)
 244   (elmo-init)
 245   (let ((service (wl-acap-find-acap-service))
 246         proc settings type)
 247     (setq proc (acap-open (car service)
 248                           wl-acap-user
 249                           (upcase (symbol-name wl-acap-authenticate-type))
 250                           (cdr service)))
 251     (dolist (option (wl-acap-list-options))
 252       (setq settings
 253             (cons (wl-acap-name option) settings)
 254             settings
 255             (cons (when (symbol-value option)
 256                     (setq type (custom-variable-type option))
 257                     (cond
 258                      ((or (eq (car type) 'string)
 259                           (and (eq (car type) 'choice)
 260                                (memq 'string type)))
 261                       (if (memq option wl-acap-base64-encode-options)
 262                           (wl-acap-base64-encode-string
 263                            (symbol-value option))
 264                         (symbol-value option)))
 265                      (t (if (memq option wl-acap-base64-encode-options)
 266                             (wl-acap-base64-encode-string
 267                              (prin1-to-string (symbol-value option)))
 268                           (prin1-to-string (symbol-value option))))))
 269                   settings)))
 270     (unwind-protect
 271         (progn
 272           (message "Storing settings...")
 273           (acap-store proc
 274                       (nconc
 275                        (list
 276                         (concat
 277                          "/" wl-acap-dataset-class "/~/" wl-acap-entry-name))
 278                        (nreverse settings)))
 279           (message "Storing folders...")
 280           (wl-acap-store-folders proc)
 281           ;; Does not work correctly??
 282           ;;      (acap-setacl proc (list
 283           ;;                         (concat
 284           ;;                          "/" wl-acap-dataset-class "/~/"))
 285           ;;                   "anyone" "") ; protect.
 286           )
 287       (acap-close proc))
 288     (if (interactive-p)
 289         (message "Store completed."))))
 290
 291 (provide 'wl-acap)
 292
 293 ;;; wl-acap.el ends here