From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 31 Dec 1998 04:25:04 +0000 (+0000)
Subject: Add ability to specify a proxy for a NNTP server.
X-Git-Tag: 20090517-FFI~4704
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7c6d47adef147b3a30c021a382e6aff3f6d6fded;p=mit-scheme.git

Add ability to specify a proxy for a NNTP server.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 4e8b7f017..f8f0c1e47 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.229 1998/12/29 04:09:50 cph Exp $
+$Id: edwin.pkg,v 1.230 1998/12/31 04:25:04 cph Exp $
 
 Copyright (c) 1989-98 Massachusetts Institute of Technology
 
@@ -1759,6 +1759,7 @@ MIT in each case. |#
 	  edwin-variable$news-server-mode-hook
 	  edwin-variable$news-server-name-appearance
 	  edwin-variable$news-server-offline-timeout
+	  edwin-variable$news-server-proxy-alist
 	  edwin-variable$news-show-nonexistent-groups
 	  edwin-variable$news-show-unsubscribed-groups
 	  edwin-variable$news-sort-groups
diff --git a/v7/src/edwin/nntp.scm b/v7/src/edwin/nntp.scm
index 70a0c85f6..adf83965c 100644
--- a/v7/src/edwin/nntp.scm
+++ b/v7/src/edwin/nntp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: nntp.scm,v 1.20 1998/12/29 04:07:48 cph Exp $
+;;;	$Id: nntp.scm,v 1.21 1998/12/31 04:24:50 cph Exp $
 ;;;
 ;;;	Copyright (c) 1995-98 Massachusetts Institute of Technology
 ;;;
@@ -62,8 +62,10 @@
 
 (define-structure (nntp-connection
 		   (conc-name nntp-connection:)
-		   (constructor make-nntp-connection (server change-hook)))
+		   (constructor make-nntp-connection
+				(server proxy change-hook)))
   (server #f read-only #t)
+  (proxy #f read-only #t)
   (change-hook #f read-only #t)
   (port #f)
   (banner #f)
@@ -78,7 +80,8 @@
 			"... ")))
     (message msg)
     (let ((port
-	   (open-tcp-stream-socket (nntp-connection:server connection)
+	   (open-tcp-stream-socket (or (nntp-connection:proxy connection)
+				       (nntp-connection:server connection))
 				   "nntp"
 				   nntp-socket-buffer-size)))
       (set-nntp-connection:port! connection port)
diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm
index 97526c37b..42f7c28e0 100644
--- a/v7/src/edwin/snr.scm
+++ b/v7/src/edwin/snr.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: snr.scm,v 1.47 1998/12/29 04:08:26 cph Exp $
+;;;	$Id: snr.scm,v 1.48 1998/12/31 04:24:56 cph Exp $
 ;;;
 ;;;	Copyright (c) 1995-98 Massachusetts Institute of Technology
 ;;;
@@ -67,6 +67,19 @@ This has three possible values:
   'NONE
   (lambda (object) (memq object '(NONE FULL HOST-ONLY))))
 
+(define-variable news-server-proxy-alist
+  "Alist mapping news servers to associated proxies.
+Each entry in the list is a pair of strings:
+ the car of the entry is the FQDN of a news server;
+ the cdr of the entry is the FQDN of a proxy for that server."
+  '()
+  (lambda (object)
+    (list-of-type? object
+      (lambda (entry)
+	(and (pair? entry)
+	     (string? (car entry))
+	     (string? (cdr entry)))))))
+
 (define-variable news-server-initial-refresh
   "Switch controlling whether News groups are refreshed when reader starts.
 If false (the default), groups are initially listed with the estimates
@@ -263,11 +276,10 @@ The default value of this variable is (SUBSCRIBED (HEADERS BODIES))."
 	     (eq? 'ALL (car object))
 	     (list-of-strings? (car object)))
 	 (pair? (cdr object))
-	 (and (list? (cadr object))
-	      (for-all? (cadr object)
-		(lambda (element)
-		  (or (eq? 'HEADERS element)
-		      (eq? 'BODIES element)))))
+	 (list-of-type? (cadr object)
+	   (lambda (element)
+	     (or (eq? 'HEADERS element)
+		 (eq? 'BODIES element))))
 	 (null? (cddr object)))))
 
 (define-command rnews
@@ -364,12 +376,12 @@ Only one News reader may be open per server; if a previous News reader
 (define (news-buffer-name server prefix)
   (case (ref-variable news-server-name-appearance #f)
     ((HOST-ONLY)
-      (string-append prefix
-		     ":"
-		     (let ((dot (string-find-next-char server #\.)))
-		       (if dot
-			   (string-head server dot)
-			   server))))
+     (string-append prefix
+		    ":"
+		    (let ((dot (string-find-next-char server #\.)))
+		      (if dot
+			  (string-head server dot)
+			  server))))
     ((FULL) (string-append prefix ":" server))
     (else prefix)))
 
@@ -387,8 +399,7 @@ Only one News reader may be open per server; if a previous News reader
     (lambda (buffer)
       (add-kill-buffer-hook buffer news-server-buffer:kill)
       (buffer-put! buffer 'NNTP-CONNECTION
-		   (make-nntp-connection server
-					 update-nntp-connection-modeline!))
+		   (make-nntp-connection-1 server buffer))
       (let ((sort? (ref-variable news-sort-groups buffer)))
 	(let ((groups
 	       (let ((groups
@@ -451,6 +462,14 @@ Only one News reader may be open per server; if a previous News reader
 (define (news-server-buffer:close-connection buffer)
   (nntp-connection:close (news-server-buffer:connection buffer)))
 
+(define (make-nntp-connection-1 server buffer)
+  (make-nntp-connection
+   server
+   (let ((entry (assoc server (ref-variable news-server-proxy-alist buffer))))
+     (and entry
+	  (cdr entry)))
+   update-nntp-connection-modeline!))
+
 (define (news-server-buffer:save-groups buffer)
   (write-groups-init-file buffer)
   (for-each-vector-element (news-server-buffer:groups buffer)
@@ -2981,9 +3000,7 @@ C-c C-q  mail-fill-yanked-message (fill what was yanked)."
       (let ((server-buffer (find-news-server-buffer server)))
 	(if server-buffer
 	    (do-it (news-server-buffer:connection server-buffer))
-	    (let ((connection
-		   (make-nntp-connection server
-					 update-nntp-connection-modeline!)))
+	    (let ((connection (make-nntp-connection-1 server lookup-buffer)))
 	      (let ((result (do-it connection)))
 		(nntp-connection:close connection)
 		result)))))))