cgit.sxemacs.org Git - gnus/blob - lisp/webmail.el

   1 ;;; webmail.el --- interface of web mail
   2 ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: hotmail netaddress my-deja netscape
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Note: Now mail.yahoo.com provides POP3 service, the webmail
  27 ;; fetching is not going to be supported.
  28
  29 ;; Note: You need to have `url' and `w3' installed for this backend to
  30 ;; work. `w3' must be 4.0pre46+one-line-cookie patch or standalone
  31 ;; `url'.
  32
  33 ;; Todo: To support more web mail servers.
  34
  35 ;; Known bugs:
  36 ;; 1. Net@ddress may corrupt `X-Face'.
  37
  38 ;; Warning:
  39 ;; Webmail is an experimental function, which means NO WARRANTY.
  40
  41 ;;; Code:
  42
  43 (eval-when-compile (require 'cl))
  44
  45 (require 'nnoo)
  46 (require 'message)
  47 (require 'gnus-util)
  48 (require 'gnus)
  49 (require 'nnmail)
  50 (require 'mm-util)
  51 (require 'mm-url)
  52 (require 'mml)
  53 (eval-when-compile
  54   (ignore-errors
  55     (require 'url)
  56     (require 'url-cookie)))
  57 ;; Report failure to find w3 at load time if appropriate.
  58 (eval '(progn
  59          (require 'url)
  60          (require 'url-cookie)))
  61
  62 ;;;
  63
  64 (defvar webmail-type-definition
  65   '((hotmail
  66      ;; Hotmail hate other HTTP user agents and use one line cookie
  67      (paranoid agent cookie post)
  68      (address . "www.hotmail.com")
  69      (open-url "http://www.hotmail.com/")
  70      (open-snarf . webmail-hotmail-open)
  71      ;; W3 hate redirect POST
  72      (login-url
  73       "http://%s/cgi-bin/dologin?login=%s&passwd=%s&enter=Sign+in&sec=no&curmbox=ACTIVE&_lang=&js=yes&id=2&tw=-10000&beta="
  74       webmail-aux user password)
  75      ;;(login-snarf . webmail-hotmail-login)
  76      ;;(list-url "%s" webmail-aux)
  77      (list-snarf . webmail-hotmail-list)
  78      (article-snarf . webmail-hotmail-article)
  79      (trash-url
  80       "%s&login=%s&f=33792&curmbox=ACTIVE&_lang=&foo=inbox&js=&page=&%s=on&_HMaction=MoveTo&tobox=trAsH&nullbox="
  81       webmail-aux user id))
  82     (yahoo
  83      (paranoid agent cookie post)
  84      (address . "mail.yahoo.com")
  85      (open-url "http://mail.yahoo.com/")
  86      (open-snarf . webmail-yahoo-open)
  87      (login-url;; yahoo will not accept GET
  88       content
  89       ("%s" webmail-aux)
  90       ".tries=&.src=ym&.last=&promo=&.intl=&.bypass=&.partner=&.chkP=Y&.done=&login=%s&passwd=%s"
  91       user password)
  92      (login-snarf . webmail-yahoo-login)
  93      (list-url "%s&rb=Inbox&YN=1" webmail-aux)
  94      (list-snarf . webmail-yahoo-list)
  95      (article-snarf . webmail-yahoo-article)
  96      (trash-url
  97       "%s/ym/ShowFolder?YY=52107&inc=50&order=down&sort=date&pos=0&box=Inbox&DEL=Delete&destBox=&Mid=%s&destBox2="
  98       webmail-aux id))
  99     (netaddress
 100      (paranoid cookie post)
 101      (address . "www.netaddress.com")
 102      (open-url "http://www.netaddress.com/")
 103      (open-snarf . webmail-netaddress-open)
 104      (login-url
 105       content
 106       ("%s" webmail-aux)
 107       "LoginState=2&SuccessfulLogin=%%2Ftpl&NewServerName=www.netaddress.com&JavaScript=JavaScript1.2&DomainID=4&Domain=usa.net&NA31site=classic.netaddress.com&NA31port=80&UserID=%s&passwd=%s"
 108       user password)
 109      (login-snarf . webmail-netaddress-login)
 110      (list-url
 111       "http://www.netaddress.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True"
 112       webmail-session)
 113      (list-snarf . webmail-netaddress-list)
 114      (article-url "http://www.netaddress.com/")
 115      (article-snarf . webmail-netaddress-article)
 116      (trash-url
 117       "http://www.netaddress.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1"
 118       webmail-session id))
 119     (netscape
 120      (paranoid cookie post agent)
 121      (address . "webmail.netscape.com")
 122      (open-url "http://ureg.netscape.com/iiop/UReg2/login/login?U2_LA=en&U2_BACK_FROM_CJ=true&U2_CS=iso-8859-1&U2_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_NEW_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_EXITURL=http://home.netscape.com/&U2_SOURCE=Webmail")
 123      (open-snarf . webmail-netscape-open)
 124      (login-url
 125       content
 126       ("http://ureg.netscape.com/iiop/UReg2/login/loginform")
 127       "U2_USERNAME=%s&U2_PASSWORD=%s%s"
 128       user password webmail-aux)
 129      (login-snarf . webmail-netaddress-login)
 130      (list-url
 131       "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True"
 132       webmail-session)
 133      (list-snarf . webmail-netaddress-list)
 134      (article-url "http://webmail.netscape.com/")
 135      (article-snarf . webmail-netscape-article)
 136      (trash-url
 137       "http://webmail.netscape.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1"
 138       webmail-session id))
 139     (my-deja
 140      (paranoid cookie post)
 141      (address . "www.my-deja.com")
 142      ;;(open-snarf . webmail-my-deja-open)
 143      (login-url
 144       content
 145       ("http://mydeja.google.com/cgi-bin/deja/maillogin.py")
 146       "userid=%s&password=%s"
 147       user password)
 148      (list-snarf . webmail-my-deja-list)
 149      (article-snarf . webmail-my-deja-article)
 150      (trash-url webmail-aux id))))
 151
 152 (defvar webmail-variables
 153   '(address article-snarf article-url list-snarf list-url
 154             login-url login-snarf open-url open-snarf site articles
 155             post-process paranoid trash-url))
 156
 157 (defconst webmail-version "webmail 1.0")
 158
 159 (defvar webmail-newmail-only nil
 160   "Only fetch new mails.")
 161
 162 (defvar webmail-move-to-trash-can t
 163   "Move mail to trash can after fetch it.")
 164
 165 ;;; Internal variables
 166
 167 (defvar webmail-address nil)
 168 (defvar webmail-paranoid nil)
 169 (defvar webmail-aux nil)
 170 (defvar webmail-session nil)
 171 (defvar webmail-article-snarf nil)
 172 (defvar webmail-article-url nil)
 173 (defvar webmail-list-snarf nil)
 174 (defvar webmail-list-url nil)
 175 (defvar webmail-login-url nil)
 176 (defvar webmail-login-snarf nil)
 177 (defvar webmail-open-snarf nil)
 178 (defvar webmail-open-url nil)
 179 (defvar webmail-trash-url nil)
 180 (defvar webmail-articles nil)
 181 (defvar webmail-post-process nil)
 182
 183 (defvar webmail-buffer nil)
 184 (defvar webmail-buffer-list nil)
 185
 186 (defvar webmail-type nil)
 187
 188 (defvar webmail-error-function nil)
 189
 190 (defvar webmail-debug-file "~/.emacs-webmail-debug")
 191
 192 ;;; Interface functions
 193
 194 (defun webmail-debug (str)
 195   (with-temp-buffer
 196     (insert "\n---------------- A bug at " str " ------------------\n")
 197     (mapcar #'(lambda (sym)
 198                 (if (boundp sym)
 199                     (pp `(setq ,sym ',(eval sym)) (current-buffer))))
 200             '(webmail-type user))
 201     (insert "---------------- webmail buffer ------------------\n\n")
 202     (insert-buffer-substring webmail-buffer)
 203     (insert "\n---------------- end of buffer ------------------\n\n")
 204     (append-to-file (point-min) (point-max) webmail-debug-file)))
 205
 206 (defun webmail-error (str)
 207   (if webmail-error-function
 208       (funcall webmail-error-function str))
 209   (message "%s HTML has changed or your w3 package is too old.(%s)"
 210            webmail-type str)
 211   (error "%s HTML has changed or your w3 package is too old.(%s)"
 212          webmail-type str))
 213
 214 (defun webmail-setdefault (type)
 215   (let ((type-def (cdr (assq type webmail-type-definition)))
 216         (vars webmail-variables)
 217         pair)
 218     (setq webmail-type type)
 219     (dolist (var vars)
 220       (if (setq pair (assq var type-def))
 221           (set (intern (concat "webmail-" (symbol-name var))) (cdr pair))
 222         (set (intern (concat "webmail-" (symbol-name var))) nil)))))
 223
 224 (defun webmail-eval (expr)
 225   (cond
 226    ((consp expr)
 227     (cons (webmail-eval (car expr)) (webmail-eval (cdr expr))))
 228    ((symbolp expr)
 229     (eval expr))
 230    (t
 231     expr)))
 232
 233 (defun webmail-url (xurl)
 234   (mm-with-unibyte-current-buffer
 235     (cond
 236      ((eq (car xurl) 'content)
 237       (pop xurl)
 238       (mm-url-fetch-simple (if (stringp (car xurl))
 239                                 (car xurl)
 240                               (apply 'format (webmail-eval (car xurl))))
 241                             (apply 'format (webmail-eval (cdr xurl)))))
 242      ((eq (car xurl) 'post)
 243       (pop xurl)
 244       (mm-url-fetch-form (car xurl) (webmail-eval (cdr xurl))))
 245      (t
 246       (mm-url-insert (apply 'format (webmail-eval xurl)))))))
 247
 248 (defun webmail-init ()
 249   "Initialize buffers and such."
 250   (if (gnus-buffer-live-p webmail-buffer)
 251       (set-buffer webmail-buffer)
 252     (setq webmail-buffer
 253           (nnheader-set-temp-buffer " *webmail*"))
 254     (mm-disable-multibyte)))
 255
 256 (defvar url-package-name)
 257 (defvar url-package-version)
 258 (defvar url-cookie-multiple-line)
 259 (defvar url-confirmation-func)
 260
 261 ;; Hack W3 POST redirect.  See `url-parse-mime-headers'.
 262 ;;
 263 ;; Netscape uses "GET" as redirect method when orignal method is POST
 264 ;; and status is 302, .i.e no security risks by default without
 265 ;; confirmation.
 266 ;;
 267 ;; Some web servers (at least Apache used by yahoo) return status 302
 268 ;; instead of 303, though they mean 303.
 269
 270 (defun webmail-url-confirmation-func (prompt)
 271   (cond
 272    ((equal prompt (concat "Honor redirection with non-GET method "
 273                           "(possible security risks)? "))
 274     nil)
 275    ((equal prompt "Continue (with method of GET)? ")
 276     t)
 277    (t (error prompt))))
 278
 279 (defun webmail-refresh-redirect ()
 280   "Redirect refresh url in META."
 281   (goto-char (point-min))