;;; wl-acap.el -- ACAP support for Wanderlust.

;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>

;; Author: Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: mail, net news

;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;

;;; Commentary:

;;; Code:
;;

(cond
 ((and (not (featurep 'utf-2000))
       (module-installed-p 'un-define))
  (require 'un-define))
 ((and (featurep 'xemacs)
       (not (featurep 'utf-2000))
       (module-installed-p 'xemacs-ucs))
  (require 'xemacs-ucs)))
(require 'custom)
(require 'cus-edit)
(require 'wl-vars)
(require 'wl)
(require 'elmo-vars)
(require 'acap)
(require 'slp)

(defconst wl-acap-dataset-class "vendor.wanderlust")
(defconst wl-acap-entry-name "settings")

(defcustom wl-acap-user (or (getenv "USER")
			    (getenv "LOGNAME")
			    (user-login-name))
  "ACAP user."
  :type 'string
  :group 'wl)

(defcustom wl-acap-server nil
  "ACAP server.
If nil, SLP is used to find ACAP server.
If nil and SLP is not available, localhost is assumed."
  :type 'string
  :group 'wl)

(defcustom wl-acap-port nil
  "ACAP server port.
Only valid when `wl-acap-server' is non-nil.
If nil, default acap port is used."
  :type 'string
  :group 'wl)

(defcustom wl-acap-authenticate-type 'cram-md5
  "ACAP authenticate type."
  :type 'symbol
  :group 'wl)

(defcustom wl-acap-stream-type nil
  "ACAP stream type."
  :type 'symbol
  :group 'wl)

(defcustom wl-acap-extra-options nil
  "Extra options to be saved on ACAP server."
  :type '(repeat symbol)
  :group 'wl)

;; Encoding string as BASE64 is temporal solution.
;; As far as I know, current implementation of ACAP server
;; (cyrus-smlacapd 0.5) does not accept literal argument for STORE.
(defvar wl-acap-base64-encode-options
  '(wl-template-alist
    wl-draft-config-alist)
  "Options which should be encoded with base64 to store ACAP server.")

(defcustom wl-acap-coding-system 'utf-8
  "Coding system for ACAP."
  :type 'symbol
  :group 'wl)

(defun wl-acap-init ()
  "A candidate for `wl-folder-init-function'."
  (let ((service (wl-acap-find-acap-service))
	proc entries settings folder-top type)
    (unless (car service) (error "No ACAP service found"))
    (setq proc (acap-open (car service)
			  wl-acap-user
			  (upcase (symbol-name wl-acap-authenticate-type))
			  (cdr service)))
    (setq entries (acap-response-entries
		   (acap-search proc (concat "/"
					     wl-acap-dataset-class
					     "/~/")
				'((RETURN ("*"))))))
    (while entries
      (when (string= (acap-response-entry-entry (car entries))
		     wl-acap-entry-name)
	(setq settings (car (acap-response-entry-return-data-list
			     (car entries)))
	      entries nil))
      (setq entries (cdr entries)))
    (setq settings
	  (delq
	   'wl-acap-ignored
	   (mapcar (lambda (x)
		     (let ((sym (wl-acap-symbol (car x))))
		       (cond
			((and sym (eq sym 'wl-folders))
			 ;; Folders.
			 (setq wl-folder-entity
			       (wl-acap-create-folder-entity (cadr x)))
			 'wl-acap-ignored)
			((and sym (boundp sym))
			 (setq type (custom-variable-type sym))
			 (cons
			  sym
			  (when (cadr x)
			    (cond
			     ((or (eq (car type) 'string)
				  (and (eq (car type) 'choice)
				       (memq 'string type)))
			      (if (memq sym wl-acap-base64-encode-options)
				  (wl-acap-base64-decode-string (cadr x))
				(decode-coding-string
				 (cadr x)
				 wl-acap-coding-system)))
			     (t
			      (if (cadr x)
				  (read
				   (if (memq sym
					     wl-acap-base64-encode-options)
				       (wl-acap-base64-decode-string (cadr x))
				      (read (concat
					     "\""
					     (decode-coding-string
					      (cadr x)
					      wl-acap-coding-system)
					     "\""))
				      ))))))))
			(t 'wl-acap-ignored))))
		   settings)))
    ;; Setup options.
    (dolist (setting settings)
      (set (car setting) (cdr setting)))
    ;; Database directory becomes specific to the ACAP server.
    (setq elmo-msgdb-dir (expand-file-name
			  (concat "acap/" (car service) "/" wl-acap-user)
			  elmo-msgdb-dir))
    (acap-close proc)))

(defun wl-acap-create-folder-entity (string)
  (with-temp-buffer
    (message "Initializing folder...")
    (let (folders)
      (setq string (elmo-base64-decode-string string))
      (setq string (decode-coding-string string wl-acap-coding-system))
      (insert string)
      (goto-char (point-min))
      (while (and (not (eobp))
		  (setq entity (wl-create-folder-entity-from-buffer)))
	(unless (eq entity 'ignore)
	  (wl-append folders (list entity))))
      (message "Initializing folder...done")
      (list wl-folder-desktop-name 'group folders))))

(defun wl-acap-find-acap-service ()
  (or (and wl-acap-server
	   (cons wl-acap-server wl-acap-port))
      (with-temp-buffer
	(message "Searching ACAP server...")
	(prog1 (let ((response (condition-case nil
				   (slp-findsrvs "acap")
				 (error))))
		 (when response
		   ;; Only the first service entry is used.
		   (setq response (car (slp-response-body response)))
		   (cons (slp-response-srv-url-host response)
			 (slp-response-srv-url-port response))))
	  (message "Searching ACAP server...done")))
      (cons "localhost" nil)))

(defun wl-acap-name (option)
  (let ((name (symbol-name option))
	prefix)
    (cond ((string-match "^wl-" name)
	   (setq name (substring name (match-end 0))
		 prefix "wl"))
	  ((string-match "^elmo-" name)
	   (setq name (substring name (match-end 0))
		 prefix "elmo")))
    (concat
     wl-acap-dataset-class "." prefix "."
     (mapconcat 'capitalize (split-string name "-") ""))))

(defun wl-acap-symbol (name)
  (let (case-fold-search li)
    (when (string-match (concat "^" (regexp-quote wl-acap-dataset-class)
				"\\.\\([^\\.]+\\)\\.") name)
      (setq li (list (match-string 1 name))
	    name (substring name (match-end 0)))
      (while (string-match "^[A-Z][a-z0-9]*" name)
	(setq li (cons (match-string 0 name) li))
	(setq name (substring name (match-end 0))))
      (intern (mapconcat 'downcase (nreverse li) "-")))))

(defun wl-acap-list-options ()
  (nconc (mapcar 'car (append (custom-group-members 'wl-setting nil)
			      (custom-group-members 'elmo-setting nil)))
	 wl-acap-extra-options))

(defun wl-acap-store-folders (proc)
  (with-temp-buffer
    (insert-file-contents wl-folders-file)
    (acap-store
     proc
     (list (concat "/" wl-acap-dataset-class "/~/"
		   wl-acap-entry-name)
	   (concat wl-acap-dataset-class ".wl.Folders")
	   (wl-acap-base64-encode-string (buffer-string))))))

(defun wl-acap-base64-encode-string (string)
  (elmo-base64-encode-string
   (encode-coding-string string wl-acap-coding-system)
   'no-line-break))

(defun wl-acap-base64-decode-string (string)
  (decode-coding-string
   (elmo-base64-decode-string string )
   wl-acap-coding-system))

(defun wl-acap-store ()
  "Store Wanderlust configuration to the ACAP server."
  (interactive)
  (wl-load-profile)
  (elmo-init)
  (let ((service (wl-acap-find-acap-service))
	proc settings type)
    (setq proc (acap-open (car service)
			  wl-acap-user
			  (upcase (symbol-name wl-acap-authenticate-type))
			  (cdr service)))
    (dolist (option (wl-acap-list-options))
      (setq settings
	    (cons (wl-acap-name option) settings)
	    settings
	    (cons (when (symbol-value option)
		    (setq type (custom-variable-type option))
		    (cond
		     ((or (eq (car type) 'string)
			  (and (eq (car type) 'choice)
			       (memq 'string type)))
		      (if (memq option wl-acap-base64-encode-options)
			  (wl-acap-base64-encode-string
			   (symbol-value option))
			(encode-coding-string
			 (symbol-value option)
			 wl-acap-coding-system)))
		     (t (if (memq option wl-acap-base64-encode-options)
			    (wl-acap-base64-encode-string
			     (prin1-to-string (symbol-value option)))
			  (encode-coding-string
			   (prin1-to-string (symbol-value option))
			   wl-acap-coding-system)))))
		  settings)))
    (unwind-protect
	(progn
	  (message "Storing settings...")
	  (acap-store proc
		      (nconc
		       (list
			(concat
			 "/" wl-acap-dataset-class "/~/" wl-acap-entry-name))
		       (nreverse settings)))
	  (message "Storing folders...")
	  (wl-acap-store-folders proc)
	  ;; Does not work correctly??
	  ;;	  (acap-setacl proc (list
	  ;;			     (concat
	  ;;			      "/" wl-acap-dataset-class "/~/"))
	  ;;		       "anyone" "") ; protect.
	  )
      (acap-close proc))
    (if (interactive-p)
	(message "Store completed."))))

(require 'product)
(product-provide (provide 'wl-acap) (require 'wl-version))

;;; wl-acap.el ends here