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