cgit.sxemacs.org Git - gnus/blob - lisp/nnwfm.el

   1 ;;; nnwfm.el --- interfacing with a web forum
   2 ;; Copyright (C) 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  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 (url-unhex-string (match-string 2))))
 301           (when (and (nnwfm-new-threads-p group time)
 302                      (not (member
 303                            (setq url (concat
 304                                       nnwfm-address
 305                                       (mm-url-decode-entities-string url)))
 306                            fetched-urls)))
 307             (push url furls))))
 308       ;; The main idea here is to map Gnus article numbers to
 309       ;; nnwfm article numbers.  Say there are three topics in
 310       ;; this forum, the first with 4 articles, the seconds with 2,
 311       ;; and the third with 1.  Then this will translate into 7 Gnus
 312       ;; article numbers, where 1-4 comes from the first topic, 5-6
 313       ;; from the second and 7 from the third.  Now, then next time
 314       ;; the group is entered, there's 2 new articles in topic one
 315       ;; and 1 in topic three.  Then Gnus article number 8-9 be 5-6
 316       ;; in topic one and 10 will be the 2 in topic three.
 317       (dolist (elem (nreverse forum-contents))
 318         (setq subject (nth 1 elem)
 319               topic (nth 0 elem)
 320               garticles (nth 2 elem))
 321         (if (setq tinfo (assq topic topics))
 322             (progn
 323               (setq old-max (cadr tinfo))
 324               (setcar (cdr tinfo) garticles))
 325           (setq old-max 0)
 326           (push (list topic garticles subject) topics)
 327           (setcar (nthcdr 4 entry) topics))
 328         (when (not (= old-max garticles))
 329           (setq inc (- garticles old-max))
 330           (setq mapping (nconc mapping
 331                                (list
 332                                 (list
 333                                  old-total (1- (incf old-total inc))
 334                                  topic (1+ old-max)))))
 335           (incf old-max inc)
 336           (setcar (nthcdr 5 entry) mapping)
 337           (setcar (nthcdr 6 entry) old-total))))
 338     (setcar (nthcdr 7 entry) current-time)
 339     (setcar (nthcdr 1 entry) (1- old-total))
 340     (nnwfm-write-groups)
 341     mapping))
 342
 343 (defun nnwfm-possibly-change-server (&optional group server)
 344   (nnwfm-init server)
 345   (when (and server
 346              (not (nnwfm-server-opened server)))
 347     (nnwfm-open-server server))
 348   (unless nnwfm-groups-alist
 349     (nnwfm-read-groups)
 350     (setq nnwfm-groups (cdr (assoc nnwfm-address
 351                                         nnwfm-groups-alist)))))
 352
 353 (deffoo nnwfm-open-server (server &optional defs connectionless)
 354   (nnheader-init-server-buffer)
 355   (if (nnwfm-server-opened server)
 356       t
 357     (unless (assq 'nnwfm-address defs)
 358       (setq defs (append defs (list (list 'nnwfm-address server)))))
 359     (nnoo-change-server 'nnwfm server defs)))
 360
 361 (defun nnwfm-read-groups ()
 362   (setq nnwfm-groups-alist nil)
 363   (let ((file (expand-file-name "groups" nnwfm-directory)))
 364     (when (file-exists-p file)
 365       (mm-with-unibyte-buffer
 366         (insert-file-contents file)
 367         (goto-char (point-min))
 368         (setq nnwfm-groups-alist (read (current-buffer)))))))
 369
 370 (defun nnwfm-write-groups ()
 371   (setq nnwfm-groups-alist
 372         (delq (assoc nnwfm-address nnwfm-groups-alist)
 373               nnwfm-groups-alist))
 374   (push (cons nnwfm-address nnwfm-groups)
 375         nnwfm-groups-alist)
 376   (with-temp-file (expand-file-name "groups" nnwfm-directory)
 377     (prin1 nnwfm-groups-alist (current-buffer))))
 378
 379 (defun nnwfm-init (server)
 380   "Initialize buffers and such."
 381   (unless (file-exists-p nnwfm-directory)
 382     (gnus-make-directory nnwfm-directory)))
 383
 384 (defun nnwfm-generate-active ()
 385   (save-excursion
 386     (set-buffer nntp-server-buffer)
 387     (erase-buffer)
 388     (dolist (elem nnwfm-groups)
 389       (insert (prin1-to-string (car elem))
 390               " " (number-to-string (cadr elem)) " 1 y\n"))))
 391
 392 (defun nnwfm-find-forum-table (contents)
 393   (catch 'found
 394     (nnwfm-find-forum-table-1 contents)))
 395
 396 (defun nnwfm-find-forum-table-1 (contents)
 397   (dolist (element contents)
 398     (unless (stringp element)
 399       (when (and (eq (car element) 'table)
 400                  (nnwfm-forum-table-p element))
 401         (throw 'found element))
 402       (when (nth 2 element)
 403         (nnwfm-find-forum-table-1 (nth 2 element))))))
 404
 405 (defun nnwfm-forum-table-p (parse)
 406   (when (not (apply 'gnus-or
 407                     (mapcar
 408                      (lambda (p)
 409                        (nnweb-parse-find 'table p))
 410                      (nth 2 parse))))
 411     (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20)))))
 412           case-fold-search)
 413       (when (and href (string-match nnwfm-table-regexp href))
 414         t))))
 415
 416 (defun nnwfm-date-to-time (date)
 417   (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]"))))
 418     (encode-time 0 (nth 4 time) (nth 3 time)
 419                  (nth 0 time) (nth 1 time)
 420                  (if (< (nth 2 time) 70)
 421                      (+ 2000 (nth 2 time))
 422                    (+ 1900 (nth 2 time))))))
 423
 424 (provide 'nnwfm)
 425
 426 ;; Local Variables:
 427 ;; coding: iso-8859-1
 428 ;; End:
 429
 430 ;;; nnwfm.el ends here