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

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