lisp/gnus/nnultimate.el

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