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