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