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                      selected)
 193                  (when response
 194                    (if (> (length (slp-response-body response)) 1)
 195                        (progn
 196                          (setq selected
 197                                (completing-read
 198                                 "Select ACAP server: "
 199                                 (mapcar (lambda (body)
 200                                           (list
 201                                            (concat
 202                                             (slp-response-srv-url-host
 203                                              body)
 204                                             (when (slp-response-srv-url-port
 205                                                    body)
 206                                               (concat
 207                                                ":"
 208                                                (slp-response-srv-url-port
 209                                                 body))))))
 210                                         (slp-response-body response)))
 211                                response
 212                                (catch 'done
 213                                  (dolist (entry (slp-response-body response))
 214                                    (when (string=
 215                                           (concat
 216                                            (slp-response-srv-url-host
 217                                             entry)
 218                                            (when
 219                                                (slp-response-srv-url-port
 220                                                 entry)
 221                                              (concat
 222                                               ":"
 223                                               (slp-response-srv-url-port
 224                                                entry))))
 225                                           selected)
 226                                      (throw 'done entry))))))
 227                      (setq response (car (slp-response-body response))))
 228                    (cons (slp-response-srv-url-host response)
 229                          (slp-response-srv-url-port response))))
 230           (message "Searching ACAP server...done")))
 231       (cons "localhost" nil)))
 232
 233 (defun wl-acap-name (option)
 234   (let ((name (symbol-name option))
 235         prefix)
 236     (cond ((string-match "^wl-" name)
 237            (setq name (substring name (match-end 0))
 238                  prefix "wl"))
 239           ((string-match "^elmo-" name)
 240            (setq name (substring name (match-end 0))
 241                  prefix "elmo")))
 242     (concat
 243      wl-acap-dataset-class "." prefix "."
 244      (mapconcat 'capitalize (split-string name "-") ""))))
 245
 246 (defun wl-acap-symbol (name)
 247   (let (case-fold-search li)
 248     (when (string-match (concat "^" (regexp-quote wl-acap-dataset-class)
 249                                 "\\.\\([^\\.]+\\)\\.") name)
 250       (setq li (list (match-string 1 name))
 251             name (substring name (match-end 0)))
 252       (while (string-match "^[A-Z][a-z0-9]*" name)
 253         (setq li (cons (match-string 0 name) li))
 254         (setq name (substring name (match-end 0))))
 255       (intern (mapconcat 'downcase (nreverse li) "-")))))
 256
 257 (defun wl-acap-list-options ()
 258   (nconc (mapcar 'car (append (custom-group-members 'wl-setting nil)
 259                               (custom-group-members 'elmo-setting nil)))
 260          wl-acap-extra-options))
 261
 262 (defun wl-acap-store-folders (proc)
 263   (with-temp-buffer
 264     (insert-file-contents wl-folders-file)
 265     (acap-store
 266      proc
 267      (list (concat "/" wl-acap-dataset-class "/~/"
 268                    wl-acap-entry-name)
 269            (concat wl-acap-dataset-class ".wl.Folders")
 270            (wl-acap-base64-encode-string (buffer-string))))))
 271
 272 (defun wl-acap-base64-encode-string (string)
 273   (elmo-base64-encode-string
 274    (encode-coding-string string wl-acap-coding-system)
 275    'no-line-break))
 276
 277 (defun wl-acap-base64-decode-string (string)
 278   (decode-coding-string
 279    (elmo-base64-decode-string string )
 280    wl-acap-coding-system))
 281
 282 (defun wl-acap-store ()
 283   "Store Wanderlust configuration to the ACAP server."
 284   (interactive)
 285   (wl-load-profile)
 286   (elmo-init)
 287   (let ((service (wl-acap-find-acap-service))
 288         proc settings type)
 289     (setq proc (acap-open (car service)
 290                           wl-acap-user
 291                           (upcase (symbol-name wl-acap-authenticate-type))
 292                           (cdr service)))
 293     (dolist (option (wl-acap-list-options))
 294       (setq settings
 295             (cons (wl-acap-name option) settings)
 296             settings
 297             (cons (when (symbol-value option)
 298                     (setq type (custom-variable-type option))
 299                     (cond
 300                      ((or (eq (car type) 'string)
 301                           (and (eq (car type) 'choice)
 302                                (memq 'string type)))
 303                       (if (memq option wl-acap-base64-encode-options)
 304                           (wl-acap-base64-encode-string
 305                            (symbol-value option))
 306                         (encode-coding-string
 307                          (symbol-value option)
 308                          wl-acap-coding-system)))
 309                      (t (if (memq option wl-acap-base64-encode-options)
 310                             (wl-acap-base64-encode-string
 311                              (prin1-to-string (symbol-value option)))
 312                           (encode-coding-string
 313                            (prin1-to-string (symbol-value option))
 314                            wl-acap-coding-system)))))
 315                   settings)))
 316     (unwind-protect
 317         (progn
 318           (message "Storing settings...")
 319           (acap-store proc
 320                       (nconc
 321                        (list
 322                         (concat
 323                          "/" wl-acap-dataset-class "/~/" wl-acap-entry-name))
 324                        (nreverse settings)))
 325           (message "Storing folders...")
 326           (wl-acap-store-folders proc)
 327           ;; Does not work correctly??
 328           ;;      (acap-setacl proc (list
 329           ;;                         (concat
 330           ;;                          "/" wl-acap-dataset-class "/~/"))
 331           ;;                   "anyone" "") ; protect.
 332           )
 333       (acap-close proc))
 334     (if (interactive-p)
 335         (message "Store completed."))))
 336
 337 (require 'product)
 338 (product-provide (provide 'wl-acap) (require 'wl-version))
 339
 340 ;;; wl-acap.el ends here