git.chise.org Git - elisp/gnus.git-/blob - lisp/nnweb.el

   1 ;;; nnweb.el --- retrieving articles via web search engines
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Note: You need to have `w3' installed for some functions to work.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32 (eval-when-compile (require 'gnus-clfns))
  33
  34 (require 'nnoo)
  35 (require 'message)
  36 (require 'gnus-util)
  37 (require 'gnus)
  38 (require 'nnmail)
  39 (require 'mm-util)
  40 (require 'mm-url)
  41 (eval-and-compile
  42   (ignore-errors
  43     (require 'url)))
  44 (autoload 'w3-parse-buffer "w3-parse")
  45
  46 (nnoo-declare nnweb)
  47
  48 (defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/")
  49   "Where nnweb will save its files.")
  50
  51 (defvoo nnweb-type 'google
  52   "What search engine type is being used.
  53 Valid types include `google', `dejanews', and `gmane'.")
  54
  55 (defvar nnweb-type-definition
  56   '((google
  57      (article . ignore)
  58      (id . "http://groups.google.com/groups?selm=%s&output=gplain")
  59      (reference . identity)
  60      (map . nnweb-google-create-mapping)
  61      (search . nnweb-google-search)
  62      (address . "http://groups.google.com/groups")
  63      (identifier . nnweb-google-identity))
  64     (dejanews ;; alias of google
  65      (article . ignore)
  66      (id . "http://groups.google.com/groups?selm=%s&output=gplain")
  67      (reference . identity)
  68      (map . nnweb-google-create-mapping)
  69      (search . nnweb-google-search)
  70      (address . "http://groups.google.com/groups")
  71      (identifier . nnweb-google-identity))
  72     (gmane
  73      (article . nnweb-gmane-wash-article)
  74      (id . "http://gmane.org/view.php?group=%s")
  75      (reference . identity)
  76      (map . nnweb-gmane-create-mapping)
  77      (search . nnweb-gmane-search)
  78      (address . "http://gmane.org/")
  79      (identifier . nnweb-gmane-identity)))
  80   "Type-definition alist.")
  81
  82 (defvoo nnweb-search nil
  83   "Search string to feed to Google.")
  84
  85 (defvoo nnweb-max-hits 999
  86   "Maximum number of hits to display.")
  87
  88 (defvoo nnweb-ephemeral-p nil
  89   "Whether this nnweb server is ephemeral.")
  90
  91 ;;; Internal variables
  92
  93 (defvoo nnweb-articles nil)
  94 (defvoo nnweb-buffer nil)
  95 (defvoo nnweb-group-alist nil)
  96 (defvoo nnweb-group nil)
  97 (defvoo nnweb-hashtb nil)
  98
  99 ;;; Interface functions
 100
 101 (nnoo-define-basics nnweb)
 102
 103 (deffoo nnweb-retrieve-headers (articles &optional group server fetch-old)
 104   (nnweb-possibly-change-server group server)
 105   (save-excursion
 106     (set-buffer nntp-server-buffer)
 107     (erase-buffer)
 108     (let (article header)
 109       (mm-with-unibyte-current-buffer
 110         (while (setq article (pop articles))
 111           (when (setq header (cadr (assq article nnweb-articles)))
 112             (nnheader-insert-nov header))))
 113       'nov)))
 114
 115 (deffoo nnweb-request-scan (&optional group server)
 116   (nnweb-possibly-change-server group server)
 117   (if nnweb-ephemeral-p
 118       (setq nnweb-hashtb (gnus-make-hashtable 4095)))
 119   (funcall (nnweb-definition 'map))
 120   (unless nnweb-ephemeral-p
 121     (nnweb-write-active)
 122     (nnweb-write-overview group)))
 123
 124 (deffoo nnweb-request-group (group &optional server dont-check)
 125   (nnweb-possibly-change-server nil server)
 126   (when (and group
 127              (not (equal group nnweb-group))
 128              (not nnweb-ephemeral-p))
 129     (setq nnweb-group group
 130           nnweb-articles nil)
 131     (let ((info (assoc group nnweb-group-alist)))
 132       (when info
 133         (setq nnweb-type (nth 2 info))
 134         (setq nnweb-search (nth 3 info))
 135         (unless dont-check
 136           (nnweb-read-overview group)))))
 137   (cond
 138    ((not nnweb-articles)
 139     (nnheader-report 'nnweb "No matching articles"))
 140    (t
 141     (let ((active (if nnweb-ephemeral-p
 142                       (cons (caar nnweb-articles)
 143                             (caar (last nnweb-articles)))
 144                     (cadr (assoc group nnweb-group-alist)))))
 145       (nnheader-report 'nnweb "Opened group %s" group)
 146       (nnheader-insert
 147        "211 %d %d %d %s\n" (length nnweb-articles)
 148        (car active) (cdr active) group)))))
 149
 150 (deffoo nnweb-close-group (group &optional server)
 151   (nnweb-possibly-change-server group server)
 152   (when (gnus-buffer-live-p nnweb-buffer)
 153     (save-excursion
 154       (set-buffer nnweb-buffer)
 155       (set-buffer-modified-p nil)
 156       (kill-buffer nnweb-buffer)))
 157   t)
 158
 159 (deffoo nnweb-request-article (article &optional group server buffer)
 160   (nnweb-possibly-change-server group server)
 161   (save-excursion
 162     (set-buffer (or buffer nntp-server-buffer))
 163     (let* ((header (cadr (assq article nnweb-articles)))
 164            (url (and header (mail-header-xref header))))
 165       (when (or (and url
 166                      (mm-with-unibyte-current-buffer
 167                        (mm-url-insert url)))
 168                 (and (stringp article)
 169                      (nnweb-definition 'id t)
 170                      (let ((fetch (nnweb-definition 'id))
 171                            art active)
 172                        (when (string-match "^<\\(.*\\)>$" article)
 173                          (setq art (match-string 1 article)))
 174                        (when (and fetch art)
 175                          (setq url (format fetch art))
 176                          (mm-with-unibyte-current-buffer
 177                            (mm-url-insert url))
 178                          (if (nnweb-definition 'reference t)
 179                              (setq article
 180                                    (funcall (nnweb-definition
 181                                              'reference) article)))))))
 182         (unless nnheader-callback-function
 183           (funcall (nnweb-definition 'article)))
 184         (nnheader-report 'nnweb "Fetched article %s" article)
 185         (cons group (and (numberp article) article))))))
 186
 187 (deffoo nnweb-close-server (&optional server)
 188   (when (and (nnweb-server-opened server)
 189              (gnus-buffer-live-p nnweb-buffer))
 190     (save-excursion
 191       (set-buffer nnweb-buffer)
 192       (set-buffer-modified-p nil)
 193       (kill-buffer nnweb-buffer)))
 194   (nnoo-close-server 'nnweb server))
 195
 196 (deffoo nnweb-request-list (&optional server)
 197   (nnweb-possibly-change-server nil server)
 198   (save-excursion
 199     (set-buffer nntp-server-buffer)
 200     (nnmail-generate-active nnweb-group-alist)
 201     t))
 202
 203 (deffoo nnweb-request-update-info (group info &optional server)
 204   (nnweb-possibly-change-server group server))
 205
 206 (deffoo nnweb-asynchronous-p ()
 207   nil)
 208
 209 (deffoo nnweb-request-create-group (group &optional server args)
 210   (nnweb-possibly-change-server nil server)
 211   (nnweb-request-delete-group group)
 212   (push `(,group ,(cons 1 0) ,@args) nnweb-group-alist)
 213   (nnweb-write-active)
 214   t)
 215
 216 (deffoo nnweb-request-delete-group (group &optional force server)
 217   (nnweb-possibly-change-server group server)
 218   (gnus-pull group nnweb-group-alist t)
 219   (nnweb-write-active)
 220   (gnus-delete-file (nnweb-overview-file group))
 221   t)
 222
 223 (nnoo-define-skeleton nnweb)
 224
 225 ;;; Internal functions
 226
 227 (defun nnweb-read-overview (group)
 228   "Read the overview of GROUP and build the map."
 229   (when (file-exists-p (nnweb-overview-file group))
 230     (mm-with-unibyte-buffer
 231       (nnheader-insert-file-contents (nnweb-overview-file group))
 232       (goto-char (point-min))
 233       (let (header)
 234         (while (not (eobp))
 235           (setq header (nnheader-parse-nov))
 236           (forward-line 1)
 237           (push (list (mail-header-number header)
 238                       header (mail-header-xref header))
 239                 nnweb-articles)
 240           (nnweb-set-hashtb header (car nnweb-articles)))))))
 241
 242 (defun nnweb-write-overview (group)
 243   "Write the overview file for GROUP."
 244   (with-temp-file (nnweb-overview-file group)
 245     (let ((articles nnweb-articles))
 246       (while articles
 247         (nnheader-insert-nov (cadr (pop articles)))))))
 248
 249 (defun nnweb-set-hashtb (header data)
 250   (gnus-sethash (nnweb-identifier (mail-header-xref header))
 251                 data nnweb-hashtb))
 252
 253 (defun nnweb-get-hashtb (url)
 254   (gnus-gethash (nnweb-identifier url) nnweb-hashtb))
 255
 256 (defun nnweb-identifier (ident)
 257   (funcall (nnweb-definition 'identifier) ident))
 258
 259 (defun nnweb-overview-file (group)
 260   "Return the name of the overview file of GROUP."
 261   (nnheader-concat nnweb-directory group ".overview"))
 262
 263 (defun nnweb-write-active ()
 264   "Save the active file."
 265   (gnus-make-directory nnweb-directory)
 266   (with-temp-file (nnheader-concat nnweb-directory "active")
 267     (prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer))))
 268
 269 (defun nnweb-read-active ()
 270   "Read the active file."
 271   (load (nnheader-concat nnweb-directory "active") t t t))
 272
 273 (defun nnweb-definition (type &optional noerror)
 274   "Return the definition of TYPE."
 275   (let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition)))))
 276     (when (and (not def)
 277                (not noerror))
 278       (error "Undefined definition %s" type))
 279     def))
 280
 281 (defun nnweb-possibly-change-server (&optional group server)
 282   (nnweb-init server)
 283   (when server
 284     (unless (nnweb-server-opened server)
 285       (nnweb-open-server server)))
 286   (unless nnweb-group-alist
 287     (nnweb-read-active))
 288   (unless nnweb-hashtb
 289     (setq nnweb-hashtb (gnus-make-hashtable 4095)))
 290   (when group
 291     (when (and (not nnweb-ephemeral-p)
 292                (equal group nnweb-group))
 293       (nnweb-request-group group nil t))))
 294
 295 (defun nnweb-init (server)
 296   "Initialize buffers and such."
 297   (unless (gnus-buffer-live-p nnweb-buffer)
 298     (setq nnweb-buffer
 299           (save-excursion
 300             (mm-with-unibyte
 301               (nnheader-set-temp-buffer
 302                (format " *nnweb %s %s %s*"
 303                        nnweb-type nnweb-search server))
 304               (current-buffer))))))
 305
 306 ;;;
 307 ;;; Deja bought by google.com
 308 ;;;
 309
 310 (defun nnweb-google-wash-article ()
 311   (let ((case-fold-search t) url)
 312     (goto-char (point-min))
 313     (re-search-forward "^<pre>" nil t)
 314     (narrow-to-region (point-min) (point))
 315     (search-backward "<table " nil t 2)
 316     (delete-region (point-min) (point))
 317     (if (re-search-forward "Search Result [0-9]+" nil t)
 318         (replace-match ""))
 319     (if (re-search-forward "View complete thread ([0-9]+ articles?)" nil t)
 320         (replace-match ""))
 321     (goto-char (point-min))
 322     (while (search-forward "<br>" nil t)
 323       (replace-match "\n"))
 324     (mm-url-remove-markup)
 325     (goto-char (point-min))
 326     (while (re-search-forward "^[ \t]*\n" nil t)
 327       (replace-match ""))
 328     (goto-char (point-max))
 329     (insert "\n")
 330     (widen)
 331     (narrow-to-region (point) (point-max))
 332     (search-forward "</pre>" nil t)
 333     (delete-region (point) (point-max))
 334     (mm-url-remove-markup)
 335     (widen)))
 336
 337 (defun nnweb-google-parse-1 (&optional Message-ID)
 338   (let ((i 0)
 339         (case-fold-search t)
 340         (active (cadr (assoc nnweb-group nnweb-group-alist)))
 341         Subject Score Date Newsgroups From
 342         map url mid)
 343     (unless active
 344       (push (list nnweb-group (setq active (cons 1 0))
 345                   nnweb-type nnweb-search)
 346             nnweb-group-alist))
 347     ;; Go through all the article hits on this page.
 348     (goto-char (point-min))
 349     (while (re-search-forward
 350             "a href=/groups\\(\\?[^ \">]*selm=\\([^ &\">]+\\)\\)" nil t)
 351       (setq mid (match-string 2)
 352             url (format
 353                  "http://groups.google.com/groups?selm=%s&output=gplain" mid))
 354       (narrow-to-region (search-forward ">" nil t)
 355                         (search-forward "</a>" nil t))
 356       (mm-url-remove-markup)
 357       (mm-url-decode-entities)
 358       (setq Subject (buffer-string))
 359       (goto-char (point-max))
 360       (widen)
 361       (forward-line 1)
 362       (when (looking-at "<br><font[^>]+>")
 363         (goto-char (match-end 0)))
 364       (if (not (looking-at "<a[^>]+>"))
 365           (skip-chars-forward " \t")
 366         (narrow-to-region (point)
 367                           (search-forward "</a>" nil t))
 368         (mm-url-remove-markup)
 369         (mm-url-decode-entities)
 370         (setq Newsgroups (buffer-string))
 371         (goto-char (point-max))
 372         (widen)
 373         (skip-chars-forward "- \t"))
 374       (when (looking-at
 375              "\\([0-9]+\\)[/ ]\\([A-Za-z]+\\)[/ ]\\([0-9]+\\)[ \t]*by[ \t]*\\([^<]*\\) - <a")
 376         (setq From (match-string 4)
 377               Date (format "%s %s 00:00:00 %s"
 378                            (match-string 2) (match-string 1)
 379                            (match-string 3))))
 380       (forward-line 1)
 381       (incf i)
 382       (unless (nnweb-get-hashtb url)
 383         (push
 384          (list
 385           (incf (cdr active))
 386           (make-full-mail-header
 387            (cdr active) (if Newsgroups
 388                             (concat  "(" Newsgroups ") " Subject)
 389                           Subject)
 390            From Date (or Message-ID mid)
 391            nil 0 0 url))
 392          map)
 393         (nnweb-set-hashtb (cadar map) (car map))))
 394     map))
 395
 396 (defun nnweb-google-reference (id)
 397   (let ((map (nnweb-google-parse-1 id)) header)
 398     (setq nnweb-articles
 399           (nconc nnweb-articles map))
 400     (when (setq header (cadar map))
 401       (mm-with-unibyte-current-buffer
 402         (mm-url-insert (mail-header-xref header)))
 403       (caar map))))
 404
 405 (defun nnweb-google-create-mapping ()
 406   "Perform the search and create a number-to-url alist."
 407   (save-excursion
 408     (set-buffer nnweb-buffer)
 409     (erase-buffer)
 410     (when (funcall (nnweb-definition 'search) nnweb-search)
 411       (let ((more t)
 412             (i 0))
 413         (while more
 414           (setq nnweb-articles
 415                 (nconc nnweb-articles (nnweb-google-parse-1)))
 416           ;; Check if there are more articles to fetch
 417           (goto-char (point-min))
 418           (incf i 100)
 419           (if (or (not (re-search-forward
 420                         "<td nowrap><a href=\\([^>]+\\).*<span class=b>Next</span>" nil t))
 421                   (>= i nnweb-max-hits))
 422               (setq more nil)
 423             ;; Yup, there are more articles
 424             (setq more (concat "http://groups.google.com" (match-string 1)))
 425             (when more
 426               (erase-buffer)
 427               (mm-url-insert more))))
 428         ;; Return the articles in the right order.
 429         (setq nnweb-articles
 430               (sort nnweb-articles 'car-less-than-car))))))
 431
 432 (defun nnweb-google-search (search)
 433   (mm-url-insert
 434    (concat
 435     (nnweb-definition 'address)
 436     "?"
 437     (mm-url-encode-www-form-urlencoded
 438      `(("q" . ,search)
 439        ("num". "100")
 440        ("hq" . "")
 441        ("hl" . "")
 442        ("lr" . "")
 443        ("safe" . "off")
 444        ("sites" . "groups")))))
 445   t)
 446
 447 (defun nnweb-google-identity (url)
 448   "Return an unique identifier based on URL."
 449   (if (string-match "selm=\\([^ &>]+\\)" url)
 450       (match-string 1 url)
 451     url))
 452
 453 ;;;
 454 ;;; gmane.org
 455 ;;;
 456 (defun nnweb-gmane-create-mapping ()
 457   "Perform the search and create a number-to-url alist."
 458   (save-excursion
 459     (set-buffer nnweb-buffer)
 460     (erase-buffer)
 461     (when (funcall (nnweb-definition 'search) nnweb-search)
 462       (let ((more t)
 463             (case-fold-search t)
 464             (active (or (cadr (assoc nnweb-group nnweb-group-alist))
 465                         (cons 1 0)))
 466             subject group url
 467             map)
 468           ;; Remove stuff from the beginning of results
 469         (goto-char (point-min))
 470         (search-forward "Search Results</h1><ul>" nil t)
 471         (delete-region (point-min) (point))
 472         (goto-char (point-min))
 473         ;; Iterate over the actual hits
 474         (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\(.*\\)" nil t)
 475             (setq url (concat "http://gmane.org/" (match-string 1)))
 476             (setq subject (match-string 2))
 477           (unless (nnweb-get-hashtb url)
 478             (push
 479              (list
 480               (incf (cdr active))
 481               (make-full-mail-header
 482                (cdr active) (concat  "(" group ") " subject) nil nil
 483                nil nil 0 0 url))
 484              map)
 485             (nnweb-set-hashtb (cadar map) (car map))))
 486         ;; Return the articles in the right order.
 487         (setq nnweb-articles
 488               (sort (nconc nnweb-articles map) 'car-less-than-car))))))
 489
 490 (defun nnweb-gmane-wash-article ()
 491   (let ((case-fold-search t))
 492     (goto-char (point-min))
 493     (re-search-forward "<!--X-Head-of-Message-->" nil t)
 494     (delete-region (point-min) (point))
 495     (goto-char (point-min))
 496     (while (looking-at "^<li><em>\\([^ ]+\\)</em>.*</li>")
 497       (replace-match "\\1\\2" t)
 498       (forward-line 1))
 499     (mm-url-remove-markup)))
 500
 501 (defun nnweb-gmane-search (search)
 502   (mm-url-insert
 503    (concat
 504     (nnweb-definition 'address)
 505     "?"
 506     (mm-url-encode-www-form-urlencoded
 507      `(("query" . ,search)))))
 508   (setq buffer-file-name nil)
 509   t)
 510
 511
 512 (defun nnweb-gmane-identity (url)
 513   "Return a unique identifier based on URL."
 514   (if (string-match "group=\\(.+\\)" url)
 515       (match-string 1 url)
 516     url))
 517
 518 ;;;
 519 ;;; General web/w3 interface utility functions
 520 ;;;
 521
 522 (defun nnweb-insert-html (parse)
 523   "Insert HTML based on a w3 parse tree."
 524   (if (stringp parse)
 525       (insert (nnheader-string-as-multibyte parse))
 526     (insert "<" (symbol-name (car parse)) " ")
 527     (insert (mapconcat
 528              (lambda (param)
 529                (concat (symbol-name (car param)) "="
 530                        (prin1-to-string
 531                         (if (consp (cdr param))
 532                             (cadr param)
 533                           (cdr param)))))
 534              (nth 1 parse)
 535              " "))
 536     (insert ">\n")
 537     (mapcar 'nnweb-insert-html (nth 2 parse))
 538     (insert "</" (symbol-name (car parse)) ">\n")))
 539
 540 (defun nnweb-parse-find (type parse &optional maxdepth)
 541   "Find the element of TYPE in PARSE."
 542   (catch 'found
 543     (nnweb-parse-find-1 type parse maxdepth)))
 544
 545 (defun nnweb-parse-find-1 (type contents maxdepth)
 546   (when (or (null maxdepth)
 547             (not (zerop maxdepth)))
 548     (when (consp contents)
 549       (when (eq (car contents) type)
 550         (throw 'found contents))
 551       (when (listp (cdr contents))
 552         (dolist (element contents)
 553           (when (consp element)
 554             (nnweb-parse-find-1 type element
 555                                 (and maxdepth (1- maxdepth)))))))))
 556
 557 (defun nnweb-parse-find-all (type parse)
 558   "Find all elements of TYPE in PARSE."
 559   (catch 'found
 560     (nnweb-parse-find-all-1 type parse)))
 561
 562 (defun nnweb-parse-find-all-1 (type contents)
 563   (let (result)
 564     (when (consp contents)
 565       (if (eq (car contents) type)
 566           (push contents result)
 567         (when (listp (cdr contents))
 568           (dolist (element contents)
 569             (when (consp element)
 570               (setq result
 571                     (nconc result (nnweb-parse-find-all-1 type element))))))))
 572     result))
 573
 574 (defvar nnweb-text)
 575 (defun nnweb-text (parse)
 576   "Return a list of text contents in PARSE."
 577   (let ((nnweb-text nil))
 578     (nnweb-text-1 parse)
 579     (nreverse nnweb-text)))
 580
 581 (defun nnweb-text-1 (contents)
 582   (dolist (element contents)
 583     (if (stringp element)
 584         (push element nnweb-text)
 585       (when (and (consp element)
 586                  (listp (cdr element)))
 587         (nnweb-text-1 element)))))
 588
 589 (provide 'nnweb)
 590
 591 ;;; nnweb.el ends here