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