1 ;;; webmail.el --- interfacing with web mail
2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; This file is part of GNU Emacs.
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.
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.
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.
26 ;; Note: You need to have `url' and `w3' installed for this backend to
29 ;; Todo: To support more web mail.
32 ;; 1. In w3, there are two copies of url-maybe-relative.
33 ;; If it is loaded from w3.el, (load-library "url").
34 ;; Fixed in w3 4.0pre46.
35 ;; 2. Hotmail only accept one line cookie, while w3 breaks cookies
37 ;; Maybe fixed in w3 4.0pre47+?.
40 ;; webmail is an experimental function, which means NO WARRANTY.
44 (eval-when-compile (require 'cl))
59 ;; Report failure to find w3 at load time if appropriate.
68 (defvar webmail-type-definition
70 ;; Hotmail hate other HTTP user agents and use one line cookie
71 (paranoid agent cookie post)
72 (address . "www.hotmail.com")
73 (open-url "http://www.hotmail.com")
74 (open-snarf . webmail-hotmail-open)
75 ;; W3 hate redirect POST
77 "http://%s/cgi-bin/dologin?login=%s&passwd=%s&enter=Sign+in&sec=no&curmbox=ACTIVE&_lang=&js=yes&id=2&tw=-10000&beta="
78 webmail-aux user password)
79 (list-snarf . webmail-hotmail-list)
80 (article-snarf . webmail-hotmail-article)
82 "%s&login=%s&f=33792&curmbox=ACTIVE&_lang=&js=&foo=inbox&page=&%s=on&Move+To.x=Move+To&tobox=trAsH"
85 (paranoid cookie post)
86 (address . "mail.yahoo.com")
87 (open-url "http://mail.yahoo.com")
88 (open-snarf . webmail-yahoo-open)
89 (login-url ;; yahoo will not accept GET
92 ".tries=1&.src=ym&.last=&promo=&lg=us&.intl=us&.bypass=&.chkP=Y&.done=http%%253a%%2F%%2Fedit.yahoo.com%%2Fconfig%%2Fmail%%253f.intl%%3D&login=%s&passwd=%s"
94 (login-snarf . webmail-yahoo-login)
95 (list-url "%s&rb=Inbox&YN=1" webmail-aux)
96 (list-snarf . webmail-yahoo-list)
97 (article-snarf . webmail-yahoo-article)
99 "%s/ym/us/ShowFolder?YY=52107&inc=50&order=down&sort=date&pos=0&box=Inbox&DEL=Delete&destBox=&Mid=%s&destBox2="
102 (defvar webmail-variables
103 '(address article-snarf article-url list-snarf list-url
104 login-url login-snarf open-url open-snarf site articles
105 post-process paranoid trash-url))
107 (defconst webmail-version "webmail 1.0")
109 (defvar webmail-newmail-only nil
110 "Only fetch new mails.")
112 (defvar webmail-move-to-trash-can t
113 "Move mail to trash can after fetch it.")
115 ;;; Internal variables
117 (defvar webmail-address nil)
118 (defvar webmail-paranoid nil)
119 (defvar webmail-aux nil)
120 (defvar webmail-article-snarf nil)
121 (defvar webmail-article-url nil)
122 (defvar webmail-list-snarf nil)
123 (defvar webmail-list-url nil)
124 (defvar webmail-login-url nil)
125 (defvar webmail-login-snarf nil)
126 (defvar webmail-open-snarf nil)
127 (defvar webmail-open-url nil)
128 (defvar webmail-trash-url nil)
129 (defvar webmail-articles nil)
130 (defvar webmail-post-process nil)
132 (defvar webmail-buffer nil)
133 (defvar webmail-buffer-list nil)
134 ;;; Interface functions
136 (defun webmail-setdefault (type)
137 (let ((type-def (cdr (assq type webmail-type-definition)))
138 (vars webmail-variables)
141 (if (setq pair (assq var type-def))
142 (set (intern (concat "webmail-" (symbol-name var))) (cdr pair))
143 (set (intern (concat "webmail-" (symbol-name var))) nil)))))
145 (defun webmail-encode-www-form-urlencoded (pairs)
146 "Return PAIRS encoded for forms."
150 (concat (w3-form-encode-xwfu (car data)) "="
151 (w3-form-encode-xwfu (cdr data)))))
154 (defun webmail-fetch-simple (url content)
155 (let ((url-request-data content)
156 (url-request-method "POST")
157 (url-request-extra-headers
158 '(("Content-type" . "application/x-www-form-urlencoded"))))
162 (defun webmail-fetch-form (url pairs)
163 (let ((url-request-data (webmail-encode-www-form-urlencoded pairs))
164 (url-request-method "POST")
165 (url-request-extra-headers
166 '(("Content-type" . "application/x-www-form-urlencoded"))))
170 (defun webmail-eval (expr)
173 (cons (webmail-eval (car expr)) (webmail-eval (cdr expr))))
179 (defun webmail-url (xurl)
181 ((eq (car xurl) 'content)
183 (webmail-fetch-simple (if (stringp (car xurl))
185 (apply 'format (webmail-eval (car xurl))))
186 (apply 'format (webmail-eval (cdr xurl)))))
187 ((eq (car xurl) 'post)
189 (webmail-fetch-form (car xurl) (webmail-eval (cdr xurl))))
191 (nnweb-insert (apply 'format (webmail-eval xurl))))))
193 (defun webmail-decode-entities ()
194 (goto-char (point-min))
195 (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
196 (replace-match (char-to-string
197 (if (eq (aref (match-string 1) 0) ?\#)
198 (string-to-number (substring (match-string 1) 1))
199 (or (cdr (assq (intern (match-string 1))
204 (defun webmail-decode-entities-string (str)
207 (webmail-decode-entities)
208 (buffer-substring (point-min) (point-max))))
210 (defun webmail-remove-markup ()
211 (goto-char (point-min))
212 (while (search-forward "<!--" nil t)
213 (delete-region (match-beginning 0)
214 (or (search-forward "-->" nil t)
216 (goto-char (point-min))
217 (while (re-search-forward "<[^>]+>" nil t)
218 (replace-match "" t t)))
220 (defun webmail-init ()
221 "Initialize buffers and such."
222 (if (gnus-buffer-live-p webmail-buffer)
223 (set-buffer webmail-buffer)
225 (nnheader-set-temp-buffer " *webmail*"))))
227 (defvar url-package-name)
228 (defvar url-package-version)
229 (defvar url-cookie-multiple-line)
230 (defvar url-confirmation-func)
232 ;; Hack W3 POST redirect. See `url-parse-mime-headers'.
234 ;; Netscape uses "GET" as redirect method when orignal method is POST
235 ;; and status is 302, .i.e no security risks by default without
238 ;; Some web servers (at least Apache used by yahoo) return status 302
239 ;; instead of 303, though they mean 303.
241 (defun webmail-url-confirmation-func (prompt)
243 ((equal prompt (concat "Honor redirection with non-GET method "
244 "(possible security risks)? "))
246 ((equal prompt "Continue (with method of GET)? ")
251 (defun webmail-fetch (file subtype user password)
253 (webmail-setdefault subtype)
254 (let ((url-package-name (if (memq 'agent webmail-paranoid)
257 (url-package-version (if (memq 'agent webmail-paranoid)
259 url-package-version))
260 (url-cookie-multiple-line (if (memq 'cookie webmail-paranoid)
262 url-cookie-multiple-line))
263 (url-confirmation-func (if (memq 'post webmail-paranoid)
264 'webmail-url-confirmation-func
265 url-confirmation-func))
266 url-cookie-storage url-cookie-secure-storage
267 url-cookie-confirmation
270 (when webmail-open-url
272 (webmail-url webmail-open-url))
273 (if webmail-open-snarf (funcall webmail-open-snarf))
274 (when webmail-login-url
276 (webmail-url webmail-login-url))
277 (if webmail-login-snarf
278 (funcall webmail-login-snarf))
279 (when webmail-list-url
281 (webmail-url webmail-list-url))
282 (if webmail-list-snarf
283 (funcall webmail-list-snarf))
284 (while (setq item (pop webmail-articles))
285 (message "Fetching mail #%d..." (setq n (1+ n)))
287 (nnweb-insert (cdr item))
289 (if webmail-article-snarf
290 (funcall webmail-article-snarf file id))
291 (when (and webmail-trash-url webmail-move-to-trash-can)
292 (message "Move mail #%d to trash can..." n)
295 (webmail-url webmail-trash-url)
297 (while (setq buf (pop webmail-buffer-list))
301 (while (setq buf (pop webmail-buffer-list))
304 (if webmail-post-process
305 (funcall webmail-post-process))))
309 (defun webmail-hotmail-open ()
310 (goto-char (point-min))
311 (if (re-search-forward
312 "action=\"https?://\\([^/]+\\)/cgi-bin/dologin" nil t)
313 (setq webmail-aux (match-string 1))
314 (error "Can't find login url (open@1)")))
316 (defun webmail-hotmail-list ()
318 (goto-char (point-min))
319 (if (re-search-forward "[0-9]+ messages, [0-9]+ new")
320 (message "Found %s" (match-string 0)))
321 (goto-char (point-min))
322 (if (re-search-forward
323 "action=\"https?://\\([^/]+\\)/cgi-bin/HoTMaiL" nil t)
324 (setq site (match-string 1))
325 (error "Can't find server url (list@1)"))
326 (goto-char (point-min))
327 (if (re-search-forward "disk=\\([^&]+\\)&" nil t)
329 (concat "http://" site "/cgi-bin/HoTMaiL?disk="
331 (error "Can't find disk (list@2)"))
332 (goto-char (point-max))
333 (while (re-search-backward
334 "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\""
336 (if (setq url (match-string 1))
338 (if (or newp (not webmail-newmail-only))
340 (if (string-match "msg=\\([^&]+\\)" url)
341 (setq id (match-string 1 url)))
342 (push (cons id (concat "http://" site url))
347 (defun webmail-hotmail-article (file id)
348 (let (p attachment count mime)
350 (goto-char (point-min))
351 (if (not (search-forward "FILE: wc_pnames.asp -->" nil t))
352 (error "Can't find start label (article@1)"))
353 (setq p (match-end 0))
354 (search-backward "<table" nil t)
355 (narrow-to-region (point-min) p)
356 (delete-region (point-min) (match-beginning 0))
357 (while (search-forward "<a href=" nil t)
358 (setq p (match-beginning 0))
359 (search-forward "</a>" nil t)
360 (delete-region p (match-end 0)))
361 (webmail-remove-markup)
362 (webmail-decode-entities)
363 (goto-char (point-min))
365 (goto-char (point-max))
369 (while (re-search-forward "<div>\\|\\(http://[^/]+/cgi-bin/getmsg/\\([^\?]+\\)\?[^\"]*\\)\"" nil t)
370 (if (setq attachment (match-string 1))
371 (let ((filename (match-string 2))
372 bufname) ;; Attachment
373 (delete-region p (match-end 0))
375 (set-buffer (generate-new-buffer " *webmail-att*"))
376 (nnweb-insert attachment)
377 (push (current-buffer) webmail-buffer-list)
378 (setq bufname (buffer-name)))
380 (insert "<#part type="
382 (string-match "\\.[^\\.]+$" filename)
383 (mailcap-extension-to-mime
384 (match-string 0 filename)))
385 "application/octet-stream"))
386 (insert " buffer=\"" bufname "\"")
387 (insert " filename=\"" filename "\"")
388 (insert " disposition=\"inline\"")
389 (insert "><#/part>\n")
391 (delete-region p (match-end 0))
393 (while (and (> count 0)
394 (re-search-forward "</div>\\|\\(<div>\\)" nil t))
396 (setq count (1+ count))
397 (if (= (setq count (1- count)) 0)
398 (delete-region (match-beginning 0)
400 (narrow-to-region p (point))
401 (goto-char (point-min))
403 ((looking-at "<pre>")
404 (goto-char (match-end 0))
405 (if (looking-at "$") (forward-char))
406 (delete-region (point-min) (point))
407 (webmail-remove-markup)
408 (webmail-decode-entities)
412 (insert "<#part type=\"text/html\" disposition=inline>")
413 (goto-char (point-max))
414 (insert "<#/part>")))
415 (goto-char (point-max))
418 (delete-region p (point-max))
419 (goto-char (point-min))
420 ;; Some blank line to seperate mails.
421 (insert "\n\nFrom nobody " (current-time-string) "\n")
423 (insert "Message-ID: <" id "@hotmail.com>\n"))
424 (unless (looking-at "$")
425 (search-forward "\n\n" nil t)
427 (narrow-to-region (point) (point-max))
429 (insert "MIME-Version: 1.0\n"
432 (delete-region (point-min) (point-max)))))
433 (goto-char (point-min))
435 (let (case-fold-search)
436 (while (re-search-forward "^From " nil t)
439 (mm-append-to-file (point-min) (point-max) file)))
443 (defun webmail-yahoo-open ()
444 (goto-char (point-min))
445 (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t)
446 (setq webmail-aux (match-string 1))
447 (error "Can't find login url (open@1)")))
449 (defun webmail-yahoo-login ()
450 (goto-char (point-min))
451 (if (re-search-forward "http://[a-zA-Z][0-9]\\.mail\\.yahoo\\.com/" nil t)
452 (setq webmail-aux (match-string 0))
453 (error "Can't find login url (login@1)"))
454 (if (re-search-forward "YY=[0-9]+" nil t)
455 (setq webmail-aux (concat webmail-aux "ym/us/ShowFolder?"
457 (error "Can't find login url (login@2)")))
459 (defun webmail-yahoo-list ()
460 (let (url (newp t) (tofetch 0))
461 (goto-char (point-min))
462 (when (re-search-forward
463 "showing [0-9]+-\\([0-9]+\\) of \\([0-9]+\\)" nil t)
464 ;(setq listed (match-string 1))
465 (message "Found %s mail(s)" (match-string 2)))
466 (if (string-match "http://[^/]+" webmail-aux)
467 (setq webmail-aux (match-string 0 webmail-aux))
468 (error "Can't find server url (list@1)"))
469 (goto-char (point-min))
470 (while (re-search-forward
471 "bgcolor=\"#eeeeee\"\\|href=\"\\(/ym/us/ShowLetter\\?MsgId=\\([^&]+\\)&[^\"]*\\)\""
473 (if (setq url (match-string 1))
475 (when (or newp (not webmail-newmail-only))
476 (push (cons (match-string 2) (concat webmail-aux url "&toc=1"))
478 (setq tofetch (1+ tofetch)))
481 (message "Fetching %d mail(s)" tofetch)))
483 (defun webmail-yahoo-article (file id)
486 (goto-char (point-min))
487 (if (not (search-forward "value=\"Done\"" nil t))
488 (error "Can't find start label (article@1)"))
489 (if (not (search-forward "<table" nil t))
490 (error "Can't find start label (article@2)"))
491 (delete-region (point-min) (match-beginning 0))
492 (if (not (search-forward "</table>" nil t))
493 (error "Can't find start label (article@3)"))
494 (narrow-to-region (point-min) (match-end 0))
495 (while (search-forward "<a href=" nil t)
496 (setq p (match-beginning 0))
497 (search-forward "</a>" nil t)
498 (delete-region p (match-end 0)))
499 (webmail-remove-markup)
500 (webmail-decode-entities)
501 (goto-char (point-min))
503 (goto-char (point-max))
507 (while (re-search-forward "[^\"]*/ShowLetter/[^\?]+\?[^\"]*" nil t)
508 (setq attachment (match-string 0))
509 (let (bufname ct ctl cd description)
510 (if (not (search-forward "<table" nil t))
511 (error "Can't find start label (article@4)"))
512 (delete-region p (match-beginning 0))
513 (if (not (search-forward "</table>" nil t))
514 (error "Can't find start label (article@5)"))
515 (narrow-to-region p (match-end 0))
516 (webmail-remove-markup)
517 (webmail-decode-entities)
518 (goto-char (point-min))
520 (setq ct (mail-fetch-field "content-type")
521 ctl (ignore-errors (mail-header-parse-content-type ct))
522 ;;cte (mail-fetch-field "content-transfer-encoding")
523 cd (mail-fetch-field "content-disposition")
524 description (mail-fetch-field "content-description")
525 id (mail-fetch-field "content-id"))
526 (delete-region (point-min) (point-max))
529 (set-buffer (generate-new-buffer " *webmail-att*"))
530 (nnweb-insert (concat webmail-aux attachment))
531 (push (current-buffer) webmail-buffer-list)
532 (setq bufname (buffer-name)))
534 (if (and ctl (not (equal (car ctl) "text/")))
535 (insert " type=\"" (car ctl) "\""))
536 (insert " buffer=\"" bufname "\"")
538 (insert " disposition=\"" cd "\""))
540 (insert " description=\"" description "\""))
541 (insert "><#/part>\n")
543 (delete-region p (point-max))
544 (goto-char (point-min))
545 ;; Some blank line to seperate mails.
546 (insert "\n\nFrom nobody " (current-time-string) "\n")
548 (insert "Message-ID: <" id "@yahoo.com>\n"))
549 (unless (looking-at "$")
550 (search-forward "\n\n" nil t)
552 (narrow-to-region (point) (point-max))
553 (insert "MIME-Version: 1.0\n"
556 (delete-region (point-min) (point-max))))
557 (goto-char (point-min))
559 (let (case-fold-search)
560 (while (re-search-forward "^From " nil t)
563 (mm-append-to-file (point-min) (point-max) file)))
567 ;;; webmail.el ends here