lisp/gnus/nnwfm.el

   1 ;;; nnwfm.el --- interfacing with a web forum
   2
   3 ;; Copyright (C) 2000, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007 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, 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 `url' and `w3' installed for this
  29 ;; backend to work.
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34
  35 (require 'nnoo)
  36 (require 'message)
  37 (require 'gnus-util)
  38 (require 'gnus)
  39 (require 'nnmail)
  40 (require 'mm-util)
  41 (require 'mm-url)
  42 (require 'nnweb)
  43 (autoload 'w3-parse-buffer "w3-parse")
  44
  45 (nnoo-declare nnwfm)
  46
  47 (defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/")
  48   "Where nnwfm will save its files.")
  49
  50 (defvoo nnwfm-address ""
  51   "The address of the Ultimate bulletin board.")
  52
  53 ;;; Internal variables
  54
  55 (defvar nnwfm-groups-alist nil)
  56 (defvoo nnwfm-groups nil)
  57 (defvoo nnwfm-headers nil)
  58 (defvoo nnwfm-articles nil)
  59 (defvar nnwfm-table-regexp
  60   "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio")
  61
  62 ;;; Interface functions
  63
  64 (nnoo-define-basics nnwfm)
  65
  66 (deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old)
  67   (nnwfm-possibly-change-server group server)
  68   (unless gnus-nov-is-evil
  69     (let* ((last (car (last articles)))
  70            (did nil)
  71            (start 1)
  72            (entry (assoc group nnwfm-groups))
  73            (sid (nth 2 entry))
  74            (topics (nth 4 entry))
  75            (mapping (nth 5 entry))
  76            (old-total (or (nth 6 entry) 1))
  77            (nnwfm-table-regexp "Thread.asp")
  78            headers article subject score from date lines parent point
  79            contents tinfo fetchers map elem a href garticles topic old-max
  80            inc datel table string current-page total-contents pages
  81            farticles forum-contents parse furl-fetched mmap farticle
  82            thread-id tables hstuff bstuff time)
  83       (setq map mapping)
  84       (while (and (setq article (car articles))
  85                   map)
  86         (while (and map
  87                     (or (> article (caar map))
  88                         (< (cadar map) (caar map))))
  89           (pop map))
  90         (when (setq mmap (car map))
  91           (setq farticle -1)
  92           (while (and article
  93                       (<= article (nth 1 mmap)))
  94             ;; Do we already have a fetcher for this topic?
  95             (if (setq elem (assq (nth 2 mmap) fetchers))
  96                 ;; Yes, so we just add the spec to the end.
  97                 (nconc elem (list (cons article
  98                                         (+ (nth 3 mmap) (incf farticle)))))
  99               ;; No, so we add a new one.
 100               (push (list (nth 2 mmap)
 101                           (cons article
 102                                 (+ (nth 3 mmap) (incf farticle))))
 103                     fetchers))
 104             (pop articles)
 105             (setq article (car articles)))))
 106       ;; Now we have the mapping from/to Gnus/nnwfm article numbers,
 107       ;; so we start fetching the topics that we need to satisfy the
 108       ;; request.
 109       (if (not fetchers)
 110           (save-excursion
 111             (set-buffer nntp-server-buffer)
 112             (erase-buffer))
 113         (setq nnwfm-articles nil)
 114         (mm-with-unibyte-buffer
 115           (dolist (elem fetchers)
 116             (erase-buffer)
 117             (setq subject (nth 2 (assq (car elem) topics))
 118                   thread-id (nth 0 (assq (car elem) topics)))
 119             (mm-url-insert
 120              (concat nnwfm-address
 121                      (format "Item.asp?GroupID=%d&ThreadID=%d" sid
 122                              thread-id)))
 123             (goto-char (point-min))
 124             (setq tables (caddar
 125                           (caddar
 126                            (cdr (caddar
 127                                  (caddar
 128                                   (ignore-errors
 129                                     (w3-parse-buffer (current-buffer)))))))))
 130             (setq tables (cdr (caddar (memq (assq 'div tables) tables))))
 131             (setq contents nil)
 132             (dolist (table tables)
 133               (when (eq (car table) 'table)
 134                 (setq table (caddar (caddar (caddr table)))
 135                       hstuff (delete ":link" (nnweb-text (car table)))
 136                       bstuff (car (caddar (cdr table)))
 137                       from (car hstuff))
 138                 (when (nth 2 hstuff)
 139                   (setq time (nnwfm-date-to-time (nth 2 hstuff)))
 140                   (push (list from time bstuff) contents))))
 141             (setq contents (nreverse contents))
 142             (dolist (art (cdr elem))
 143                 (push (list (car art)
 144                             (nth (1- (cdr art)) contents)
 145                             subject)
 146                       nnwfm-articles))))
 147         (setq nnwfm-articles
 148               (sort nnwfm-articles 'car-less-than-car))
 149         ;; Now we have all the articles, conveniently in an alist
 150         ;; where the key is the Gnus article number.
 151         (dolist (articlef nnwfm-articles)
 152           (setq article (nth 0 articlef)
 153                 contents (nth 1 articlef)
 154                 subject (nth 2 articlef))
 155           (setq from (nth 0 contents)
 156                 date (message-make-date (nth 1 contents)))
 157           (push
 158            (cons
 159             article
 160             (make-full-mail-header
 161              article subject
 162              from (or date "")
 163              (concat "<" (number-to-string sid) "%"
 164                      (number-to-string article)
 165                      "@wfm>")
 166              "" 0
 167              (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) ""))
 168                 70)
 169              nil nil))
 170            headers))
 171         (setq nnwfm-headers (sort headers 'car-less-than-car))
 172         (save-excursion
 173           (set-buffer nntp-server-buffer)
 174           (mm-with-unibyte-current-buffer
 175             (erase-buffer)
 176             (dolist (header nnwfm-headers)
 177               (nnheader-insert-nov (cdr header))))))
 178       'nov)))
 179
 180 (deffoo nnwfm-request-group (group &optional server dont-check)
 181   (nnwfm-possibly-change-server nil server)
 182   (when (not nnwfm-groups)
 183     (nnwfm-request-list))
 184   (unless dont-check
 185     (nnwfm-create-mapping group))
 186   (let ((elem (assoc group nnwfm-groups)))
 187     (cond
 188      ((not elem)
 189       (nnheader-report 'nnwfm "Group does not exist"))
 190      (t
 191       (nnheader-report 'nnwfm "Opened group %s" group)
 192       (nnheader-insert
 193        "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
 194        (prin1-to-string group))))))
 195
 196 (deffoo nnwfm-request-close ()
 197   (setq nnwfm-groups-alist nil
 198         nnwfm-groups nil))
 199
 200 (deffoo nnwfm-request-article (article &optional group server buffer)
 201   (nnwfm-possibly-change-server group server)
 202   (let ((contents (cdr (assq article nnwfm-articles))))
 203     (when (setq contents (nth 2 (car contents)))
 204       (save-excursion
 205         (set-buffer (or buffer nntp-server-buffer))
 206         (erase-buffer)
 207         (nnweb-insert-html contents)
 208         (goto-char (point-min))
 209         (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
 210         (let ((header (cdr (assq article nnwfm-headers))))
 211           (mm-with-unibyte-current-buffer
 212             (nnheader-insert-header header)))
 213         (nnheader-report 'nnwfm "Fetched article %s" article)
 214         (cons group article)))))
 215
 216 (deffoo nnwfm-request-list (&optional server)
 217   (nnwfm-possibly-change-server nil server)
 218   (mm-with-unibyte-buffer
 219     (mm-url-insert
 220      (if (string-match "/$" nnwfm-address)
 221          (concat nnwfm-address "Group.asp")
 222        nnwfm-address))
 223     (let* ((nnwfm-table-regexp "Thread.asp")
 224            (contents (w3-parse-buffer (current-buffer)))
 225            sid elem description articles a href group forum
 226            a1 a2)
 227       (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table
 228                                             contents))))))
 229         (setq row (nth 2 row))
 230         (when (setq a (nnweb-parse-find 'a row))
 231           (setq group (car (last (nnweb-text a)))
 232                 href (cdr (assq 'href (nth 1 a))))
 233           (setq description (car (last (nnweb-text (nth 1 row)))))
 234           (setq articles
 235                 (string-to-number
 236                  (gnus-replace-in-string
 237                   (car (last (nnweb-text (nth 3 row)))) "," "")))
 238           (when (and href
 239                      (string-match "GroupId=\\([0-9]+\\)" href))
 240             (setq forum (string-to-number (match-string 1 href)))
 241             (if (setq elem (assoc group nnwfm-groups))
 242                 (setcar (cdr elem) articles)
 243               (push (list group articles forum description nil nil nil nil)
 244                     nnwfm-groups))))))
 245     (nnwfm-write-groups)
 246     (nnwfm-generate-active)
 247     t))
 248
 249 (deffoo nnwfm-request-newgroups (date &optional server)
 250   (nnwfm-possibly-change-server nil server)
 251   (nnwfm-generate-active)
 252   t)
 253
 254 (nnoo-define-skeleton nnwfm)
 255
 256 ;;; Internal functions
 257
 258 (defun nnwfm-new-threads-p (group time)
 259   "See whether we want to fetch the threads for GROUP written before TIME."
 260   (let ((old-time (nth 7 (assoc group nnwfm-groups))))
 261     (or (null old-time)
 262         (time-less-p old-time time))))
 263
 264 (defun nnwfm-create-mapping (group)
 265   (let* ((entry (assoc group nnwfm-groups))
 266          (sid (nth 2 entry))
 267          (topics (nth 4 entry))
 268          (mapping (nth 5 entry))
 269          (old-total (or (nth 6 entry) 1))
 270          (current-time (current-time))
 271          (nnwfm-table-regexp "Thread.asp")
 272          (furls (list (concat nnwfm-address
 273                               (format "Thread.asp?GroupId=%d" sid))))
 274          fetched-urls
 275          contents forum-contents a subject href
 276          garticles topic tinfo old-max inc parse elem date
 277          url time)
 278     (mm-with-unibyte-buffer
 279       (while furls
 280         (erase-buffer)
 281         (push (car furls) fetched-urls)
 282         (mm-url-insert (pop furls))
 283         (goto-char (point-min))
 284         (while (re-search-forward "  wr(" nil t)
 285           (forward-char -1)
 286           (setq elem (message-tokenize-header
 287                       (gnus-replace-in-string
 288                        (buffer-substring
 289                         (1+ (point))
 290                         (progn
 291                           (forward-sexp 1)
 292                           (1- (point))))
 293                        "\\\\[\"\\\\]" "")))
 294           (push (list
 295                  (string-to-number (nth 1 elem))
 296                  (gnus-replace-in-string (nth 2 elem) "\"" "")
 297                  (string-to-number (nth 5 elem)))
 298                 forum-contents))
 299         (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)"
 300                                  nil t)
 301           (setq url (match-string 1)
 302                 time (nnwfm-date-to-time (gnus-url-unhex-string
 303                                           (match-string 2))))
 304           (when (and (nnwfm-new-threads-p group time)
 305                      (not (member
 306                            (setq url (concat
 307                                       nnwfm-address
 308                                       (mm-url-decode-entities-string url)))
 309                            fetched-urls)))
 310             (push url furls))))
 311       ;; The main idea here is to map Gnus article numbers to
 312       ;; nnwfm article numbers.  Say there are three topics in
 313       ;; this forum, the first with 4 articles, the seconds with 2,
 314       ;; and the third with 1.  Then this will translate into 7 Gnus
 315       ;; article numbers, where 1-4 comes from the first topic, 5-6
 316       ;; from the second and 7 from the third.  Now, then next time
 317       ;; the group is entered, there's 2 new articles in topic one
 318       ;; and 1 in topic three.  Then Gnus article number 8-9 be 5-6
 319       ;; in topic one and 10 will be the 2 in topic three.
 320       (dolist (elem (nreverse forum-contents))
 321         (setq subject (nth 1 elem)
 322               topic (nth 0 elem)
 323               garticles (nth 2 elem))
 324         (if (setq tinfo (assq topic topics))
 325             (progn
 326               (setq old-max (cadr tinfo))
 327               (setcar (cdr tinfo) garticles))
 328           (setq old-max 0)
 329           (push (list topic garticles subject) topics)
 330           (setcar (nthcdr 4 entry) topics))
 331         (when (not (= old-max garticles))
 332           (setq inc (- garticles old-max))
 333           (setq mapping (nconc mapping
 334                                (list
 335                                 (list
 336                                  old-total (1- (incf old-total inc))
 337                                  topic (1+ old-max)))))
 338           (incf old-max inc)
 339           (setcar (nthcdr 5 entry) mapping)
 340           (setcar (nthcdr 6 entry) old-total))))
 341     (setcar (nthcdr 7 entry) current-time)
 342     (setcar (nthcdr 1 entry) (1- old-total))
 343     (nnwfm-write-groups)
 344     mapping))
 345
 346 (defun nnwfm-possibly-change-server (&optional group server)
 347   (nnwfm-init server)
 348   (when (and server
 349              (not (nnwfm-server-opened server)))
 350     (nnwfm-open-server server))
 351   (unless nnwfm-groups-alist
 352     (nnwfm-read-groups)
 353     (setq nnwfm-groups (cdr (assoc nnwfm-address
 354                                         nnwfm-groups-alist)))))
 355
 356 (deffoo nnwfm-open-server (server &optional defs connectionless)
 357   (nnheader-init-server-buffer)
 358   (if (nnwfm-server-opened server)
 359       t
 360     (unless (assq 'nnwfm-address defs)
 361       (setq defs (append defs (list (list 'nnwfm-address server)))))
 362     (nnoo-change-server 'nnwfm server defs)))
 363
 364 (defun nnwfm-read-groups ()
 365   (setq nnwfm-groups-alist nil)
 366   (let ((file (expand-file-name "groups" nnwfm-directory)))
 367     (when (file-exists-p file)
 368       (mm-with-unibyte-buffer
 369         (insert-file-contents file)
 370         (goto-char (point-min))
 371         (setq nnwfm-groups-alist (read (current-buffer)))))))
 372
 373 (defun nnwfm-write-groups ()
 374   (setq nnwfm-groups-alist
 375         (delq (assoc nnwfm-address nnwfm-groups-alist)
 376               nnwfm-groups-alist))
 377   (push (cons nnwfm-address nnwfm-groups)
 378         nnwfm-groups-alist)
 379   (with-temp-file (expand-file-name "groups" nnwfm-directory)
 380     (prin1 nnwfm-groups-alist (current-buffer))))
 381
 382 (defun nnwfm-init (server)
 383   "Initialize buffers and such."
 384   (unless (file-exists-p nnwfm-directory)
 385     (gnus-make-directory nnwfm-directory)))
 386
 387 (defun nnwfm-generate-active ()
 388   (save-excursion
 389     (set-buffer nntp-server-buffer)
 390     (erase-buffer)
 391     (dolist (elem nnwfm-groups)
 392       (insert (prin1-to-string (car elem))
 393               " " (number-to-string (cadr elem)) " 1 y\n"))))
 394
 395 (defun nnwfm-find-forum-table (contents)
 396   (catch 'found
 397     (nnwfm-find-forum-table-1 contents)))
 398
 399 (defun nnwfm-find-forum-table-1 (contents)
 400   (dolist (element contents)
 401     (unless (stringp element)
 402       (when (and (eq (car element) 'table)
 403                  (nnwfm-forum-table-p element))
 404         (throw 'found element))
 405       (when (nth 2 element)
 406         (nnwfm-find-forum-table-1 (nth 2 element))))))
 407
 408 (defun nnwfm-forum-table-p (parse)
 409   (when (not (apply 'gnus-or
 410                     (mapcar
 411                      (lambda (p)
 412                        (nnweb-parse-find 'table p))
 413                      (nth 2 parse))))
 414     (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20)))))
 415           case-fold-search)
 416       (when (and href (string-match nnwfm-table-regexp href))
 417         t))))
 418
 419 (defun nnwfm-date-to-time (date)
 420   (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]"))))
 421     (encode-time 0 (nth 4 time) (nth 3 time)
 422                  (nth 0 time) (nth 1 time)
 423                  (if (< (nth 2 time) 70)
 424                      (+ 2000 (nth 2 time))
 425                    (+ 1900 (nth 2 time))))))
 426
 427 (provide 'nnwfm)
 428
 429 ;; Local Variables:
 430 ;; coding: iso-8859-1
 431 ;; End:
 432
 433 ;;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536
 434 ;;; nnwfm.el ends here