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

   1 ;;; nnwarchive.el --- interfacing with web archives
   2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: news
   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: You need to have `url' and `w3' installed for this backend to
  27 ;; work.
  28
  29 ;; A lot of codes stolen from mail-source, nnslashdot, nnweb.
  30
  31 ;; Todo: To support more web archives.
  32
  33 ;; Known bugs: in w3 0.44, there are two copies of url-maybe-relative.
  34 ;; If it is loaded from w3.el, (load-library "url").  w3 0.45 should
  35 ;; work.
  36
  37 ;;; Code:
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (require 'nnoo)
  42 (require 'message)
  43 (require 'gnus-util)
  44 (require 'gnus)
  45 (require 'nnmail)
  46 (require 'mm-util)
  47 (require 'mail-source)
  48 (eval-when-compile
  49   (ignore-errors
  50     (require 'w3)
  51     (require 'url)
  52     (require 'w3-forms)))
  53 ;; Report failure to find w3 at load time if appropriate.
  54 (eval '(progn
  55          (require 'w3)
  56          (require 'url)
  57          (require 'w3-forms)))
  58
  59 (nnoo-declare nnwarchive)
  60
  61 (eval-and-compile
  62   (defvar nnwarchive-type-definition
  63     '((egroups
  64        (open-url
  65         "http://www.egroups.com/register?method=loginAction&email=%s&password=%s"
  66         login passwd)
  67        (open-dissect . nnwarchive-egroups-open)
  68        (list-url
  69         "http://www.egroups.com/UserGroupsPage?")
  70        (list-dissect . nnwarchive-egroups-list)
  71        (xover-url
  72         "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group start)
  73        (xover-last-url
  74         "http://www.egroups.com/group/%s/?fetchForward=1" group)
  75        (xover-page-size . 13)
  76        (xover-dissect . nnwarchive-egroups-xover)
  77        (article-url
  78         "http://www.egroups.com/group/%s/%d.html?raw=1" group article)
  79        (article-dissect . nnwarchive-egroups-article)))))
  80
  81 (eval-and-compile
  82   (defvar nnwarchive-short-names
  83     '(login passwd)))
  84
  85 (defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/")
  86   "Where nnwarchive will save its files.")
  87
  88 (eval-and-compile
  89   (defvoo nnwarchive-type 'egroups
  90     "The type of nnwarchive."))
  91
  92 (defvoo nnwarchive-address "egroups.com"
  93   "The address of nnwarchive.")
  94
  95 (defvoo nnwarchive-login nil
  96   "Your login name for the group.")
  97
  98 (defvoo nnwarchive-passwd nil
  99   "Your password for the group.")
 100
 101 (defvoo nnwarchive-groups nil)
 102
 103 (defvoo nnwarchive-headers-cache nil)
 104
 105 (defvoo nnwarchive-opened nil)
 106
 107 (defconst nnwarchive-version "nnwarchive 1.0")
 108
 109 ;;; Internal variables
 110
 111 (defvar nnwarchive-open-url nil)
 112 (defvar nnwarchive-open-dissect nil)
 113
 114 (defvar nnwarchive-list-url nil)
 115 (defvar nnwarchive-list-dissect nil)
 116
 117 (defvar nnwarchive-xover-url nil)
 118 (defvar nnwarchive-xover-last-url nil)
 119 (defvar nnwarchive-xover-dissect nil)
 120 (defvar nnwarchive-xover-page-size nil)
 121
 122 (defvar nnwarchive-article-url nil)
 123 (defvar nnwarchive-article-dissect nil)
 124
 125 (defvar nnwarchive-buffer nil)
 126
 127 (defvar nnwarchive-headers nil)
 128
 129 ;;; Interface functions
 130
 131 (nnoo-define-basics nnwarchive)
 132
 133 (eval-and-compile
 134   (defun nnwarchive-bind-1 ()
 135     (let ((defaults (cdr (assq nnwarchive-type nnwarchive-type-definition)))
 136           (short-names nnwarchive-short-names)
 137           default bind)
 138       (while (setq default (pop defaults))
 139         (push (list (intern (concat "nnwarchive-" (symbol-name (car default))))
 140                     (list 'quote (cdr default))) bind))
 141       (while (setq default (pop short-names))
 142         (push (list default
 143                     (intern (concat "nnwarchive-"
 144                                     (symbol-name default))))
 145               bind))
 146       bind)))
 147
 148 (defmacro nnwarchive-bind (&rest body)
 149   "Return a `let' form that binds all variables in TYPE.
 150 Read `mail-source-bind' for details."
 151   `(let ,(nnwarchive-bind-1)
 152      ,@body))
 153
 154 (put 'nnwarchive-bind 'lisp-indent-function 0)
 155 (put 'nnwarchive-bind 'edebug-form-spec '(form body))
 156
 157 (deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old)
 158   (nnwarchive-possibly-change-server group server)
 159   (nnwarchive-bind
 160     (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 161     (save-excursion
 162       (set-buffer nnwarchive-buffer)
 163       (erase-buffer)
 164       (let (point start starts)
 165         (setq starts (nnwarchive-paged (sort articles '<)))
 166         (while (setq start (pop starts))
 167           (goto-char (point-max))
 168           (nnwarchive-url nnwarchive-xover-url))
 169         (if nnwarchive-xover-dissect
 170             (funcall nnwarchive-xover-dissect))))
 171     (save-excursion
 172       (set-buffer nntp-server-buffer)
 173       (erase-buffer)
 174       (let (header)
 175         (dolist (art articles)
 176           (if (setq header (assq art nnwarchive-headers))
 177               (nnheader-insert-nov (cdr header))))))
 178     (let ((elem (assoc group nnwarchive-headers-cache)))
 179       (if elem
 180           (setcdr elem nnwarchive-headers)
 181         (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))
 182     'nov))
 183
 184 (deffoo nnwarchive-request-group (group &optional server dont-check)
 185   (nnwarchive-possibly-change-server nil server)
 186   (let ((elem (assoc group nnwarchive-groups)))
 187     (cond
 188      ((not elem)
 189       (nnheader-report 'nnwarchive "Group does not exist"))
 190      (t
 191       (nnheader-report 'nnwarchive "Opened group %s" group)
 192       (nnheader-insert
 193        "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
 194        (prin1-to-string group))))))
 195
 196 (deffoo nnwarchive-close-group (group &optional server)
 197   (nnwarchive-possibly-change-server group server)
 198   (when (gnus-buffer-live-p nnwarchive-buffer)
 199     (save-excursion
 200       (set-buffer nnwarchive-buffer)
 201       (kill-buffer nnwarchive-buffer)))
 202   t)
 203
 204 (deffoo nnwarchive-request-article (article &optional group server buffer)
 205   (nnwarchive-possibly-change-server group server)
 206   (nnwarchive-bind
 207     (let (contents)
 208       (save-excursion
 209         (set-buffer nnwarchive-buffer)
 210         (goto-char (point-min))
 211         (nnwarchive-url nnwarchive-article-url)
 212         (setq contents (funcall nnwarchive-article-dissect)))
 213       (when contents
 214         (save-excursion
 215           (set-buffer (or buffer nntp-server-buffer))
 216           (erase-buffer)
 217           (insert contents)
 218           (nnheader-report 'nnwarchive "Fetched article %s" article)
 219           (cons group article))))))
 220
 221 (deffoo nnwarchive-close-server (&optional server)
 222   (when (and (nnwarchive-server-opened server)
 223              (gnus-buffer-live-p nnwarchive-buffer))
 224     (save-excursion
 225       (set-buffer nnwarchive-buffer)
 226       (kill-buffer nnwarchive-buffer)))
 227   (nnoo-close-server 'nnwarchive server))
 228
 229 (deffoo nnwarchive-request-list (&optional server)
 230   (nnwarchive-possibly-change-server nil server)
 231   (nnwarchive-bind
 232     (save-excursion
 233       (set-buffer nnwarchive-buffer)
 234       (erase-buffer)
 235       (if nnwarchive-list-url
 236           (nnwarchive-url nnwarchive-list-url))
 237       (if nnwarchive-list-dissect
 238           (funcall nnwarchive-list-dissect))
 239       (nnwarchive-write-groups)
 240       (nnwarchive-generate-active)))
 241   t)
 242
 243 (deffoo nnwarchive-request-newgroups (date &optional server)
 244   (nnwarchive-possibly-change-server nil server)
 245   (nnwarchive-bind
 246     (nnwarchive-generate-active))
 247   t)
 248
 249 (deffoo nnwarchive-asynchronous-p ()
 250   nil)
 251
 252 (deffoo nnwarchive-server-opened (&optional server)
 253   nnwarchive-opened)
 254
 255 (deffoo nnwarchive-open-server (server &optional defs connectionless)
 256   (nnwarchive-init server)
 257   (setq nnwarchive-login
 258         (or nnwarchive-login
 259             (read-string
 260              (format "Login at %s: " server)
 261              user-mail-address)))
 262   (setq nnwarchive-passwd
 263         (or nnwarchive-passwd
 264             (mail-source-read-passwd
 265              (format "Password for %s at %s: " nnwarchive-login server))))
 266   (nnwarchive-bind
 267     (save-excursion
 268       (set-buffer nnwarchive-buffer)
 269       (erase-buffer)
 270       (if nnwarchive-open-url
 271           (nnwarchive-url nnwarchive-open-url))
 272       (if nnwarchive-open-dissect
 273           (funcall nnwarchive-open-dissect)
 274         (setq nnwarchive-opened t))))
 275   t)
 276
 277 (nnoo-define-skeleton nnwarchive)
 278
 279 ;;; Internal functions
 280
 281 (defun nnwarchive-possibly-change-server (&optional group server)
 282   (nnwarchive-init server)
 283   (when (and server
 284              (not (nnwarchive-server-opened server)))
 285     (nnwarchive-open-server server)))
 286
 287 (defun nnwarchive-read-groups ()
 288   (let ((file (expand-file-name (concat "groups-" nnwarchive-address)
 289                                 nnwarchive-directory)))
 290     (when (file-exists-p file)
 291       (with-temp-buffer
 292         (insert-file-contents file)
 293         (goto-char (point-min))
 294         (setq nnwarchive-groups (read (current-buffer)))))))
 295
 296 (defun nnwarchive-write-groups ()
 297   (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address)
 298                                     nnwarchive-directory)
 299     (prin1 nnwarchive-groups (current-buffer))))
 300
 301 (defun nnwarchive-init (server)
 302   "Initialize buffers and such."
 303   (unless (file-exists-p nnwarchive-directory)
 304     (gnus-make-directory nnwarchive-directory))
 305   (unless (gnus-buffer-live-p nnwarchive-buffer)
 306     (setq nnwarchive-buffer
 307           (save-excursion
 308             (nnheader-set-temp-buffer
 309              (format " *nnwarchive %s %s*" nnwarchive-type server))))))
 310
 311 (defun nnwarchive-encode-www-form-urlencoded (pairs)
 312   "Return PAIRS encoded for forms."
 313   (mapconcat
 314    (function
 315     (lambda (data)
 316       (concat (w3-form-encode-xwfu (car data)) "="
 317               (w3-form-encode-xwfu (cdr data)))))
 318    pairs "&"))
 319
 320 (defun nnwarchive-fetch-form (url pairs)
 321   (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs))
 322         (url-request-method "POST")
 323         (url-request-extra-headers
 324          '(("Content-type" . "application/x-www-form-urlencoded"))))
 325     (url-insert-file-contents url)
 326     (setq buffer-file-name t))
 327   t)
 328
 329 (defun nnwarchive-eval (expr)
 330   (cond
 331    ((consp expr)
 332     (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
 333    ((symbolp expr)
 334     (eval expr))
 335    (t
 336     expr)))
 337
 338 (defun nnwarchive-url (xurl)
 339   (let ((url-confirmation-func 'identity))
 340     (cond
 341      ((eq (car xurl) 'post)
 342       (pop xurl)
 343       (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
 344      (t
 345       (url-insert-file-contents (apply 'format (nnwarchive-eval xurl)))
 346       (setq buffer-file-name nil)))))
 347
 348 (defun nnwarchive-decode-entities ()
 349   (goto-char (point-min))
 350   (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
 351     (replace-match (char-to-string
 352                     (if (eq (aref (match-string 1) 0) ?\#)
 353                         (string-to-number (substring (match-string 1) 1))
 354                       (or (cdr (assq (intern (match-string 1))
 355                                      w3-html-entities))
 356                           ?#)))
 357                    t t)))
 358
 359 (defun nnwarchive-decode-entities-string (str)
 360   (with-temp-buffer
 361     (insert str)
 362     (nnwarchive-decode-entities)
 363     (buffer-substring (point-min) (point-max))))
 364
 365 (defun nnwarchive-remove-markup ()
 366   (goto-char (point-min))
 367   (while (search-forward "<!--" nil t)
 368     (delete-region (match-beginning 0)
 369                    (or (search-forward "-->" nil t)
 370                        (point-max))))
 371   (goto-char (point-min))
 372   (while (re-search-forward "<[^>]+>" nil t)
 373     (replace-match "" t t)))
 374
 375 (defun nnwarchive-date-to-date (sdate)
 376   (let ((elem (split-string sdate)))
 377     (concat (substring (nth 0 elem) 0 3) " "
 378             (substring (nth 1 elem) 0 3) " "
 379             (substring (nth 2 elem) 0 2) " "
 380             (substring (nth 3 elem) 1 6) " "
 381             (format-time-string "%Y") " "
 382             (nth 4 elem))))
 383
 384 (defun nnwarchive-generate-active ()
 385   (save-excursion
 386     (set-buffer nntp-server-buffer)
 387     (erase-buffer)
 388     (dolist (elem nnwarchive-groups)
 389       (insert (prin1-to-string (car elem))
 390               " " (number-to-string (cadr elem)) " 1 y\n"))))
 391
 392 (defun nnwarchive-paged (articles)
 393   (let (art narts next)
 394     (while (setq art (pop articles))
 395       (when (and (>= art (or next 0))
 396                  (not (assq art nnwarchive-headers)))
 397         (push art narts)
 398         (setq next (+ art nnwarchive-xover-page-size))))
 399     narts))
 400
 401 ;; egroups
 402
 403 (defun nnwarchive-egroups-open ()
 404   (setq nnwarchive-opened t))
 405
 406 (defun nnwarchive-egroups-list ()
 407   (let ((case-fold-search t)
 408         group description elem articles)
 409     (goto-char (point-min))
 410     (while
 411         (re-search-forward
 412          "/group/\\([^/]+\\)/info\\.html[^>]+>[^>]+>[\040\t]*-[\040\t]*\\([^<]+\\)<"
 413          nil t)
 414       (setq group (match-string 1)
 415             description (match-string 2))
 416       (forward-line 1)
 417       (when (re-search-forward ">\\([0-9]+\\)<" nil t)
 418         (setq articles (string-to-number (match-string 1))))
 419       (if (setq elem (assoc group nnwarchive-groups))
 420           (setcar (cdr elem) articles)
 421         (push (list group articles description) nnwarchive-groups)))
 422     (dolist (elem nnwarchive-groups)
 423       (setq group (car elem))
 424       (erase-buffer)
 425       (nnwarchive-url nnwarchive-xover-last-url)
 426       (goto-char (point-min))
 427       (when (re-search-forward "of \\([0-9]+\\)</title>" nil t)
 428         (setq articles (string-to-number (match-string 1))))
 429       (setcar (cdr elem) articles)
 430       (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
 431       (nnwarchive-egroups-xover)
 432       (let ((elem (assoc group nnwarchive-headers-cache)))
 433         (if elem
 434             (setcdr elem nnwarchive-headers)
 435           (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))))
 436   t)
 437
 438 (defun nnwarchive-egroups-xover()
 439   (let (article subject from date group)
 440     (goto-char (point-min))
 441     (while (re-search-forward
 442             "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
 443             nil t)
 444           (setq group  (match-string 1)
 445                 article (string-to-number (match-string 2))
 446                 subject (match-string 3))
 447           (forward-line 1)
 448           (unless (assq article nnwarchive-headers)
 449             (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 450                 (setq from (match-string 1)))
 451             (forward-line 1)
 452             (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
 453                 (setq date (identity (match-string 1))))
 454             (push (cons
 455                    article
 456                    (make-full-mail-header
 457                     article
 458                     (nnwarchive-decode-entities-string subject)
 459                     (nnwarchive-decode-entities-string from)
 460                     date
 461                     (concat "<" group "%"
 462                             (number-to-string article)
 463                             "@egroup.com>")
 464                     ""
 465                     0 nil nil nil)) nnwarchive-headers))))
 466   nnwarchive-headers)
 467
 468 (defun nnwarchive-egroups-article ()
 469   (goto-char (point-min))
 470   (if (search-forward "<pre>" nil t)
 471       (delete-region (point-min) (point)))
 472   (goto-char (point-max))
 473   (if (search-backward "</pre>" nil t)
 474       (delete-region (point) (point-max)))
 475   (goto-char (point-min))
 476   (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
 477     (replace-match "<\\1>"))
 478   (nnwarchive-decode-entities)
 479   (buffer-substring (point-min) (point-max)))
 480
 481 (provide 'nnwarchive)
 482
 483 ;;; nnwarchive.el ends here