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