lisp/gnus/nnwfm.el

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