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

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