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