git.chise.org Git - elisp/gnus.git-/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 (eval-when-compile (require 'gnus-clfns))
  33
  34 (require 'nnoo)
  35 (require 'message)
  36 (require 'gnus-util)
  37 (require 'gnus)
  38 (require 'nnmail)
  39 (require 'mm-util)
  40 (eval-when-compile
  41   (ignore-errors
  42     (require 'nnweb)))
  43 ;; Report failure to find w3 at load time if appropriate.
  44 (eval '(require 'nnweb))
  45
  46 (nnoo-declare nnwfm)
  47
  48 (defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/")
  49   "Where nnwfm will save its files.")
  50
  51 (defvoo nnwfm-address ""
  52   "The address of the Ultimate bulletin board.")
  53
  54 ;;; Internal variables
  55
  56 (defvar nnwfm-groups-alist nil)
  57 (defvoo nnwfm-groups nil)
  58 (defvoo nnwfm-headers nil)
  59 (defvoo nnwfm-articles nil)
  60 (defvar nnwfm-table-regexp
  61   "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio")
  62
  63 ;;; Interface functions
  64
  65 (nnoo-define-basics nnwfm)
  66
  67 (deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old)
  68   (nnwfm-possibly-change-server group server)
  69   (unless gnus-nov-is-evil
  70     (let* ((last (car (last articles)))
  71            (did nil)
  72            (start 1)
  73            (entry (assoc group nnwfm-groups))
  74            (sid (nth 2 entry))
  75            (topics (nth 4 entry))
  76            (mapping (nth 5 entry))
  77            (old-total (or (nth 6 entry) 1))
  78            (nnwfm-table-regexp "Thread.asp")
  79            headers article subject score from date lines parent point
  80            contents tinfo fetchers map elem a href garticles topic old-max
  81            inc datel table string current-page total-contents pages
  82            farticles forum-contents parse furl-fetched mmap farticle
  83            thread-id tables hstuff bstuff time)
  84       (setq map mapping)
  85       (while (and (setq article (car articles))
  86                   map)
  87         (while (and map
  88                     (or (> article (caar map))
  89                         (< (cadar map) (caar map))))
  90           (pop map))
  91         (when (setq mmap (car map))
  92           (setq farticle -1)
  93           (while (and article
  94                       (<= article (nth 1 mmap)))
  95             ;; Do we already have a fetcher for this topic?
  96             (if (setq elem (assq (nth 2 mmap) fetchers))
  97                 ;; Yes, so we just add the spec to the end.
  98                 (nconc elem (list (cons article
  99                                         (+ (nth 3 mmap) (incf farticle)))))
 100               ;; No, so we add a new one.
 101               (push (list (nth 2 mmap)
 102                           (cons article
 103                                 (+ (nth 3 mmap) (incf farticle))))
 104                     fetchers))
 105             (pop articles)
 106             (setq article (car articles)))))
 107       ;; Now we have the mapping from/to Gnus/nnwfm article numbers,
 108       ;; so we start fetching the topics that we need to satisfy the
 109       ;; request.
 110       (if (not fetchers)
 111           (save-excursion
 112             (set-buffer nntp-server-buffer)
 113             (erase-buffer))
 114         (setq nnwfm-articles nil)
 115         (mm-with-unibyte-buffer
 116           (dolist (elem fetchers)
 117             (erase-buffer)
 118             (setq subject (nth 2 (assq (car elem) topics))
 119                   thread-id (nth 0 (assq (car elem) topics)))
 120             (nnweb-insert
 121              (concat nnwfm-address
 122                      (format "Item.asp?GroupID=%d&ThreadID=%d" sid
 123                              thread-id)))
 124             (goto-char (point-min))
 125             (setq tables (caddar
 126                           (caddar
 127                            (cdr (caddar
 128                                  (caddar
 129                                   (ignore-errors
 130                                     (w3-parse-buffer (current-buffer)))))))))
 131             (setq tables (cdr (caddar (memq (assq 'div tables) tables))))
 132             (setq contents nil)
 133             (dolist (table tables)
 134               (when (eq (car table) 'table)
 135                 (setq table (caddar (caddar (caddr table)))
 136                       hstuff (delete ":link" (nnweb-text (car table)))
 137                       bstuff (car (caddar (cdr table)))
 138                       from (car hstuff))
 139                 (when (nth 2 hstuff)
 140                   (setq time (nnwfm-date-to-time (nth 2 hstuff)))
 141                   (push (list from time bstuff) contents))))
 142             (setq contents (nreverse contents))
 143             (dolist (art (cdr elem))
 144                 (push (list (car art)
 145                             (nth (1- (cdr art)) contents)
 146                             subject)
 147                       nnwfm-articles))))
 148         (setq nnwfm-articles
 149               (sort nnwfm-articles 'car-less-than-car))
 150         ;; Now we have all the articles, conveniently in an alist
 151         ;; where the key is the Gnus article number.
 152         (dolist (articlef nnwfm-articles)
 153           (setq article (nth 0 articlef)
 154                 contents (nth 1 articlef)
 155                 subject (nth 2 articlef))
 156           (setq from (nth 0 contents)
 157                 date (message-make-date (nth 1 contents)))
 158           (push
 159            (cons
 160             article
 161             (make-full-mail-header
 162              article subject
 163              from (or date "")
 164              (concat "<" (number-to-string sid) "%"
 165                      (number-to-string article)
 166                      "@wfm>")
 167              "" 0
 168              (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) ""))
 169                 70)
 170              nil nil))
 171            headers))
 172         (setq nnwfm-headers (sort headers 'car-less-than-car))
 173         (save-excursion
 174           (set-buffer nntp-server-buffer)
 175           (mm-with-unibyte-current-buffer
 176             (erase-buffer)
 177             (dolist (header nnwfm-headers)
 178               (nnheader-insert-nov (cdr header))))))
 179       'nov)))
 180
 181 (deffoo nnwfm-request-group (group &optional server dont-check)
 182   (nnwfm-possibly-change-server nil server)
 183   (when (not nnwfm-groups)
 184     (nnwfm-request-list))
 185   (unless dont-check
 186     (nnwfm-create-mapping group))
 187   (let ((elem (assoc group nnwfm-groups)))
 188     (cond
 189      ((not elem)
 190       (nnheader-report 'nnwfm "Group does not exist"))
 191      (t
 192       (nnheader-report 'nnwfm "Opened group %s" group)
 193       (nnheader-insert
 194        "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
 195        (prin1-to-string group))))))
 196
 197 (deffoo nnwfm-request-close ()
 198   (setq nnwfm-groups-alist nil
 199         nnwfm-groups nil))
 200
 201 (deffoo nnwfm-request-article (article &optional group server buffer)
 202   (nnwfm-possibly-change-server group server)
 203   (let ((contents (cdr (assq article nnwfm-articles))))
 204     (when (setq contents (nth 2 (car contents)))
 205       (save-excursion
 206         (set-buffer (or buffer nntp-server-buffer))
 207         (erase-buffer)
 208         (nnweb-insert-html contents)
 209         (goto-char (point-min))
 210         (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
 211         (let ((header (cdr (assq article nnwfm-headers))))
 212           (mm-with-unibyte-current-buffer
 213             (nnheader-insert-header header)))
 214         (nnheader-report 'nnwfm "Fetched article %s" article)
 215         (cons group article)))))
 216
 217 (deffoo nnwfm-request-list (&optional server)
 218   (nnwfm-possibly-change-server nil server)
 219   (mm-with-unibyte-buffer
 220     (nnweb-insert
 221      (if (string-match "/$" nnwfm-address)
 222          (concat nnwfm-address "Group.asp")
 223        nnwfm-address))
 224     (let* ((nnwfm-table-regexp "Thread.asp")
 225            (contents (w3-parse-buffer (current-buffer)))
 226            sid elem description articles a href group forum
 227            a1 a2)
 228       (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table
 229                                             contents))))))
 230         (setq row (nth 2 row))
 231         (when (setq a (nnweb-parse-find 'a row))
 232           (setq group (car (last (nnweb-text a)))
 233                 href (cdr (assq 'href (nth 1 a))))
 234           (setq description (car (last (nnweb-text (nth 1 row)))))
 235           (setq articles
 236                 (string-to-number
 237                  (nnweb-replace-in-string
 238                   (car (last (nnweb-text (nth 3 row)))) "," "")))
 239           (when (and href
 240                      (string-match "GroupId=\\([0-9]+\\)" href))
 241             (setq forum (string-to-number (match-string 1 href)))
 242             (if (setq elem (assoc group nnwfm-groups))
 243                 (setcar (cdr elem) articles)
 244               (push (list group articles forum description nil nil nil nil)
 245                     nnwfm-groups))))))
 246     (nnwfm-write-groups)
 247     (nnwfm-generate-active)
 248     t))
 249
 250 (deffoo nnwfm-request-newgroups (date &optional server)
 251   (nnwfm-possibly-change-server nil server)
 252   (nnwfm-generate-active)
 253   t)
 254
 255 (nnoo-define-skeleton nnwfm)
 256
 257 ;;; Internal functions
 258
 259 (defun nnwfm-new-threads-p (group time)
 260   "See whether we want to fetch the threads for GROUP written before TIME."
 261   (let ((old-time (nth 7 (assoc group nnwfm-groups))))
 262     (or (null old-time)
 263         (time-less-p old-time time))))
 264
 265 (defun nnwfm-create-mapping (group)
 266   (let* ((entry (assoc group nnwfm-groups))
 267          (sid (nth 2 entry))
 268          (topics (nth 4 entry))
 269          (mapping (nth 5 entry))
 270          (old-total (or (nth 6 entry) 1))
 271          (current-time (current-time))
 272          (nnwfm-table-regexp "Thread.asp")
 273          (furls (list (concat nnwfm-address
 274                               (format "Thread.asp?GroupId=%d" sid))))
 275          fetched-urls
 276          contents forum-contents a subject href
 277          garticles topic tinfo old-max inc parse elem date
 278          url time)
 279     (mm-with-unibyte-buffer
 280       (while furls
 281         (erase-buffer)
 282         (push (car furls) fetched-urls)
 283         (nnweb-insert (pop furls))
 284         (goto-char (point-min))
 285         (while (re-search-forward "  wr(" nil t)
 286           (forward-char -1)
 287           (setq elem (message-tokenize-header
 288                       (nnweb-replace-in-string
 289                        (buffer-substring
 290                         (1+ (point))
 291                         (progn
 292                           (forward-sexp 1)
 293                           (1- (point))))
 294                        "\\\\[\"\\\\]" "")))
 295           (push (list
 296                  (string-to-number (nth 1 elem))
 297                  (nnweb-replace-in-string (nth 2 elem) "\"" "")
 298                  (string-to-number (nth 5 elem)))
 299                 forum-contents))
 300         (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)"
 301                                  nil t)
 302           (setq url (match-string 1)
 303                 time (nnwfm-date-to-time (url-unhex-string (match-string 2))))
 304           (when (and (nnwfm-new-threads-p group time)
 305                      (not (member
 306                            (setq url (concat
 307                                       nnwfm-address
 308                                       (nnweb-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 ;;; nnwfm.el ends here