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