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