From mboxrd@z Thu Jan  1 00:00:00 1970
X-Msuck: nntp://news.gmane.io/gmane.emacs.gnus.general/26546
Path: main.gmane.org!not-for-mail
From: Shenghuo ZHU <zsh@cs.rochester.edu>
Newsgroups: gmane.emacs.gnus.general
Subject: Re: Announce: nnwarchive
Date: 09 Nov 1999 14:12:31 -0500
Organization: U of Rochester
Sender: owner-ding@hpc.uh.edu
Message-ID: <5biu3btr6o.fsf@giga.cs.rochester.edu>
References: <5biu3bd2dh.fsf@giga.cs.rochester.edu>
NNTP-Posting-Host: coloc-standby.netfonds.no
Mime-Version: 1.0
Content-Type: multipart/mixed; boundary="=-=-="
X-Trace: main.gmane.org 1035163734 19944 80.91.224.250 (21 Oct 2002 01:28:54 GMT)
X-Complaints-To: usenet@main.gmane.org
NNTP-Posting-Date: Mon, 21 Oct 2002 01:28:54 +0000 (UTC)
Return-Path: <owner-ding@hpc.uh.edu>
Original-Received: from lisa.math.uh.edu (lisa.math.uh.edu [129.7.128.49])
	by sclp3.sclp.com (8.8.5/8.8.5) with ESMTP id OAA21389
	for <jason@mailhost.sclp.com>; Tue, 9 Nov 1999 14:13:41 -0500 (EST)
Original-Received: from sina.hpc.uh.edu (lists@Sina.HPC.UH.EDU [129.7.3.5])
	by lisa.math.uh.edu (8.9.1/8.9.1) with ESMTP id NAB22730;
	Tue, 9 Nov 1999 13:13:37 -0600 (CST)
Original-Received: by sina.hpc.uh.edu (TLB v0.09a (1.20 tibbs 1996/10/09 22:03:07)); Tue, 09 Nov 1999 13:13:51 -0600 (CST)
Original-Received: from sclp3.sclp.com (root@sclp3.sclp.com [204.252.123.139])
	by sina.hpc.uh.edu (8.9.3/8.9.3) with ESMTP id NAA04970
	for <ding@hpc.uh.edu>; Tue, 9 Nov 1999 13:13:29 -0600 (CST)
Original-Received: from cayuga.cs.rochester.edu (cayuga.cs.rochester.edu [192.5.53.209])
	by sclp3.sclp.com (8.8.5/8.8.5) with ESMTP id OAA21380
	for <ding@gnus.org>; Tue, 9 Nov 1999 14:12:35 -0500 (EST)
Original-Received: from giga.cs.rochester.edu (giga.cs.rochester.edu [192.5.53.186]) by cayuga.cs.rochester.edu (8.9.3/Q) with ESMTP id OAA29476 for <ding@gnus.org>; Tue, 9 Nov 1999 14:12:32 -0500 (EST)
Original-Received: (from zsh@localhost) by giga.cs.rochester.edu (8.9.1b+Sun/Q++) id OAA09241; Tue, 9 Nov 1999 14:12:31 -0500 (EST)
Original-To: ding@gnus.org
X-Attribution: ZSH
X-Face: 'IF:e51ib'Qbl^(}l^&4-J`'P!@[4~O|&k#:@Gld#b/]oMq&`&FVY._3+b`mzp~Jeve~/#/
 ERD!OTe<86UhyN=l`mrPY)M7_}`Ktt\K+58Z!hu7>qU,i.N7TotU[FYE(f1;}`g2xj!u*l`^&=Q!g{
 *q|<EDbQtg9{wfQuI,#r#{'A,\!95my:/,]"s,O4nzqxNL.}WrHA>ddto|nkt"$r,K$[)"|6,elPH=
 GJ6Q
In-Reply-To: Shenghuo ZHU's message of "09 Nov 1999 12:02:50 -0500"
Original-Lines: 27
User-Agent: Gnus/5.070099 (Pterodactyl Gnus v0.99) Emacs/20.4
Precedence: list
X-Majordomo: 1.94.jlt7
Xref: main.gmane.org gmane.emacs.gnus.general:26546
X-Report-Spam: http://spam.gmane.org/gmane.emacs.gnus.general:26546


--=-=-=

>>>>> "ZSH" == Shenghuo ZHU <zsh@cs.rochester.edu> writes:

ZSH> I am working on nnwarchive, a backend for web archives of
ZSH> mailing-lists.  Now, it only works with egroups.com. More web
ZSH> archives such as onelist.com, are supposed to be implemented.

I attached the code.

To setup, use the following code.

(defun nnwarchive-load ()
  "Setup nnwarchive."
  (interactive)
  (require 'nnwarchive)
  (setq nnwarchive-login "your@email.address.at.egroups") 
  (setq nnwarchive-passwd "the passwd") 
  (push '("nnwarchive" none)  gnus-valid-select-methods))

Maybe a small bug in w3 0.44. (load-library "url") to make sure
`url-maybe-relative' is using the copy from url.el.

