wl auto config

wl-auto-config.el

;; Copyright 2011 Erik Hetzner
;;
;; 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.

(require 'wl)
(require 'cl)

(defun egh:wl-auto-config-substitute (for addr)
  (let* ((parsed (eword-extract-address-components addr))
         (realname (car parsed))
         (fulladdr (car (cdr parsed)))
         (local (car (split-string fulladdr "@")))
         (domain (car (cdr (split-string fulladdr "@")))))
    (cond ((string= for "%EMAILADDRESS%")
           fulladdr)
          ((string= for "%EMAILDOMAIN%")
           domain)
          ((string= for "%EMAILLOCALPART%")
           local)
          ((string= for "%REALNAME%")
           realname)
          (t for))))

(defun egh:wl-auto-config-get-param (config what)
  (car (xml-node-children
        (car (xml-get-children config what)))))

(defun egh:wl-auto-config-parse-auth (authentication)
  (let ((downauth (downcase authentication)))
    (cond ((or (string= "plain" downauth)
               (string= "password-cleartext" downauth))
           "clear")
          ((or (string= "password-encrypted" downauth)
               (string= "secure" downauth))
           "cram-md5") ;; or "digest-md5" ?
          ((string= "ntlm" downauth)
           "ntlm")
          (t nil))))

(defun egh:wl-auto-config-build-outgoing (outgoing addr)
  (flet ((ssub (s) (egh:wl-auto-config-substitute s addr)))
    (mapc (lambda (config)
            (cond ((string= "smtp" 
                            (xml-get-attribute-or-nil config 'type))
                   (let* ((posting-port
                           (egh:wl-auto-config-get-param config 'port))
                          (posting-server
                           (egh:wl-auto-config-get-param config 'hostname))
                          (posting-user
                           (ssub (egh:wl-auto-config-get-param config 'username)))
                          (authenticate-type
                           (egh:wl-auto-config-parse-auth
                            (egh:wl-auto-config-get-param config 'authentication)))
                          (socket-type
                           (egh:wl-auto-config-get-param config 'socketType))
                          (connection-type
                           (cond ((string= "ssl" (downcase socket-type))
                                  'ssl)
                                 ((or (string= "starttls" (downcase socket-type))
                                      (string= "tls" (downcase socket-type)))
                                  'starttls)
                                 ((string= "plain" (downcase socket-type))
                                  nil))))
                     (let ((f (if (y-or-n-p
                                   "Do you want to set the detected SMTP/from settings? ")
                                  (if (y-or-n-p
                                       (format "Do you want to save them to %s? "
                                               custom-file))
                                      (function customize-save-variable)
                                    (function customize-set-variable)))))
                       (if (not (null f))
                           (progn
                             (funcall f 'wl-from addr)
                             (funcall f 'wl-local-domain 
                                      (egh:wl-auto-config-substitute
                                       "%EMAILDOMAIN%"
                                       addr))
                             (funcall f 'wl-local-domain posting-server)
                             (funcall f 'wl-smtp-connection-type connection-type)
                             (funcall f 'wl-smtp-authenticate-type authenticate-type)
                             (funcall f 'wl-smtp-posting-port posting-port)
                             (funcall f 'wl-smtp-posting-server posting-server)
                             (funcall f 'wl-smtp-posting-user posting-user))))))))
        outgoing)))

(defun egh:wl-auto-config-build-incoming (incoming addr)
  (flet ((ssub (s) (egh:wl-auto-config-substitute s addr))
         (quote-username (s)
                         (if (string-match "@" s)
                             (format "\"%s\"" s)
                           s)))
    (mapc (lambda (config)
            (cond ((string= "imap"
                            (xml-get-attribute-or-nil config 'type))
                   (let* ((port
                           (egh:wl-auto-config-get-param config 'port))
                          (username
                           (quote-username
                            (ssub (egh:wl-auto-config-get-param config 'username))))
                          (hostname
                           (egh:wl-auto-config-get-param config 'hostname))
                          (socket-type
                           (egh:wl-auto-config-get-param config 'socketType))
                          (elmo-stream-type
                           (cond ((string= "ssl" (downcase socket-type))
                                  "!")
                                 ((or (string= "starttls" (downcase socket-type))
                                      (string= "tls" (downcase socket-type)))
                                  "!!")
                                 ((string= "plain" (downcase socket-type))
                                  "!direct")))
                          (authentication
                           (egh:wl-auto-config-get-param config 'authentication))
                          (elmo-authentication-type
                           (egh:wl-auto-config-parse-auth authentication))
                          (foldername
                           (format "%%:%s/%s@%s:%s%s"
                                   username
                                   elmo-authentication-type 
                                   hostname 
                                   port
                                   elmo-stream-type)))
                     (if (y-or-n-p
                          (format "Do you want to add the IMAP access folder %s? " 
                                  foldername))
                         (save-excursion
                           (wl)
                           (goto-char (point-max))
                           (wl-fldmgr-make-group foldername t)))))))
          incoming)))

(defun egh:wl-auto-config (addr)
  (interactive "sYour email address: ")
  (let* ((domain (egh:wl-auto-config-substitute "%EMAILDOMAIN%" addr))
         (urls (mapc 'url-generic-parse-url
                     (list (format "https://live.mozillamessaging.com/autoconfig/v1.1/%s" domain)
                           (format "https://ispdb.mozillamessaging.com/export_xml/v1.1/%s" domain)))))
    (save-excursion
      (catch :done
        (dolist (url urls)
          (set-buffer (url-retrieve-synchronously url))
          (if (eq url-http-response-status 200)
              (let* ((doc (car (xml-parse-region (point-min) (point-max))))
                     (provider (car (xml-get-children doc 'emailProvider)))
                     (outgoing (xml-get-children provider 'outgoingServer))
                     (incoming (xml-get-children provider 'incomingServer)))
                (egh:wl-auto-config-build-outgoing outgoing addr)
                (egh:wl-auto-config-build-incoming incoming addr)
                (throw :done nil))))
        (error "No auto-config settings found for %s on mozillamessaging.com, sorry!" addr)))))