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

   1 ;;; nnweb.el --- retrieving articles via web search engines
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Note: You need to have `w3' installed for some functions to work.
  29
  30 ;; FIXME: Due to changes in the HTML output of Gmane, stuff related to Gmane
  31 ;; web groups (`gnus-group-make-web-group') doesn't work anymore.
  32
  33 ;;; Code:
  34
  35 (eval-when-compile (require 'cl))
  36
  37 (require 'nnoo)
  38 (require 'message)
  39 (require 'gnus-util)
  40 (require 'gnus)
  41 (require 'nnmail)
  42 (require 'mm-util)
  43 (require 'mm-url)
  44 (eval-and-compile
  45   (ignore-errors
  46     (require 'url)))
  47 (autoload 'w3-parse-buffer "w3-parse")
  48
  49 (nnoo-declare nnweb)
  50
  51 (defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/")
  52   "Where nnweb will save its files.")
  53
  54 (defvoo nnweb-type 'google
  55   "What search engine type is being used.
  56 Valid types include `google', `dejanews', and `gmane'.")
  57
  58 (defvar nnweb-type-definition
  59   '((google
  60      (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
  61      (result . "http://groups.google.com/group/%s/msg/%s?dmode=source")
  62      (article . nnweb-google-wash-article)
  63      (reference . identity)
  64      (map . nnweb-google-create-mapping)
  65      (search . nnweb-google-search)
  66      (address . "http://groups.google.com/groups")
  67      (base    . "http://groups.google.com")
  68      (identifier . nnweb-google-identity))
  69     (dejanews ;; alias of google
  70      (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
  71      (result . "http://groups.google.com/group/%s/msg/%s?dmode=source")
  72      (article . nnweb-google-wash-article)
  73      (reference . identity)
  74      (map . nnweb-google-create-mapping)
  75      (search . nnweb-google-search)
  76      (address . "http://groups.google.com/groups")
  77      (base    . "http://groups.google.com")
  78      (identifier . nnweb-google-identity))
  79     (gmane
  80      (article . nnweb-gmane-wash-article)
  81      (id . "http://gmane.org/view.php?group=%s")
  82      (reference . identity)
  83      (map . nnweb-gmane-create-mapping)
  84      (search . nnweb-gmane-search)
  85      (address . "http://gmane.org/")
  86      (identifier . nnweb-gmane-identity)))
  87   "Type-definition alist.")
  88
  89 (defvoo nnweb-search nil
  90   "Search string to feed to Google.")
  91
  92 (defvoo nnweb-max-hits 999
  93   "Maximum number of hits to display.")
  94
  95 (defvoo nnweb-ephemeral-p nil
  96   "Whether this nnweb server is ephemeral.")
  97
  98 ;;; Internal variables
  99
 100 (defvoo nnweb-articles nil)
 101 (defvoo nnweb-buffer nil)
 102 (defvar nnweb-group-alist nil)
 103 (defvoo nnweb-group nil)
 104 (defvoo nnweb-hashtb nil)
 105
 106 ;;; Interface functions
 107
 108 (nnoo-define-basics nnweb)
 109
 110 (deffoo nnweb-retrieve-headers (articles &optional group server fetch-old)
 111   (nnweb-possibly-change-server group server)
 112   (save-excursion
 113     (set-buffer nntp-server-buffer)
 114     (erase-buffer)
 115     (let (article header)
 116       (mm-with-unibyte-current-buffer
 117         (while (setq article (pop articles))
 118           (when (setq header (cadr (assq article nnweb-articles)))
 119             (nnheader-insert-nov header))))
 120       'nov)))
 121
 122 (deffoo nnweb-request-scan (&optional group server)
 123   (nnweb-possibly-change-server group server)
 124   (if nnweb-ephemeral-p
 125       (setq nnweb-hashtb (gnus-make-hashtable 4095))
 126     (unless nnweb-articles
 127       (nnweb-read-overview group)))
 128   (funcall (nnweb-definition 'map))
 129   (unless nnweb-ephemeral-p
 130     (nnweb-write-active)
 131     (nnweb-write-overview group)))
 132
 133 (deffoo nnweb-request-group (group &optional server dont-check)
 134   (nnweb-possibly-change-server group server)
 135   (unless (or nnweb-ephemeral-p
 136               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 (list (assoc server 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)) 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   (when server
 284     (unless (nnweb-server-opened server)
 285       (nnweb-open-server server))
 286     (nnweb-init 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     (setq nnweb-group group)))
 293
 294 (defun nnweb-init (server)
 295   "Initialize buffers and such."
 296   (unless (gnus-buffer-live-p nnweb-buffer)
 297     (setq nnweb-buffer
 298           (save-excursion
 299             (mm-with-unibyte
 300               (nnheader-set-temp-buffer
 301                (format " *nnweb %s %s %s*"
 302                        nnweb-type nnweb-search server))
 303               (current-buffer))))))
 304
 305 ;;;
 306 ;;; groups.google.com
 307 ;;;
 308
 309 (defun nnweb-google-wash-article ()
 310   ;; We have Google's masked e-mail addresses here.  :-/
 311   (let ((case-fold-search t))
 312     (goto-char (point-min))
 313     (if (save-excursion
 314           (or (re-search-forward "The requested message.*could not be found."
 315                                  nil t)
 316               (not (and (re-search-forward "^<pre>" nil t)
 317                         (re-search-forward "^</pre>" nil t)))))
 318         ;; FIXME: Don't know how to indicate "not found".
 319         ;; Should this function throw an error?  --rsteib
 320         (progn
 321           (gnus-message 3 "Requested article not found")
 322           (erase-buffer))
 323       (delete-region (point-min)
 324                      (1+ (re-search-forward "^<pre>" nil t)))
 325       (goto-char (point-min))
 326       (delete-region (- (re-search-forward "^</pre>" nil t) (length "</pre>"))
 327                      (point-max))
 328       (mm-url-decode-entities))))
 329
 330 (defun nnweb-google-parse-1 (&optional Message-ID)
 331   "Parse search result in current buffer."
 332   (let ((i 0)
 333         (case-fold-search t)
 334         (active (cadr (assoc nnweb-group nnweb-group-alist)))
 335         Subject Score Date Newsgroups From
 336         map url mid)
 337     (unless active
 338       (push (list nnweb-group (setq active (cons 1 0)))
 339             nnweb-group-alist))
 340     ;; Go through all the article hits on this page.
 341     (goto-char (point-min))
 342     (while
 343         (re-search-forward
 344          "a +href=\"/group/\\([^>\"]+\\)/browse_thread/[^>]+#\\([0-9a-f]+\\)"
 345          nil t)
 346       (setq Newsgroups (match-string-no-properties 1)
 347             ;; Note: Starting with Google Groups 2, `mid' is a Google-internal
 348             ;; ID, not a proper Message-ID.
 349             mid (match-string-no-properties 2)
 350             url (format
 351                  (nnweb-definition 'result) Newsgroups mid))
 352       (narrow-to-region (search-forward ">" nil t)
 353                         (search-forward "</a>" nil t))
 354       (mm-url-remove-markup)
 355       (mm-url-decode-entities)
 356       (setq Subject (buffer-string))
 357       (goto-char (point-max))
 358       (widen)
 359       (narrow-to-region (point)
 360                         (search-forward "</td" nil t))
 361
 362       (mm-url-remove-markup)
 363       (mm-url-decode-entities)
 364       (search-backward " - ")
 365       (when (looking-at
 366              " - \\([a-zA-Z]+\\) \\([0-9]+\\)\\(?: \\([0-9]\\{4\\}\\)\\)?, [^\n]+by \\([^<\n]+\\)\n")
 367         (setq From (match-string 4)
 368               Date (format "%s %s 00:00:00 %s"
 369                            (match-string 1)
 370                            (match-string 2)
 371                            (or (match-string 3)
 372                                (substring (current-time-string) -4)))))
 373
 374       (widen)
 375       (forward-line 1)
 376       (incf i)
 377       (unless (nnweb-get-hashtb url)
 378         (push
 379          (list
 380           (incf (cdr active))
 381           (make-full-mail-header
 382            (cdr active) (if Newsgroups
 383                             (concat  "(" Newsgroups ") " Subject)
 384                           Subject)
 385            From Date (or Message-ID mid)
 386            nil 0 0 url))
 387          map)
 388         (nnweb-set-hashtb (cadar map) (car map))))
 389     map))
 390
 391 (defun nnweb-google-reference (id)
 392   (let ((map (nnweb-google-parse-1 id)) header)
 393     (setq nnweb-articles
 394           (nconc nnweb-articles map))
 395     (when (setq header (cadar map))
 396       (mm-with-unibyte-current-buffer
 397         (mm-url-insert (mail-header-xref header)))
 398       (caar map))))
 399
 400 (defun nnweb-google-create-mapping ()
 401   "Perform the search and create a number-to-url alist."
 402   (save-excursion
 403     (set-buffer nnweb-buffer)
 404     (erase-buffer)
 405     (when (funcall (nnweb-definition 'search) nnweb-search)
 406         (let ((more t)
 407               (i 0))
 408           (while more
 409             (setq nnweb-articles
 410                   (nconc nnweb-articles (nnweb-google-parse-1)))
 411             ;; Check if there are more articles to fetch
 412             (goto-char (point-min))
 413             (incf i 100)
 414             (if (or (not (re-search-forward
 415                           "<td><a href=\"\n\\([^>\"]+\\)\"><img src=\"/img/nav_next" nil t))
 416                     (>= i nnweb-max-hits))
 417                 (setq more nil)
 418               ;; Yup, there are more articles
 419               (setq more (concat (nnweb-definition 'base) (match-string 1)))
 420             (when more
 421               (erase-buffer)
 422               (mm-url-insert more))))
 423           ;; Return the articles in the right order.
 424           (setq nnweb-articles
 425                 (sort nnweb-articles 'car-less-than-car))))))
 426
 427 (defun nnweb-google-search (search)
 428   (mm-url-insert
 429    (concat
 430     (nnweb-definition 'address)
 431     "?"
 432     (mm-url-encode-www-form-urlencoded
 433      `(("q" . ,search)
 434        ("num" . "100")
 435        ("hq" . "")
 436        ("hl" . "en")
 437        ("lr" . "")
 438        ("safe" . "off")
 439        ("sites" . "groups")
 440        ("filter" . "0")))))
 441   t)
 442
 443 (defun nnweb-google-identity (url)
 444   "Return an unique identifier based on URL."
 445   (if (string-match "selm=\\([^ &>]+\\)" url)
 446       (match-string 1 url)
 447     url))
 448
 449 ;;;
 450 ;;; gmane.org
 451 ;;;
 452 (defun nnweb-gmane-create-mapping ()
 453   "Perform the search and create a number-to-url alist."
 454   (save-excursion
 455     (set-buffer nnweb-buffer)
 456     (erase-buffer)
 457     (when (funcall (nnweb-definition 'search) nnweb-search)
 458       (let ((more t)
 459             (case-fold-search t)
 460             (active (or (cadr (assoc nnweb-group nnweb-group-alist))
 461                         (cons 1 0)))
 462             subject group url
 463             map)
 464           ;; Remove stuff from the beginning of results
 465         (goto-char (point-min))
 466         (search-forward "Search Results</h1><ul>" nil t)
 467         (delete-region (point-min) (point))
 468         (goto-char (point-min))
 469         ;; Iterate over the actual hits
 470         (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\(.*\\)" nil t)
 471             (setq url (concat "http://gmane.org/" (match-string 1)))
 472             (setq subject (match-string 2))
 473           (unless (nnweb-get-hashtb url)
 474             (push
 475              (list
 476               (incf (cdr active))
 477               (make-full-mail-header
 478                (cdr active) (concat  "(" group ") " subject) nil nil
 479                nil nil 0 0 url))
 480              map)
 481             (nnweb-set-hashtb (cadar map) (car map))))
 482         ;; Return the articles in the right order.
 483         (setq nnweb-articles
 484               (sort (nconc nnweb-articles map) 'car-less-than-car))))))
 485
 486 (defun nnweb-gmane-wash-article ()
 487   (let ((case-fold-search t))
 488     (goto-char (point-min))
 489     (search-forward "<!--X-Head-of-Message-->" nil t)
 490     (delete-region (point-min) (point))
 491     (goto-char (point-min))
 492     (while (looking-at "^<li><em>\\([^ ]+\\)</em>.*</li>")
 493       (replace-match "\\1\\2" t)
 494       (forward-line 1))
 495     (mm-url-remove-markup)))
 496
 497 (defun nnweb-gmane-search (search)
 498   (mm-url-insert
 499    (concat
 500     (nnweb-definition 'address)
 501     "?"
 502     (mm-url-encode-www-form-urlencoded
 503      `(("query" . ,search)))))
 504   (setq buffer-file-name nil)
 505   t)
 506
 507
 508 (defun nnweb-gmane-identity (url)
 509   "Return a unique identifier based on URL."
 510   (if (string-match "group=\\(.+\\)" url)
 511       (match-string 1 url)
 512     url))
 513
 514 ;;;
 515 ;;; General web/w3 interface utility functions
 516 ;;;
 517
 518 (defun nnweb-insert-html (parse)
 519   "Insert HTML based on a w3 parse tree."
 520   (if (stringp parse)
 521       (insert (nnheader-string-as-multibyte parse))
 522     (insert "<" (symbol-name (car parse)) " ")
 523     (insert (mapconcat
 524              (lambda (param)
 525                (concat (symbol-name (car param)) "="
 526                        (prin1-to-string
 527                         (if (consp (cdr param))
 528                             (cadr param)
 529                           (cdr param)))))
 530              (nth 1 parse)
 531              " "))
 532     (insert ">\n")
 533     (mapc 'nnweb-insert-html (nth 2 parse))
 534     (insert "</" (symbol-name (car parse)) ">\n")))
 535
 536 (defun nnweb-parse-find (type parse &optional maxdepth)
 537   "Find the element of TYPE in PARSE."
 538   (catch 'found
 539     (nnweb-parse-find-1 type parse maxdepth)))
 540
 541 (defun nnweb-parse-find-1 (type contents maxdepth)
 542   (when (or (null maxdepth)
 543             (not (zerop maxdepth)))
 544     (when (consp contents)
 545       (when (eq (car contents) type)
 546         (throw 'found contents))
 547       (when (listp (cdr contents))
 548         (dolist (element contents)
 549           (when (consp element)
 550             (nnweb-parse-find-1 type element
 551                                 (and maxdepth (1- maxdepth)))))))))
 552
 553 (defun nnweb-parse-find-all (type parse)
 554   "Find all elements of TYPE in PARSE."
 555   (catch 'found
 556     (nnweb-parse-find-all-1 type parse)))
 557
 558 (defun nnweb-parse-find-all-1 (type contents)
 559   (let (result)
 560     (when (consp contents)
 561       (if (eq (car contents) type)
 562           (push contents result)
 563         (when (listp (cdr contents))
 564           (dolist (element contents)
 565             (when (consp element)
 566               (setq result
 567                     (nconc result (nnweb-parse-find-all-1 type element))))))))
 568     result))
 569
 570 (defvar nnweb-text)
 571 (defun nnweb-text (parse)
 572   "Return a list of text contents in PARSE."
 573   (let ((nnweb-text nil))
 574     (nnweb-text-1 parse)
 575     (nreverse nnweb-text)))
 576
 577 (defun nnweb-text-1 (contents)
 578   (dolist (element contents)
 579     (if (stringp element)
 580         (push element nnweb-text)
 581       (when (and (consp element)
 582                  (listp (cdr element)))
 583         (nnweb-text-1 element)))))
 584
 585 (provide 'nnweb)
 586
 587 ;;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697
 588 ;;; nnweb.el ends here