-- 
Shenghuo ZHU


--=-=-=
Content-Type: application/emacs-lisp
Content-Disposition: attachment; filename=nnwarchive.el

;;; nnwarchive.el --- interfacing with web groups
;; Copyright (C) 1999 Shenghuo Zhu

;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: news

;; This file is not part of GNU Emacs yet.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Note: You need to have `url' and `w3' installed for this backend to
;; work.

;; A lot of codes stolen from mail-source, nnslashdot, nnweb.

;; Todo: To support web archives.

;; Known bug: in w3 0.44, there are two copies of url-maybe-relative.
;; If it is loaded from w3.el, (load-library "url").  w3 0.45 should
;; work.

;;; Code:

(eval-when-compile (require 'cl))

(require 'nnoo)
(require 'message)
(require 'gnus-util)
(require 'gnus)
(require 'nnmail)
(require 'mm-util)
(require 'mail-source)
(eval-when-compile
  (ignore-errors
    (require 'w3)
    (require 'url)
    (require 'w3-forms)))
;; Report failure to find w3 at load time if appropriate.
(eval '(progn
	 (require 'w3)
	 (require 'url)
	 (require 'w3-forms)))

(nnoo-declare nnwarchive)

;;eval-and-compile
(defvar nnwarchive-type-definition
  '((egroups
     (open-url 
      "http://www.egroups.com/register?method=loginAction&email=%s&password=%s" 
      login passwd)
     (open-dissect . nnwarchive-egroups-open)
     (list-url 
      "http://www.egroups.com/UserGroupsPage?")
     (list-dissect . nnwarchive-egroups-list)
     (xover-url 
      "http://www.egroups.com/group/%s/?fetchForward=1&start=%d" group start)
     (xover-last-url 
      "http://www.egroups.com/group/%s/?fetchForward=1" group)
     (xover-page-size . 13)
     (xover-dissect . nnwarchive-egroups-xover)
     (article-url 
      "http://www.egroups.com/group/%s/%d.html?raw=1" group article)
     (article-dissect . nnwarchive-egroups-article))))

;;eval-and-compile
(defvar nnwarchive-short-names
  '(login passwd))

(defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/")
  "Where nnwarchive will save its files.")

(defvoo nnwarchive-type 'egroups
  "The type of nnwarchive.")

(defvoo nnwarchive-login nil
  "Your login name for the group.")

(defvoo nnwarchive-passwd nil
  "Your password for the group.")

(defvoo nnwarchive-groups nil)

(defvoo nnwarchive-headers-cache nil)

(defvoo nnwarchive-opened nil)

;;; Internal variables

(defvar nnwarchive-open-url nil)
(defvar nnwarchive-open-dissect nil)

(defvar nnwarchive-list-url nil)
(defvar nnwarchive-list-dissect nil)

(defvar nnwarchive-xover-url nil)
(defvar nnwarchive-xover-last-url nil)
(defvar nnwarchive-xover-dissect nil)
(defvar nnwarchive-xover-page-size nil)

(defvar nnwarchive-article-url nil)
(defvar nnwarchive-article-dissect nil)

(defvar nnwarchive-buffer nil)

(defvar nnwarchive-headers nil)

;;; Interface functions

(nnoo-define-basics nnwarchive)

;; eval-and-compile
(defun nnwarchive-bind-1 ()
  (let ((defaults (cdr (assq nnwarchive-type nnwarchive-type-definition)))
	(short-names nnwarchive-short-names)
	default bind)
    (while (setq default (pop defaults))
      (push (list (intern (concat "nnwarchive-" (symbol-name (car default))))
		  (list 'quote (cdr default))) bind))
    (while (setq default (pop short-names))
      (push (list default
		  (intern (concat "nnwarchive-" 
				  (symbol-name default)))) 
	    bind))
    bind))

(defmacro nnwarchive-bind (&rest body)
  "Return a `let' form that binds all variables in TYPE.
Read `mail-source-bind' for details."
  `(let ,(nnwarchive-bind-1)
     ,@body))

(put 'nnwarchive-bind 'lisp-indent-function 0)
(put 'nnwarchive-bind 'edebug-form-spec '(form body))

(deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old)
  (nnwarchive-possibly-change-server group server)
  (nnwarchive-bind 
    (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
    (save-excursion
      (set-buffer nnwarchive-buffer)
      (erase-buffer)
      (let (point start starts)
	(setq starts (nnwarchive-paged (sort articles '<)))
	(while (setq start (pop starts))
	  (goto-char (point-max))
	  (nnwarchive-url nnwarchive-xover-url))
	(if nnwarchive-xover-dissect
	    (funcall nnwarchive-xover-dissect))))
    (save-excursion
      (set-buffer nntp-server-buffer)
      (erase-buffer)
      (let (header)
	(dolist (art articles)
	  (if (setq header (assq art nnwarchive-headers))
	      (nnheader-insert-nov (cdr header))))))
    (let ((elem (assoc group nnwarchive-headers-cache)))
      (if elem
	  (setcdr elem nnwarchive-headers)
	(push (cons group nnwarchive-headers) nnwarchive-headers-cache)))
    'nov))

(deffoo nnwarchive-request-group (group &optional server dont-check)
  (nnwarchive-possibly-change-server nil server)
  (let ((elem (assoc group nnwarchive-groups)))
    (cond
     ((not elem)
      (nnheader-report 'nnwarchive "Group does not exist"))
     (t
      (nnheader-report 'nnwarchive "Opened group %s" group)
      (nnheader-insert
       "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
       (prin1-to-string group))))))

(deffoo nnwarchive-close-group (group &optional server)
  (nnwarchive-possibly-change-server group server)
  (when (gnus-buffer-live-p nnwarchive-buffer)
    (save-excursion
      (set-buffer nnwarchive-buffer)
      (kill-buffer nnwarchive-buffer)))
  t)

(deffoo nnwarchive-request-article (article &optional group server buffer)
  (nnwarchive-possibly-change-server group server)
  (nnwarchive-bind 
    (let (contents)
      (save-excursion
	(set-buffer nnwarchive-buffer)
	(goto-char (point-min))
	(nnwarchive-url nnwarchive-article-url)
	(setq contents (funcall nnwarchive-article-dissect)))
      (when contents
	(save-excursion
	  (set-buffer (or buffer nntp-server-buffer))
	  (erase-buffer)
	  (insert contents)
	  (nnheader-report 'nnwarchive "Fetched article %s" article)
	  (cons group article))))))

(deffoo nnwarchive-close-server (&optional server)
  (when (and (nnwarchive-server-opened server)
	     (gnus-buffer-live-p nnwarchive-buffer))
    (save-excursion
      (set-buffer nnwarchive-buffer)
      (kill-buffer nnwarchive-buffer)))
  (nnoo-close-server 'nnwarchive server))

(deffoo nnwarchive-request-list (&optional server)
  (nnwarchive-possibly-change-server nil server)
  (nnwarchive-bind
    (save-excursion
      (set-buffer nnwarchive-buffer)
      (erase-buffer)
      (if nnwarchive-list-url
	  (nnwarchive-url nnwarchive-list-url))
      (if nnwarchive-list-dissect
	  (funcall nnwarchive-list-dissect))
      (nnwarchive-write-groups)
      (nnwarchive-generate-active)))
  t)

(deffoo nnwarchive-request-newgroups (date &optional server)
  (nnwarchive-possibly-change-server nil server)
  (nnwarchive-bind
    (nnwarchive-generate-active))
  t)

(deffoo nnwarchive-asynchronous-p ()
  nil)

(deffoo nnwarchive-server-opened (&optional server)
  nnwarchive-opened)

(deffoo nnwarchive-open-server (server &optional defs connectionless)
  (nnwarchive-init server)
  (setq nnwarchive-login
	(or nnwarchive-login
	    (read-string
	     (format "Login at %s: " server)
	     user-mail-address)))
  (setq nnwarchive-passwd
	(or nnwarchive-passwd
	    (mail-source-read-passwd
	     (format "Password for %s at %s: " nnwarchive-login server))))
  (nnwarchive-bind 
    (save-excursion
      (set-buffer nnwarchive-buffer)
      (erase-buffer)
      (if nnwarchive-open-url
	  (nnwarchive-url nnwarchive-open-url))
      (if nnwarchive-open-dissect
	  (funcall nnwarchive-open-dissect)
	(setq nnwarchive-opened t))))
  t)

(nnoo-define-skeleton nnwarchive)

;;; Internal functions

(defun nnwarchive-possibly-change-server (&optional group server)
  (nnwarchive-init server)
  (when (and server
	     (not (nnwarchive-server-opened server)))
    (nnwarchive-open-server server)))

(defun nnwarchive-read-groups ()
  (let ((file (expand-file-name "groups" nnslashdot-directory)))
    (when (file-exists-p file)
      (with-temp-buffer
	(insert-file-contents file)
	(goto-char (point-min))
	(setq nnwarchive-groups (read (current-buffer)))))))

(defun nnwarchive-write-groups ()
  (with-temp-file (expand-file-name "groups" nnwarchive-directory)
    (prin1 nnwarchive-groups (current-buffer))))

(defun nnwarchive-init (server)
  "Initialize buffers and such."
  (unless (file-exists-p nnwarchive-directory)
    (gnus-make-directory nnwarchive-directory))
  (unless (gnus-buffer-live-p nnwarchive-buffer)
    (setq nnwarchive-buffer
	  (save-excursion
	    (nnheader-set-temp-buffer
	     (format " *nnwarchive %s %s*" nnwarchive-type server))))))

(defun nnwarchive-encode-www-form-urlencoded (pairs)
  "Return PAIRS encoded for forms."
  (mapconcat
   (function
    (lambda (data)
      (concat (w3-form-encode-xwfu (car data)) "="
	      (w3-form-encode-xwfu (cdr data)))))
   pairs "&"))

(defun nnwarchive-fetch-form (url pairs)
  (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs))
	(url-request-method "POST")
	(url-request-extra-headers
	 '(("Content-type" . "application/x-www-form-urlencoded"))))
    (url-insert-file-contents url)
    (setq buffer-file-name t))
  t)

(defun nnwarchive-eval (expr)
  (cond
   ((consp expr)
    (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
   ((symbolp expr)
    (eval expr))
   (t
    expr)))

(defun nnwarchive-url (xurl)
  (let ((url-confirmation-func 'ignore))
    (condition-case err
	(cond 
	 ((eq (car xurl) 'post)
	  (pop xurl)
	  (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
	 (t
	  (url-insert-file-contents (apply 'format (nnwarchive-eval xurl)))
	  (setq buffer-file-name nil)))
      (error nil))))

(defun nnwarchive-decode-entities ()
  (goto-char (point-min))
  (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
    (replace-match (char-to-string 
		    (if (eq (aref (match-string 1) 0) ?\#)
			(string-to-number (substring (match-string 1) 1))
		      (or (cdr (assq (intern (match-string 1))
				     w3-html-entities))
			  ?#)))
		   t t)))

(defun nnwarchive-decode-entities-string (str)
  (with-temp-buffer
    (insert str)
    (nnwarchive-decode-entities)
    (buffer-substring (point-min) (point-max))))

(defun nnwarchive-remove-markup ()
  (goto-char (point-min))
  (while (search-forward "<!--" nil t)
    (delete-region (match-beginning 0)
		   (or (search-forward "-->" nil t)
		       (point-max))))
  (goto-char (point-min))
  (while (re-search-forward "<[^>]+>" nil t)
    (replace-match "" t t)))

(defun nnwarchive-date-to-date (sdate)
  (let ((elem (split-string sdate)))
    (concat (substring (nth 0 elem) 0 3) " "
	    (substring (nth 1 elem) 0 3) " "
	    (substring (nth 2 elem) 0 2) " "
	    (substring (nth 3 elem) 1 6) " "
	    (format-time-string "%Y") " "
	    (nth 4 elem))))

(defun nnwarchive-generate-active ()
  (save-excursion
    (set-buffer nntp-server-buffer)
    (erase-buffer)
    (dolist (elem nnwarchive-groups)
      (insert (prin1-to-string (car elem))
	      " " (number-to-string (cadr elem)) " 1 y\n"))))

(defun nnwarchive-paged (articles)
  (let (art narts next)
    (while (setq art (pop articles))
      (when (and (>= art (or next 0))
		 (not (assq art nnwarchive-headers)))
	(push art narts)
	(setq next (+ art nnwarchive-xover-page-size))))
    narts))

;; egroups

(defun nnwarchive-egroups-open ()
  (setq nnwarchive-opened t))

(defun nnwarchive-egroups-list ()
  (let ((case-fold-search t)
	group description elem articles)
    (goto-char (point-min))
    (while 
	(re-search-forward
	 "/group/\\([^/]+\\)/info\\.html[^>]+>[^>]+>[\040\t]*-[\040\t]*\\([^<]+\\)<"
	 nil t)
      (setq group (match-string 1)
	    description (match-string 2))
      (forward-line 1)
      (when (re-search-forward ">\\([0-9]+\\)<" nil t)
	(setq articles (string-to-number (match-string 1)))) 
      (if (setq elem (assoc group nnwarchive-groups))
	  (setcar (cdr elem) articles)
	(push (list group articles description) nnwarchive-groups)))
    (dolist (elem nnwarchive-groups) 
      (setq group (car elem))
      (erase-buffer)
      (nnwarchive-url nnwarchive-xover-last-url)
      (goto-char (point-min))
      (when (re-search-forward "of \\([0-9]+\\)</title>" nil t)
	(setq articles (string-to-number (match-string 1)))) 
      (setcar (cdr elem) articles)
      (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
      (nnwarchive-egroups-xover)
      (let ((elem (assoc group nnwarchive-headers-cache)))
	(if elem
	    (setcdr elem nnwarchive-headers)
	  (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))))
  t)

(defun nnwarchive-egroups-xover()
  (let (article subject from date group)
    (goto-char (point-min))
    (while (re-search-forward
	    "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
	    nil t)
	  (setq group  (match-string 1)
		article (string-to-number (match-string 2))
		subject (match-string 3))
	  (forward-line 1)
	  (unless (assq article nnwarchive-headers)
	    (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
		(setq from (match-string 1)))
	    (forward-line 1)
	    (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
		(setq date (identity (match-string 1))))
	    (push (cons
		   article
		   (make-full-mail-header
		    article 
		    (nnwarchive-decode-entities-string subject)
		    (nnwarchive-decode-entities-string from)
		    date
		    (concat "<" group "%"
			    (number-to-string article) 
			    "@egroup.com>")
		    ""
		    0 nil nil nil)) nnwarchive-headers))))
  nnwarchive-headers)

(defun nnwarchive-egroups-article ()
  (goto-char (point-min))
  (if (search-forward "<pre>" nil t)
      (delete-region (point-min) (point)))
  (goto-char (point-max))
  (if (search-backward "</pre>" nil t)
      (delete-region (point) (point-max)))
  (goto-char (point-min))
  (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
    (replace-match "<\\1>"))
  (nnwarchive-decode-entities)
  (buffer-substring (point-min) (point-max)))

;; move to gnus-group.el
(defvar gnus-group-warchive-type-history nil)
(defvar gnus-group-warchive-login-history nil)
(defvar gnus-group-warchive-server-history "")

(defun gnus-group-make-warchive-group ()
  "Create a nnwarchive group."
  (interactive)
  (require 'nnwarchive)
  (let* ((group (gnus-read-group "Group name: "))
	 (default-type (or (car gnus-group-warchive-type-history)
			   (symbol-name (caar nnwarchive-type-definition))))
	 (type
	  (gnus-string-or
	   (completing-read
	    (format "Warchive type (default %s): " default-type)
	    (mapcar (lambda (elem) (list (symbol-name (car elem))))
		    nnwarchive-type-definition)
	    nil t nil 'gnus-group-warchive-type-history)
	   default-type))
	 (server (read-string
		  (format "Warchive server: " )
		  nil 'gnus-group-warchive-server-history))
	 (default-login (or (car gnus-group-warchive-login-history)
			    user-mail-address))
	 (login
	  (gnus-string-or
	   (read-string
	    (format "Warchive login (default %s): " user-mail-address)
	    default-login 'gnus-group-warchive-login-history)
	   user-mail-address))
	 (method
	  `(nnwarchive ,server 
		  (nnwarchive-type ,(intern type))
		  (nnwarchive-login ,login)
		  )))
    (gnus-group-make-group group method)))

(provide 'nnwarchive)

;;; nnwarchive.el ends here

--=-=-=



--=-=-=--