Skip to content

Instantly share code, notes, and snippets.

@egh

egh/wl-auto-config.el

Created September 10, 2011 01:39
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
  • Save egh/1207807 to your computer and use it in GitHub Desktop.
Save egh/1207807 to your computer and use it in GitHub Desktop.
Download ZIP
wl auto config
Raw
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.
(progn
(require 'wl)
(require 'cl)
(flet ((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))))
(egh:wl-auto-config-get-param
(config what)
(car (xml-node-children
(car (xml-get-children config what)))))
(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))))
(egh:wl-auto-config-build-outgoing
(outgoing 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
(egh:wl-auto-config-substitute
(egh:wl-auto-config-get-param config 'username) addr))
(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))
;; otherwise print them
(message "SMTP settings are:
(setq wl-from %S
wl-local-domain %S
wl-smtp-connection-type %s
wl-smtp-authenticate-type %S
wl-smtp-posting-port %S
wl-smtp-posting-server %S
wl-smtp-posting-user %S)"
addr
(egh:wl-auto-config-substitute "%EMAILDOMAIN%" addr)
(if (null connection-type)
"nil" (format "'%S" connection-type))
authenticate-type
posting-port
posting-server
posting-user)))))))
outgoing))
(egh:wl-auto-config-build-incoming
(incoming addr)
(mapc (lambda (config)
(cond ((string= "imap"
(xml-get-attribute-or-nil config 'type))
(let* ((quote-username (lambda (s)
(if (string-match "@" s)
(format "\"%s\"" s)
s)))
(port
(egh:wl-auto-config-get-param config 'port))
(username
(funcall quote-username
(egh:wl-auto-config-substitute
(egh:wl-auto-config-get-param config 'username) addr)))
(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))
(message "Folder name is: %s" foldername))))))
incoming)))
(let* ((addr (read-from-minibuffer "Your email address: "))
(domain (egh:wl-auto-config-substitute "%EMAILDOMAIN%" addr))
(url-strings
(list (format "http://autoconfig.%s/mail/config-v1.1.xml?emailaddress=%s" domain addr)
(format "http://%s/.well-known/autoconfig/mail/config-v1.1.xml" domain)
(format "https://live.mozillamessaging.com/autoconfig/v1.1/%s" domain)))
(urls (mapc 'url-generic-parse-url url-strings)))
(save-excursion
(catch :done
(dolist (url urls)
(condition-case nil
(let ((buff (url-retrieve-synchronously url)))
(if (not (null buff))
(progn
(set-buffer buff)
(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 nil)))
(error "No auto-config settings found for %s, sorry!" addr))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment