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 (defcustom wl-acap-cache-filename "acap-cache"
  87   "ACAP setting cache file."
  88   :type 'string
  89   :group 'wl)
  90
  91 ;; Encoding string as BASE64 is temporal solution.
  92 ;; As far as I know, current implementation of ACAP server
  93 ;; (cyrus-smlacapd 0.5) does not accept literal argument for STORE.
  94 (defvar wl-acap-base64-encode-options
  95   '(wl-template-alist
  96     wl-draft-config-alist)
  97   "Options which should be encoded with base64 to store ACAP server.")
  98
  99 (defcustom wl-acap-coding-system 'utf-8
 100   "Coding system for ACAP."
 101   :type 'symbol
 102   :group 'wl)
 103
 104 (defvar wl-acap-original-msgdb-directory nil)
 105
 106 (defun wl-acap-exit ()
 107   "End ACAP session."
 108   (when wl-acap-original-msgdb-directory
 109     (setq elmo-msgdb-directory wl-acap-original-msgdb-directory)))
 110
 111 (defun wl-acap-init ()
 112   "A candidate for `wl-folder-init-function'."
 113   (setq wl-acap-original-msgdb-directory nil)
 114   (condition-case err                   ; catch error and quit.
 115       (let ((service (wl-acap-find-acap-service))
 116             proc entries settings folder-top type caches msgdb-dir)
 117         (if (null (car service))
 118             (if (setq caches
 119                       (delq
 120                        nil
 121                        (mapcar
 122                         (lambda (dirent)
 123                           (let ((dir
 124                                  (elmo-localdir-folder-directory-internal
 125                                   (elmo-make-folder dirent))))
 126                             (if (file-exists-p
 127                                  (setq dir (expand-file-name
 128                                             wl-acap-cache-filename
 129                                             dir)))
 130                                 dir)))
 131                         (elmo-folder-list-subfolders
 132                          (elmo-make-folder (concat "+"
 133                                                    (expand-file-name
 134                                                     "acap"
 135                                                     elmo-msgdb-directory)))))))
 136                 (if (y-or-n-p "No ACAP service found.  Try cache? ")
 137                     (let (selected rpath alist)
 138                       (setq alist
 139                             (mapcar
 140                              (lambda (dir)
 141                                (setq rpath (nreverse (split-string dir "/")))
 142                                (cons (concat (nth 1 rpath) "@" (nth 2 rpath))
 143                                      dir))
 144                              caches)
 145                             selected
 146                             (cdr (assoc
 147                                   (completing-read
 148                                    "Select ACAP cache: " alist nil t)
 149                                   alist))
 150                             msgdb-dir (file-name-directory selected)
 151                             entries (elmo-object-load selected)))
 152                   (error "No ACAP service found"))
 153               (error "No ACAP service found"))
 154           (setq proc (acap-open (car service)
 155                                 wl-acap-user
 156                                 (upcase (symbol-name
 157                                          wl-acap-authenticate-type))
 158                                 (cdr service)))
 159           (setq entries (acap-response-entries
 160                          (acap-search proc (concat "/"
 161                                                    wl-acap-dataset-class
 162                                                    "/~/")
 163                                       '((RETURN ("*"))))))
 164           (when entries
 165             (elmo-object-save
 166              (expand-file-name
 167               (concat "acap/" (car service) "/" wl-acap-user "/"
 168                       wl-acap-cache-filename)
 169               elmo-msgdb-directory)
 170              entries)))
 171         (while entries
 172           (when (string= (acap-response-entry-entry (car entries))
 173                          wl-acap-entry-name)
 174             (setq settings (car (acap-response-entry-return-data-list
 175                                  (car entries)))
 176                   entries nil))
 177           (setq entries (cdr entries)))
 178         (setq settings
 179               (delq
 180                'wl-acap-ignored
 181                (mapcar (lambda (x)
 182                          (let ((sym (wl-acap-symbol (car x))))
 183                            (cond
 184                             ((and sym (eq sym 'wl-folders))
 185                              ;; Folders.
 186                              (setq wl-folder-entity
 187                                    (wl-acap-create-folder-entity (cadr x)))
 188                              'wl-acap-ignored)
 189                             ((and sym (boundp sym))
 190                              (setq type (custom-variable-type sym))
 191                              (cons
 192                               sym
 193                               (when (cadr x)
 194                                 (cond
 195                                  ((or (eq (car type) 'string)
 196                                       (and (eq (car type) 'choice)
 197                                            (memq 'string type)))
 198                                   (if (memq sym wl-acap-base64-encode-options)
 199                                       (wl-acap-base64-decode-string (cadr x))
 200                                     (decode-coding-string
 201                                      (cadr x)
 202                                      wl-acap-coding-system)))
 203                                  (t
 204                                   (if (cadr x)
 205                                       (read
 206                                        (if (memq sym
 207                                                  wl-acap-base64-encode-options)
 208                                            (wl-acap-base64-decode-string
 209                                             (cadr x))
 210                                          (read (concat
 211                                                 "\""
 212                                                 (decode-coding-string
 213                                                  (cadr x)
 214                                                  wl-acap-coding-system)
 215                                                 "\""))
 216                                          ))))))))
 217                             (t 'wl-acap-ignored))))
 218                        settings)))
 219         ;; Setup options.
 220         (dolist (setting settings)
 221           (set (car setting) (cdr setting)))
 222         ;; Database directory becomes specific to the ACAP server.
 223         (setq wl-acap-original-msgdb-directory elmo-msgdb-directory)
 224         (setq elmo-msgdb-directory (or msgdb-dir
 225                                        (expand-file-name
 226                                         (concat "acap/" (car service)
 227                                                 "/" wl-acap-user)
 228                                         elmo-msgdb-directory)))
 229         (when proc (acap-close proc)))
 230     ((error quit)
 231      (when wl-acap-original-msgdb-directory
 232        (setq elmo-msgdb-directory wl-acap-original-msgdb-directory))
 233      (signal (car err) (cdr err)))))
 234
 235 (defun wl-acap-create-folder-entity (string)
 236   (with-temp-buffer
 237     (message "Initializing folder...")
 238     (let (folders entity)
 239       (setq string (elmo-base64-decode-string string))
 240       (setq string (decode-coding-string string wl-acap-coding-system))
 241       (insert string)
 242       (goto-char (point-min))
 243       (while (and (not (eobp))
 244                   (setq entity (wl-create-folder-entity-from-buffer)))
 245         (unless (eq entity 'ignore)
 246           (wl-append folders (list entity))))
 247       (message "Initializing folder...done")
 248       (list wl-folder-desktop-name 'group folders))))
 249
 250 (defun wl-acap-find-acap-service ()
 251   (or (and wl-acap-server
 252            (cons wl-acap-server wl-acap-port))
 253       (with-temp-buffer
 254         (message "Searching ACAP server...")
 255         (prog1 (let ((response (condition-case nil
 256                                    (slp-findsrvs "acap")
 257                                  (error)))
 258                      selected)
 259                  (when response
 260                    (if (> (length (slp-response-body response)) 1)
 261                        (progn
 262                          (setq selected
 263                                (completing-read
 264                                 "Select ACAP server: "
 265                                 (mapcar (lambda (body)
 266                                           (list
 267                                            (concat
 268                                             (slp-response-srv-url-host
 269                                              body)
 270                                             (when (slp-response-srv-url-port
 271                                                    body)
 272                                               (concat
 273                                                ":"
 274                                                (slp-response-srv-url-port
 275                                                 body))))))
 276                                         (slp-response-body response)))
 277                                response
 278                                (catch 'done
 279                                  (dolist (entry (slp-response-body response))
 280                                    (when (string=
 281                                           (concat
 282                                            (slp-response-srv-url-host
 283                                             entry)
 284                                            (when
 285                                                (slp-response-srv-url-port
 286                                                 entry)
 287                                              (concat
 288                                               ":"
 289                                               (slp-response-srv-url-port
 290                                                entry))))
 291                                           selected)
 292                                      (throw 'done entry))))))
 293                      (setq response (car (slp-response-body response))))
 294                    (cons (slp-response-srv-url-host response)
 295                          (slp-response-srv-url-port response))))
 296           (message "Searching ACAP server...done")))
 297       (cons "localhost" nil)))
 298
 299 (defun wl-acap-name (option)
 300   (let ((name (symbol-name option))
 301         prefix)
 302     (cond ((string-match "^wl-" name)
 303            (setq name (substring name (match-end 0))
 304                  prefix "wl"))
 305           ((string-match "^elmo-" name)
 306            (setq name (substring name (match-end 0))
 307                  prefix "elmo")))
 308     (concat
 309      wl-acap-dataset-class "." prefix "."
 310      (mapconcat 'capitalize (split-string name "-") ""))))
 311
 312 (defun wl-acap-symbol (name)
 313   (let (case-fold-search li)
 314     (when (string-match (concat "^" (regexp-quote wl-acap-dataset-class)
 315                                 "\\.\\([^\\.]+\\)\\.") name)
 316       (setq li (list (match-string 1 name))
 317             name (substring name (match-end 0)))
 318       (while (string-match "^[A-Z][a-z0-9]*" name)
 319         (setq li (cons (match-string 0 name) li))
 320         (setq name (substring name (match-end 0))))
 321       (intern (mapconcat 'downcase (nreverse li) "-")))))
 322
 323 (defun wl-acap-list-options ()
 324   (nconc (mapcar 'car (append (custom-group-members 'wl-setting nil)
 325                               (custom-group-members 'elmo-setting nil)))
 326          wl-acap-extra-options))
 327
 328 (defun wl-acap-store-folders (proc)
 329   (with-temp-buffer
 330     (insert-file-contents wl-folders-file)
 331     (acap-store
 332      proc
 333      (list (concat "/" wl-acap-dataset-class "/~/"
 334                    wl-acap-entry-name)
 335            (concat wl-acap-dataset-class ".wl.Folders")
 336            (wl-acap-base64-encode-string (buffer-string))))))
 337
 338 (defun wl-acap-base64-encode-string (string)
 339   (elmo-base64-encode-string
 340    (encode-coding-string string wl-acap-coding-system)
 341    'no-line-break))
 342
 343 (defun wl-acap-base64-decode-string (string)
 344   (decode-coding-string
 345    (elmo-base64-decode-string string )
 346    wl-acap-coding-system))
 347
 348 (defun wl-acap-store ()
 349   "Store Wanderlust configuration to the ACAP server."
 350   (interactive)
 351   (wl-load-profile)
 352   (elmo-init)
 353   (let ((service (wl-acap-find-acap-service))
 354         proc settings type)
 355     (setq proc (acap-open (car service)
 356                           wl-acap-user
 357                           (upcase (symbol-name wl-acap-authenticate-type))
 358                           (cdr service)))
 359     (dolist (option (wl-acap-list-options))
 360       (setq settings
 361             (cons (wl-acap-name option) settings)
 362             settings
 363             (cons (when (symbol-value option)
 364                     (setq type (custom-variable-type option))
 365                     (cond
 366                      ((or (eq (car type) 'string)
 367                           (and (eq (car type) 'choice)
 368                                (memq 'string type)))
 369                       (if (memq option wl-acap-base64-encode-options)
 370                           (wl-acap-base64-encode-string
 371                            (symbol-value option))
 372                         (encode-coding-string
 373                          (symbol-value option)
 374                          wl-acap-coding-system)))
 375                      (t (if (memq option wl-acap-base64-encode-options)
 376                             (wl-acap-base64-encode-string
 377                              (prin1-to-string (symbol-value option)))
 378                           (encode-coding-string
 379                            (prin1-to-string (symbol-value option))
 380                            wl-acap-coding-system)))))
 381                   settings)))
 382     (unwind-protect
 383         (progn
 384           (message "Storing settings...")
 385           (acap-store proc
 386                       (nconc
 387                        (list
 388                         (concat
 389                          "/" wl-acap-dataset-class "/~/" wl-acap-entry-name))
 390                        (nreverse settings)))
 391           (message "Storing folders...")
 392           (wl-acap-store-folders proc)
 393 ;;; Does not work correctly??
 394 ;;;       (acap-setacl proc (list
 395 ;;;                          (concat
 396 ;;;                           "/" wl-acap-dataset-class "/~/"))
 397 ;;;                    "anyone" "") ; protect.
 398           )
 399       (acap-close proc))
 400     (if (interactive-p)
 401         (message "Store completed."))))
 402
 403 (require 'product)
 404 (product-provide (provide 'wl-acap) (require 'wl-version))
 405
 406 ;;; wl-acap.el ends here