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 (eval-when-compile
  40   (ignore-errors
  41     (require 'nnweb)))
  42 ;; Report failure to find w3 at load time if appropriate.
  43 (eval '(require 'nnweb))
  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             (nnweb-insert
 120              (concat nnwfm-address
 121                      (format "Item.asp?GroupID=%d&ThreadID=%d" sid
 122                              thread-id)))
 123             (goto-char (point-min))
 124             (setq contents
 125                   (ignore-errors (w3-parse-buffer (current-buffer))))
 126             (setq tables (caddar (caddar (cdr (caddar (caddar contents))))))
 127             (setq tables (cdr (caddar (memq (assq 'div tables) tables))))
 128             (setq contents nil)
 129             (dolist (table tables)
 130               (setq table (caddar (caddar (caddr table)))
 131                     hstuff (delete ":link" (nnweb-text (car table)))
 132                     bstuff (car (caddar (cdr table)))
 133                     from (car hstuff))
 134               (when (nth 2 hstuff)
 135                 (setq time (nnwfm-date-to-time (nth 2 hstuff)))
 136                 (push (list from time bstuff) contents)))
 137             (setq contents (nreverse contents))
 138             (dolist (art (cdr elem))
 139                 (push (list (car art)
 140                             (nth (1- (cdr art)) contents)
 141                             subject)
 142                       nnwfm-articles))))
 143         (setq nnwfm-articles
 144               (sort nnwfm-articles 'car-less-than-car))
 145         ;; Now we have all the articles, conveniently in an alist
 146         ;; where the key is the Gnus article number.
 147         (dolist (articlef nnwfm-articles)
 148           (setq article (nth 0 articlef)
 149                 contents (nth 1 articlef)
 150                 subject (nth 2 articlef))
 151           (setq from (nth 0 contents)
 152                 date (message-make-date (nth 1 contents)))
 153           (push
 154            (cons
 155             article
 156             (make-full-mail-header
 157              article subject
 158              from (or date "")
 159              (concat "<" (number-to-string sid) "%"
 160                      (number-to-string article)
 161                      "@wfm>")
 162              "" 0
 163              (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) ""))
 164                 70)
 165              nil nil))
 166            headers))
 167         (setq nnwfm-headers (sort headers 'car-less-than-car))
 168         (save-excursion
 169           (set-buffer nntp-server-buffer)
 170           (mm-with-unibyte-current-buffer
 171             (erase-buffer)
 172             (dolist (header nnwfm-headers)
 173               (nnheader-insert-nov (cdr header))))))
 174       'nov)))
 175
 176 (deffoo nnwfm-request-group (group &optional server dont-check)
 177   (nnwfm-possibly-change-server nil server)
 178   (when (not nnwfm-groups)
 179     (nnwfm-request-list))
 180   (unless dont-check
 181     (nnwfm-create-mapping group))
 182   (let ((elem (assoc group nnwfm-groups)))
 183     (cond
 184      ((not elem)
 185       (nnheader-report 'nnwfm "Group does not exist"))
 186      (t
 187       (nnheader-report 'nnwfm "Opened group %s" group)
 188       (nnheader-insert
 189        "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
 190        (prin1-to-string group))))))
 191
 192 (deffoo nnwfm-request-close ()
 193   (setq nnwfm-groups-alist nil
 194         nnwfm-groups nil))
 195
 196 (deffoo nnwfm-request-article (article &optional group server buffer)
 197   (nnwfm-possibly-change-server group server)
 198   (let ((contents (cdr (assq article nnwfm-articles))))
 199     (when (setq contents (nth 2 (car contents)))
 200       (save-excursion
 201         (set-buffer (or buffer nntp-server-buffer))
 202         (erase-buffer)
 203         (nnweb-insert-html contents)
 204         (goto-char (point-min))
 205         (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
 206         (let ((header (cdr (assq article nnwfm-headers))))
 207           (mm-with-unibyte-current-buffer
 208             (nnheader-insert-header header)))
 209         (nnheader-report 'nnwfm "Fetched article %s" article)
 210         (cons group article)))))
 211
 212 (deffoo nnwfm-request-list (&optional server)
 213   (nnwfm-possibly-change-server nil server)
 214   (mm-with-unibyte-buffer
 215     (nnweb-insert
 216      (if (string-match "/$" nnwfm-address)
 217          (concat nnwfm-address "Group.asp")
 218        nnwfm-address))
 219     (let* ((nnwfm-table-regexp "Thread.asp")
 220            (contents (w3-parse-buffer (current-buffer)))
 221            sid elem description articles a href group forum
 222            a1 a2)
 223       (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table
 224                                             contents))))))
 225         (setq row (nth 2 row))
 226         (when (setq a (nnweb-parse-find 'a row))
 227           (setq group (car (last (nnweb-text a)))
 228                 href (cdr (assq 'href (nth 1 a))))
 229           (setq description (car (last (nnweb-text (nth 1 row)))))
 230           (setq articles
 231                 (string-to-number
 232                  (nnweb-replace-in-string
 233                   (car (last (nnweb-text (nth 3 row)))) "," "")))
 234           (when (and href
 235                      (string-match "GroupId=\\([0-9]+\\)" href))
 236             (setq forum (string-to-number (match-string 1 href)))
 237             (if (setq elem (assoc group nnwfm-groups))
 238                 (setcar (cdr elem) articles)
 239               (push (list group articles forum description nil nil nil nil)
 240                     nnwfm-groups))))))
 241     (nnwfm-write-groups)
 242     (nnwfm-generate-active)
 243     t))
 244
 245 (deffoo nnwfm-request-newgroups (date &optional server)
 246   (nnwfm-possibly-change-server nil server)
 247   (nnwfm-generate-active)
 248   t)
 249
 250 (nnoo-define-skeleton nnwfm)
 251
 252 ;;; Internal functions
 253
 254 (defun nnwfm-new-threads-p (group time)
 255   "See whether we want to fetch the threads for GROUP written before TIME."
 256   (let ((old-time (nth 7 (assoc group nnwfm-groups))))
 257     (or (null old-time)
 258         (time-less-p old-time time))))
 259
 260 (defun nnwfm-create-mapping (group)
 261   (let* ((entry (assoc group nnwfm-groups))
 262          (sid (nth 2 entry))
 263          (topics (nth 4 entry))
 264          (mapping (nth 5 entry))
 265          (old-total (or (nth 6 entry) 1))
 266          (current-time (current-time))
 267          (nnwfm-table-regexp "Thread.asp")
 268          (furls (list (concat nnwfm-address
 269                               (format "Thread.asp?GroupId=%d" sid))))
 270          fetched-urls
 271          contents forum-contents a subject href
 272          garticles topic tinfo old-max inc parse elem date
 273          url time)
 274     (mm-with-unibyte-buffer
 275       (while furls
 276         (erase-buffer)
 277         (push (car furls) fetched-urls)
 278         (nnweb-insert (pop furls))
 279         (goto-char (point-min))
 280         (while (re-search-forward "  wr(" nil t)
 281           (forward-char -1)
 282           (setq elem (message-tokenize-header
 283                       (buffer-substring
 284                        (1+ (point))
 285                        (progn
 286                          (forward-sexp 1)
 287                          (1- (point))))))
 288           (push (list
 289                  (string-to-number (nth 1 elem))
 290                  (nnweb-replace-in-string (nth 2 elem) "\"" "")
 291                  (string-to-number (nth 5 elem)))
 292                 forum-contents))
 293         (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)"
 294                                  nil t)
 295           (setq url (match-string 1)
 296                 time (nnwfm-date-to-time (url-unhex-string (match-string 2))))
 297           (when (and (nnwfm-new-threads-p group time)
 298                      (not (member
 299                            (setq url (concat
 300                                       nnwfm-address
 301                                       (nnweb-decode-entities-string url)))
 302                            fetched-urls)))
 303             (push url furls))))
 304       ;; The main idea here is to map Gnus article numbers to
 305       ;; nnwfm article numbers.  Say there are three topics in
 306       ;; this forum, the first with 4 articles, the seconds with 2,
 307       ;; and the third with 1.  Then this will translate into 7 Gnus
 308       ;; article numbers, where 1-4 comes from the first topic, 5-6
 309       ;; from the second and 7 from the third.  Now, then next time
 310       ;; the group is entered, there's 2 new articles in topic one
 311       ;; and 1 in topic three.  Then Gnus article number 8-9 be 5-6
 312       ;; in topic one and 10 will be the 2 in topic three.
 313       (dolist (elem (nreverse forum-contents))
 314         (setq subject (nth 1 elem)
 315               topic (nth 0 elem)
 316               garticles (nth 2 elem))
 317         (if (setq tinfo (assq topic topics))
 318             (progn
 319               (setq old-max (cadr tinfo))
 320               (setcar (cdr tinfo) garticles))
 321           (setq old-max 0)
 322           (push (list topic garticles subject) topics)
 323           (setcar (nthcdr 4 entry) topics))
 324         (when (not (= old-max garticles))
 325           (setq inc (- garticles old-max))
 326           (setq mapping (nconc mapping
 327                                (list
 328                                 (list
 329                                  old-total (1- (incf old-total inc))
 330                                  topic (1+ old-max)))))
 331           (incf old-max inc)
 332           (setcar (nthcdr 5 entry) mapping)
 333           (setcar (nthcdr 6 entry) old-total))))
 334     (setcar (nthcdr 7 entry) current-time)
 335     (setcar (nthcdr 1 entry) (1- old-total))
 336     (nnwfm-write-groups)
 337     mapping))
 338
 339 (defun nnwfm-possibly-change-server (&optional group server)
 340   (nnwfm-init server)
 341   (when (and server
 342              (not (nnwfm-server-opened server)))
 343     (nnwfm-open-server server))
 344   (unless nnwfm-groups-alist
 345     (nnwfm-read-groups)
 346     (setq nnwfm-groups (cdr (assoc nnwfm-address
 347                                         nnwfm-groups-alist)))))
 348
 349 (deffoo nnwfm-open-server (server &optional defs connectionless)
 350   (nnheader-init-server-buffer)
 351   (if (nnwfm-server-opened server)
 352       t
 353     (unless (assq 'nnwfm-address defs)
 354       (setq defs (append defs (list (list 'nnwfm-address server)))))
 355     (nnoo-change-server 'nnwfm server defs)))
 356
 357 (defun nnwfm-read-groups ()
 358   (setq nnwfm-groups-alist nil)
 359   (let ((file (expand-file-name "groups" nnwfm-directory)))
 360     (when (file-exists-p file)
 361       (mm-with-unibyte-buffer
 362         (insert-file-contents file)
 363         (goto-char (point-min))
 364         (setq nnwfm-groups-alist (read (current-buffer)))))))
 365
 366 (defun nnwfm-write-groups ()
 367   (setq nnwfm-groups-alist
 368         (delq (assoc nnwfm-address nnwfm-groups-alist)
 369               nnwfm-groups-alist))
 370   (push (cons nnwfm-address nnwfm-groups)
 371         nnwfm-groups-alist)
 372   (with-temp-file (expand-file-name "groups" nnwfm-directory)
 373     (prin1 nnwfm-groups-alist (current-buffer))))
 374
 375 (defun nnwfm-init (server)
 376   "Initialize buffers and such."
 377   (unless (file-exists-p nnwfm-directory)
 378     (gnus-make-directory nnwfm-directory)))
 379
 380 (defun nnwfm-generate-active ()
 381   (save-excursion
 382     (set-buffer nntp-server-buffer)
 383     (erase-buffer)
 384     (dolist (elem nnwfm-groups)
 385       (insert (prin1-to-string (car elem))
 386               " " (number-to-string (cadr elem)) " 1 y\n"))))
 387
 388 (defun nnwfm-find-forum-table (contents)
 389   (catch 'found
 390     (nnwfm-find-forum-table-1 contents)))
 391
 392 (defun nnwfm-find-forum-table-1 (contents)
 393   (dolist (element contents)
 394     (unless (stringp element)
 395       (when (and (eq (car element) 'table)
 396                  (nnwfm-forum-table-p element))
 397         (throw 'found element))
 398       (when (nth 2 element)
 399         (nnwfm-find-forum-table-1 (nth 2 element))))))
 400
 401 (defun nnwfm-forum-table-p (parse)
 402   (when (not (apply 'gnus-or
 403                     (mapcar
 404                      (lambda (p)
 405                        (nnweb-parse-find 'table p))
 406                      (nth 2 parse))))
 407     (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20)))))
 408           case-fold-search)
 409       (when (and href (string-match nnwfm-table-regexp href))
 410         t))))
 411
 412 (defun nnwfm-date-to-time (date)
 413   (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]"))))
 414     (encode-time 0 (nth 4 time) (nth 3 time)
 415                  (nth 0 time) (nth 1 time)
 416                  (if (< (nth 2 time) 70)
 417                      (+ 2000 (nth 2 time))
 418                    (+ 1900 (nth 2 time))))))
 419
 420 (provide 'nnwfm)
 421
 422 ;; Local Variables:
 423 ;; coding: iso-8859-1
 424 ;; End:
 425
 426 ;;; nnwfm.el ends here