code.delx.au - gnu-emacs/blob - lisp/gnus/nnweb.el

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