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 2, 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
483