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
  31 ;; Gmane web groups doesn't work anymore.
  32
  33 ;; FIXME: Solid web groups are currently broken because ARGS are no
  34 ;; longer passed to nnweb-request-create-group from
  35 ;; gnus-group-make-web-group
  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 (re-search-forward
 356             "a +href=\"/group/\\([^>\"]+\\)/browse_thread/[^>]+#\\([0-9a-f]+\\)" nil t)
 357       (setq Newsgroups (match-string-no-properties 1)
 358             ;; Note: with groups-ng, mid is no longer a common
 359             ;; Message-ID, but some internal id.
 360             mid (match-string-no-properties 2)
 361             url (format
 362                  (nnweb-definition 'result) Newsgroups mid))
 363       (narrow-to-region (search-forward ">" nil t)
 364                         (search-forward "</a>" nil t))
 365       (mm-url-remove-markup)
 366       (mm-url-decode-entities)
 367       (setq Subject (buffer-string))
 368       (goto-char (point-max))
 369       (widen)
 370       (narrow-to-region (point)
 371                         (search-forward "</td" nil t))
 372
 373       (mm-url-remove-markup)
 374       (mm-url-decode-entities)
 375       (search-backward " - ")
 376       (when (looking-at
 377              " - \\([a-zA-Z]+\\) \\([0-9]+\\)\\(?: \\([0-9]\\{4\\}\\)\\)?, [^\n]+by \\([^<\n]+\\)\n")
 378         (setq From (match-string 4)
 379               Date (format "%s %s 00:00:00 %s"
 380                            (match-string 1)
 381                            (match-string 2)
 382                            (or (match-string 3)
 383                                (substring (current-time-string) -4)))))
 384
 385       (widen)
 386       (forward-line 1)
 387       (incf i)
 388       (unless (nnweb-get-hashtb url)
 389         (push
 390          (list
 391           (incf (cdr active))
 392           (make-full-mail-header
 393            (cdr active) (if Newsgroups
 394                             (concat  "(" Newsgroups ") " Subject)
 395                           Subject)
 396            From Date (or Message-ID mid)
 397            nil 0 0 url))
 398          map)
 399         (nnweb-set-hashtb (cadar map) (car map))))
 400     map))
 401
 402 (defun nnweb-google-reference (id)
 403   (let ((map (nnweb-google-parse-1 id)) header)
 404     (setq nnweb-articles
 405           (nconc nnweb-articles map))
 406     (when (setq header (cadar map))
 407       (mm-with-unibyte-current-buffer
 408         (mm-url-insert (mail-header-xref header)))
 409       (caar map))))
 410
 411 (defun nnweb-google-create-mapping ()
 412   "Perform the search and create a number-to-url alist."
 413   (save-excursion
 414     (set-buffer nnweb-buffer)
 415     (erase-buffer)
 416     (when (funcall (nnweb-definition 'search) nnweb-search)
 417         (let ((more t)
 418               (i 0))
 419           (while more
 420             (setq nnweb-articles
 421                   (nconc nnweb-articles (nnweb-google-parse-1)))
 422             ;; Check if there are more articles to fetch
 423             (goto-char (point-min))
 424             (incf i 100)
 425             (if (or (not (re-search-forward
 426                           "<td><a href=\"\n\\([^>\"]+\\)\"><img src=\"/img/nav_next" nil t))
 427                     (>= i nnweb-max-hits))
 428                 (setq more nil)
 429               ;; Yup, there are more articles
 430               (setq more (concat (nnweb-definition 'base) (match-string 1)))
 431             (when more
 432               (erase-buffer)
 433               (mm-url-insert more))))
 434           ;; Return the articles in the right order.
 435           (setq nnweb-articles
 436                 (sort nnweb-articles 'car-less-than-car))))))
 437
 438 (defun nnweb-google-search (search)
 439   (mm-url-insert
 440    (concat
 441     (nnweb-definition 'address)
 442     "?"
 443     (mm-url-encode-www-form-urlencoded
 444      `(("q" . ,search)
 445        ("num" . "100")
 446        ("hq" . "")
 447        ("hl" . "en")
 448        ("lr" . "")
 449        ("safe" . "off")
 450        ("sites" . "groups")
 451        ("filter" . "0")))))
 452   t)
 453
 454 (defun nnweb-google-identity (url)
 455   "Return an unique identifier based on URL."
 456   (if (string-match "selm=\\([^ &>]+\\)" url)
 457       (match-string 1 url)
 458     url))
 459
 460 ;;;
 461 ;;; gmane.org
 462 ;;;
 463 (defun nnweb-gmane-create-mapping ()
 464   "Perform the search and create a number-to-url alist."
 465   (save-excursion
 466     (set-buffer nnweb-buffer)
 467     (erase-buffer)
 468     (when (funcall (nnweb-definition 'search) nnweb-search)
 469       (let ((more t)
 470             (case-fold-search t)
 471             (active (or (cadr (assoc nnweb-group nnweb-group-alist))
 472                         (cons 1 0)))
 473             subject group url
 474             map)
 475           ;; Remove stuff from the beginning of results
 476         (goto-char (point-min))
 477         (search-forward "Search Results</h1><ul>" nil t)
 478         (delete-region (point-min) (point))
 479         (goto-char (point-min))
 480         ;; Iterate over the actual hits
 481         (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\(.*\\)" nil t)
 482             (setq url (concat "http://gmane.org/" (match-string 1)))
 483             (setq subject (match-string 2))
 484           (unless (nnweb-get-hashtb url)
 485             (push
 486              (list
 487               (incf (cdr active))
 488               (make-full-mail-header
 489                (cdr active) (concat  "(" group ") " subject) nil nil
 490                nil nil 0 0 url))
 491              map)
 492             (nnweb-set-hashtb (cadar map) (car map))))
 493         ;; Return the articles in the right order.
 494         (setq nnweb-articles
 495               (sort (nconc nnweb-articles map) 'car-less-than-car))))))
 496
 497 (defun nnweb-gmane-wash-article ()
 498   (let ((case-fold-search t))
 499     (goto-char (point-min))
 500     (search-forward "<!--X-Head-of-Message-->" nil t)
 501     (delete-region (point-min) (point))
 502     (goto-char (point-min))
 503     (while (looking-at "^<li><em>\\([^ ]+\\)</em>.*</li>")
 504       (replace-match "\\1\\2" t)
 505       (forward-line 1))
 506     (mm-url-remove-markup)))
 507
 508 (defun nnweb-gmane-search (search)
 509   (mm-url-insert
 510    (concat
 511     (nnweb-definition 'address)
 512     "?"
 513     (mm-url-encode-www-form-urlencoded
 514      `(("query" . ,search)))))
 515   (setq buffer-file-name nil)
 516   t)
 517
 518
 519 (defun nnweb-gmane-identity (url)
 520   "Return a unique identifier based on URL."
 521   (if (string-match "group=\\(.+\\)" url)
 522       (match-string 1 url)
 523     url))
 524
 525 ;;;
 526 ;;; General web/w3 interface utility functions
 527 ;;;
 528
 529 (defun nnweb-insert-html (parse)
 530   "Insert HTML based on a w3 parse tree."
 531   (if (stringp parse)
 532       (insert (nnheader-string-as-multibyte parse))
 533     (insert "<" (symbol-name (car parse)) " ")
 534     (insert (mapconcat
 535              (lambda (param)
 536                (concat (symbol-name (car param)) "="
 537                        (prin1-to-string
 538                         (if (consp (cdr param))
 539                             (cadr param)
 540                           (cdr param)))))
 541              (nth 1 parse)
 542              " "))
 543     (insert ">\n")
 544     (mapc 'nnweb-insert-html (nth 2 parse))
 545     (insert "</" (symbol-name (car parse)) ">\n")))
 546
 547 (defun nnweb-parse-find (type parse &optional maxdepth)
 548   "Find the element of TYPE in PARSE."
 549   (catch 'found
 550     (nnweb-parse-find-1 type parse maxdepth)))
 551
 552 (defun nnweb-parse-find-1 (type contents maxdepth)
 553   (when (or (null maxdepth)
 554             (not (zerop maxdepth)))
 555     (when (consp contents)
 556       (when (eq (car contents) type)
 557         (throw 'found contents))
 558       (when (listp (cdr contents))
 559         (dolist (element contents)
 560           (when (consp element)
 561             (nnweb-parse-find-1 type element
 562                                 (and maxdepth (1- maxdepth)))))))))
 563
 564 (defun nnweb-parse-find-all (type parse)
 565   "Find all elements of TYPE in PARSE."
 566   (catch 'found
 567     (nnweb-parse-find-all-1 type parse)))
 568
 569 (defun nnweb-parse-find-all-1 (type contents)
 570   (let (result)
 571     (when (consp contents)
 572       (if (eq (car contents) type)
 573           (push contents result)
 574         (when (listp (cdr contents))
 575           (dolist (element contents)
 576             (when (consp element)
 577               (setq result
 578                     (nconc result (nnweb-parse-find-all-1 type element))))))))
 579     result))
 580
 581 (defvar nnweb-text)
 582 (defun nnweb-text (parse)
 583   "Return a list of text contents in PARSE."
 584   (let ((nnweb-text nil))
 585     (nnweb-text-1 parse)
 586     (nreverse nnweb-text)))
 587
 588 (defun nnweb-text-1 (contents)
 589   (dolist (element contents)
 590     (if (stringp element)
 591         (push element nnweb-text)
 592       (when (and (consp element)
 593                  (listp (cdr element)))
 594         (nnweb-text-1 element)))))
 595
 596 (provide 'nnweb)
 597
 598 ;;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697
 599 ;;; nnweb.el ends here