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                                 (decode-coding-string
 142                                  (cadr x)
 143                                  wl-acap-coding-system)))
 144                              (t
 145                               (if (cadr x)
 146                                   (read
 147                                    (if (memq sym
 148                                              wl-acap-base64-encode-options)
 149                                        (wl-acap-base64-decode-string (cadr x))
 150                                       (read (concat
 151                                              "\""
 152                                              (decode-coding-string
 153                                               (cadr x)
 154                                               wl-acap-coding-system)
 155                                              "\""))
 156                                       ))))))))
 157                         (t 'wl-acap-ignored))))
 158                    settings)))
 159     ;; Setup options.
 160     (dolist (setting settings)
 161       (set (car setting) (cdr setting)))
 162     ;; Database directory becomes specific to the ACAP server.
 163     (setq elmo-msgdb-dir (expand-file-name
 164                           (concat "acap/" (car service) "/" wl-acap-user)
 165                           elmo-msgdb-dir))
 166     (acap-close proc)))
 167
 168 (defun wl-acap-create-folder-entity (string)
 169   (with-temp-buffer
 170     (message "Initializing folder...")
 171     (let (folders)
 172       (setq string (elmo-base64-decode-string string))
 173       (setq string (decode-coding-string string wl-acap-coding-system))
 174       (insert string)
 175       (goto-char (point-min))
 176       (while (and (not (eobp))
 177                   (setq entity (wl-create-folder-entity-from-buffer)))
 178         (unless (eq entity 'ignore)
 179           (wl-append folders (list entity))))
 180       (message "Initializing folder...done")
 181       (list wl-folder-desktop-name 'group folders))))
 182
 183 (defun wl-acap-find-acap-service ()
 184   (or (and wl-acap-server
 185            (cons wl-acap-server wl-acap-port))
 186       (with-temp-buffer
 187         (message "Searching ACAP server...")
 188         (prog1 (let ((response (condition-case nil
 189                                    (slp-findsrvs "acap")
 190                                  (error))))
 191                  (when response
 192                    ;; Only the first service entry is used.
 193                    (setq response (car (slp-response-body response)))
 194                    (cons (slp-response-srv-url-host response)
 195                          (slp-response-srv-url-port response))))
 196           (message "Searching ACAP server...done.")))
 197       (cons "localhost" nil)))
 198
 199 (defun wl-acap-name (option)
 200   (let ((name (symbol-name option))
 201         prefix)
 202     (cond ((string-match "^wl-" name)
 203            (setq name (substring name (match-end 0))
 204                  prefix "wl"))
 205           ((string-match "^elmo-" name)
 206            (setq name (substring name (match-end 0))
 207                  prefix "elmo")))
 208     (concat
 209      wl-acap-dataset-class "." prefix "."
 210      (mapconcat 'capitalize (split-string name "-") ""))))
 211
 212 (defun wl-acap-symbol (name)
 213   (let (case-fold-search li)
 214     (when (string-match (concat "^" (regexp-quote wl-acap-dataset-class)
 215                                 "\\.\\([^\\.]+\\)\\.") name)
 216       (setq li (list (match-string 1 name))
 217             name (substring name (match-end 0)))
 218       (while (string-match "^[A-Z][a-z0-9]*" name)
 219         (setq li (cons (match-string 0 name) li))
 220         (setq name (substring name (match-end 0))))
 221       (intern (mapconcat 'downcase (nreverse li) "-")))))
 222
 223 (defun wl-acap-list-options ()
 224   (nconc (mapcar 'car (append (custom-group-members 'wl-setting nil)
 225                               (custom-group-members 'elmo-setting nil)))
 226          wl-acap-extra-options))
 227
 228 (defun wl-acap-store-folders (proc)
 229   (with-temp-buffer
 230     (insert-file-contents wl-folders-file)
 231     (acap-store
 232      proc
 233      (list (concat "/" wl-acap-dataset-class "/~/"
 234                    wl-acap-entry-name)
 235            (concat wl-acap-dataset-class ".wl.Folders")
 236            (wl-acap-base64-encode-string (buffer-string))))))
 237
 238 (defun wl-acap-base64-encode-string (string)
 239   (elmo-base64-encode-string
 240    (encode-coding-string string wl-acap-coding-system)
 241    'no-line-break))
 242
 243 (defun wl-acap-base64-decode-string (string)
 244   (decode-coding-string
 245    (elmo-base64-decode-string string )
 246    wl-acap-coding-system))
 247
 248 (defun wl-acap-store ()
 249   "Store Wanderlust configuration to the ACAP server."
 250   (interactive)
 251   (wl-load-profile)
 252   (elmo-init)
 253   (let ((service (wl-acap-find-acap-service))
 254         proc settings type)
 255     (setq proc (acap-open (car service)
 256                           wl-acap-user
 257                           (upcase (symbol-name wl-acap-authenticate-type))
 258                           (cdr service)))
 259     (dolist (option (wl-acap-list-options))
 260       (setq settings
 261             (cons (wl-acap-name option) settings)
 262             settings
 263             (cons (when (symbol-value option)
 264                     (setq type (custom-variable-type option))
 265                     (cond
 266                      ((or (eq (car type) 'string)
 267                           (and (eq (car type) 'choice)
 268                                (memq 'string type)))
 269                       (if (memq option wl-acap-base64-encode-options)
 270                           (wl-acap-base64-encode-string
 271                            (symbol-value option))
 272                         (encode-coding-string
 273                          (symbol-value option)
 274                          wl-acap-coding-system)))
 275                      (t (if (memq option wl-acap-base64-encode-options)
 276                             (wl-acap-base64-encode-string
 277                              (prin1-to-string (symbol-value option)))
 278                           (encode-coding-string
 279                            (prin1-to-string (symbol-value option))
 280                            wl-acap-coding-system)))))
 281                   settings)))
 282     (unwind-protect
 283         (progn
 284           (message "Storing settings...")
 285           (acap-store proc
 286                       (nconc
 287                        (list
 288                         (concat
 289                          "/" wl-acap-dataset-class "/~/" wl-acap-entry-name))
 290                        (nreverse settings)))
 291           (message "Storing folders...")
 292           (wl-acap-store-folders proc)
 293           ;; Does not work correctly??
 294           ;;      (acap-setacl proc (list
 295           ;;                         (concat
 296           ;;                          "/" wl-acap-dataset-class "/~/"))
 297           ;;                   "anyone" "") ; protect.
 298           )
 299       (acap-close proc))
 300     (if (interactive-p)
 301         (message "Store completed."))))
 302
 303 (provide 'wl-acap)
 304
 305 ;;; wl-acap.el ends here