From 6e84de6e7bff9079d0b6ba62a3c85d2eb98f2eb4 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 11 Jul 2003 07:03:03 +0000
Subject: [PATCH] r5284: *** empty log message ***

---
 debian/changelog   |  6 +++
 kmrcl.asd          |  4 +-
 listener.lisp      | 91 +++++++++++++++++++++++++------------------
 macros.lisp        |  6 ++-
 package.lisp       |  8 ++--
 repl.lisp          | 96 ++++++++++++++++++++++++++++++++++++++++++++++
 sockets.lisp       | 75 ++++++++++++++++++++++++------------
 telnet-server.lisp | 96 ----------------------------------------------
 8 files changed, 217 insertions(+), 165 deletions(-)
 create mode 100644 repl.lisp
 delete mode 100644 telnet-server.lisp

diff --git a/debian/changelog b/debian/changelog
index 5bd6d3d..4ab1bc8 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-kmrcl (1.54-1) unstable; urgency=low
+
+  * listener and repl improvements
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri, 11 Jul 2003 01:01:11 -0600
+
 cl-kmrcl (1.53-1) unstable; urgency=low
 
   * Listener improvements
diff --git a/kmrcl.asd b/kmrcl.asd
index 34bde48..6216a71 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.39 2003/07/09 19:19:19 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.40 2003/07/11 06:58:32 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -53,7 +53,7 @@
      (:file "sockets" :depends-on ("macros"))
      (:file "processes" :depends-on ("macros"))
      (:file "listener" :depends-on ("sockets" "processes"))
-     (:file "telnet-server" :depends-on ("listener"))
+     (:file "repl" :depends-on ("listener" "strings"))
      ))
 
 
diff --git a/listener.lisp b/listener.lisp
index dfd70f4..19c7b0c 100644
--- a/listener.lisp
+++ b/listener.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id: listener.lisp,v 1.4 2003/07/11 02:37:33 kevin Exp $
+;;;; $Id: listener.lisp,v 1.5 2003/07/11 06:58:32 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:kmrcl)
@@ -40,6 +40,8 @@
    (number-fixed-workers :initform nil :accessor number-fixed-workers
 			 :initarg :number-fixed-workers)
    (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
+   (remote-host-checker :initform nil :accessor remote-host-checker
+			:initarg :remote-host-checker)
    (format :initform :text :accessor listener-format :initarg :format)))
 
 (defclass fixed-worker ()
@@ -176,25 +178,36 @@
 		  (setf (workers listener)
 			(remove self (workers listener)))))))))
 
+(defun accept-and-check-tcp-connection (listener)
+  (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener))
+    (when (and (remote-host-checker listener)
+	       (not (funcall (remote-host-checker listener)
+			     (remote-host socket))))
+      (cmsg-c :thread "Deny connection from ~A" (remote-host conn))
+      (errorset (close-active-socket conn) nil)
+      (setq conn nil))
+    conn))
+
 (defun start-socket-server (listener)
   (unwind-protect
       (loop 
-       (let ((connection (accept-tcp-connection (socket listener))))
-	 (if (wait listener)
-	     (unwind-protect
-		  (apply (listener-function listener)
-			 connection
-			 (function-args listener))
-	       (progn
-		 (errorset (finish-output connection) nil)
-		 (errorset (close-active-socket connection) nil)))
-	     (let ((worker (make-instance 'worker :listener listener
-					  :connection connection
-					  :name (next-worker-name
-						 (base-name listener)))))
-	       (setf (process worker)
-		     (make-process (name worker) (thread-fun worker)))
-	       (push worker (workers listener))))))
+       (let ((connection (accept-and-check-tcp-connection listener)))
+	 (when connection
+	   (if (wait listener)
+	       (unwind-protect
+		    (apply (listener-function listener)
+			   connection
+			   (function-args listener))
+		 (progn
+		   (errorset (finish-output connection) nil)
+		   (errorset (close-active-socket connection) nil)))
+	       (let ((worker (make-instance 'worker :listener listener
+					    :connection connection
+					    :name (next-worker-name
+						   (base-name listener)))))
+		 (setf (process worker)
+		       (make-process (name worker) (thread-fun worker)))
+		 (push worker (workers listener)))))))
     (errorset (close-passive-socket (socket listener)) nil)))
 
 #+lispworks
@@ -234,26 +247,28 @@
 
 (defun fixed-worker (name listener)
   (loop 
-   (let ((connection (accept-tcp-connection (socket listener))))
-     (flet ((do-work ()
-	      (apply (listener-function listener)
-		     connection
-		     (function-args listener))))
-       (unwind-protect
-	    (handler-case
-		(if (catch-errors listener)
-		    (handler-case
-			(if (timeout listener)
-			    (with-timeout ((timeout listener))
+   (let ((connection (accept-and-check-tcp-connection listener)))
+     (when connection
+       (flet ((do-work ()
+		(apply (listener-function listener)
+		       connection
+		       (function-args listener))))
+	 (unwind-protect
+	      (handler-case
+		  (if (catch-errors listener)
+		      (handler-case
+			  (if (timeout listener)
+			      (with-timeout ((timeout listener))
+				(do-work))
 			      (do-work))
+			(error (e)
+			  (cmsg "Error ~A [~A]" e name)))
+		      (if (timeout listener)
+			  (with-timeout ((timeout listener))
 			    (do-work))
-		      (error (e)
-			(cmsg "Error ~A [~A]" e name)))
-		    (if (timeout listener)
-			(with-timeout ((timeout listener))
-			  (do-work))
-			(do-work)))
-	      (error (e)
-		(format t "Error: ~A" e)))
-	 (errorset (finish-output connection) nil)
-	 (errorset (close connection) nil))))))
+			  (do-work)))
+		(error (e)
+		  (format t "Error: ~A" e)))
+	   (errorset (finish-output connection) nil)
+	   (errorset (close connection) nil)))))))
+  
diff --git a/macros.lisp b/macros.lisp
index 03e3a9f..1697dca 100644
--- a/macros.lisp
+++ b/macros.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: macros.lisp,v 1.2 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id: macros.lisp,v 1.3 2003/07/11 06:58:32 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -164,3 +164,7 @@
 	     (print-seconds secs)
 	     (format t ", time per iteration: ")
 	     (print-seconds (coerce (/ secs ,n) 'double-float))))))))
+
+(defmacro mv-bind (vars form &body body)
+  `(multiple-value-bind ,vars ,form 
+     ,@body))
diff --git a/package.lisp b/package.lisp
index ff337e9..754aef5 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.48 2003/07/09 19:19:19 kevin Exp $
+;;;; $Id: package.lisp,v 1.49 2003/07/11 06:58:32 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -112,6 +112,7 @@
    #:alambda
    #:it
    #:mac
+   #:mv-bind
    
    ;; files.lisp
    #:print-file-contents
@@ -170,8 +171,9 @@
    #:seed-random-generator
    #:random-choice
    
-   ;; From telnet-server.lisp
-   #:start-telnet-server	  
+   ;; From repl.lisp
+   #:make-repl
+   #:init/repl
    
    ;; From web-utils
    #:*base-url*
diff --git a/repl.lisp b/repl.lisp
new file mode 100644
index 0000000..2675426
--- /dev/null
+++ b/repl.lisp
@@ -0,0 +1,96 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          repl.lisp
+;;;; Purpose:       A repl server
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: repl.lisp,v 1.1 2003/07/11 06:58:32 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defconstant +default-repl-server-port+ 4000)
+
+(defclass repl ()
+  ((listener :initarg :listener :accessor listener
+	     :initform nil)))
+
+(defun make-repl (&key (port +default-repl-server-port+)
+		       announce user-checker remote-host-checker)
+  (make-instance 'listener 
+    :port port
+    :base-name "repl"			 
+    :function 'repl-worker
+    :function-args (list user-checker announce)
+    :format :text
+    :wait nil
+    :remote-host-checker remote-host-checker
+    :catch-errors nil))
+
+(defun init/repl (repl state)
+  (init/listener repl state))
+
+
+(defun repl-worker (conn user-checker announce)
+  (when announce
+    (format conn "~A~%" announce)
+    (force-output conn))
+  (when user-checker
+    (let (login password)
+      (format conn "login: ")
+      (finish-output conn)
+      (setq login (read-socket-line conn))
+      (format conn "password: ")
+      (finish-output conn)
+      (setq password (read-socket-line conn))
+      (unless (funcall user-checker login password)
+	(format conn "Invalid login~%")
+	(finish-output conn)
+	(return-from repl-worker))))
+  #+allegro
+  (tpl::start-interactive-top-level
+   conn
+   #'tpl::top-level-read-eval-print-loop
+   nil)
+  #-allegro
+  (repl-on-stream conn)
+  )
+
+(defun read-socket-line (stream)
+  (string-right-trim-one-char #\return
+			      (read-line stream nil nil)))
+
+(defun print-prompt (stream)
+  (format stream "~&~A> " (package-name *package*))
+  (force-output stream))
+
+(defun repl-on-stream (stream)
+  (let ((*standard-input* stream)
+	(*standard-output* stream)
+	(*terminal-io* stream)
+	(*debug-io* stream))
+    #|
+    #+sbcl
+    (if (and (find-package 'sb-aclrepl)
+	     (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
+	(sb-aclrepl::repl-fun)
+	(%repl))
+    #-sbcl
+    |#
+    (%repl)))
+
+(defun %repl ()
+  (loop
+    (print-prompt *standard-output*)
+    (let ((form (read *standard-input*)))
+      (format *standard-output* "~&~S~%" (eval form)))))
+  
diff --git a/sockets.lisp b/sockets.lisp
index 6af47d8..259b7b0 100644
--- a/sockets.lisp
+++ b/sockets.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg with excerpts from portableaserve
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id: sockets.lisp,v 1.3 2003/07/10 18:52:10 kevin Exp $
+;;;; $Id: sockets.lisp,v 1.4 2003/07/11 06:58:32 kevin Exp $
 ;;;; *************************************************************************
 
 (in-package #:kmrcl)
@@ -63,23 +63,26 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (defun accept-tcp-connection (listener)
+  "Returns (VALUES stream socket)"
   #+allegro
-  (socket:accept-connection listener)
+  (let ((sock (socket:accept-connection listener)))
+    (values sock sock))
   #+clisp
-  (ext:socket-accept listener)
+  (let ((sock (ext:socket-accept listener)))
+    (value sock sock))
   #+cmu
   (progn
     (mp:process-wait-until-fd-usable listener :input)
-    (sys:make-fd-stream
-     (nth-value 0 (ext:accept-tcp-connection listener))
-     :input t :output t))
+    (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
+      (values (sys:make-fd-stream sock :input t :output t) sock)))
   #+sbcl
   (when (sb-sys:wait-until-fd-usable
 	 (sb-bsd-sockets:socket-file-descriptor listener) :input)
-    (sb-bsd-sockets:socket-make-stream 
-     (sb-bsd-sockets:socket-accept listener)
-     :element-type 'base-char
-     :input t :output t))
+    (let ((sock (sb-bsd-sockets:socket-accept listener)))
+      (values
+       (sb-bsd-sockets:socket-make-stream
+	sock :element-type 'base-char :input t :output t)
+       sock)))
   #-(or allegro clisp cmu sbcl)
   (warn "accept-tcp-connection not supported on this implementation")
   )
@@ -151,19 +154,41 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (defun make-active-socket (server port)
-  #+allegro (socket:make-socket :remote-host server
-				:remote-port port)
-  #+lispworks (comm:open-tcp-stream server port)
-  #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
-				      :type :stream
-				      :protocol :tcp)))
-	   (sb-bsd-sockets:socket-connect
-	    socket (lookup-hostname server) port)
-	   (sb-bsd-sockets:socket-make-stream socket
-					      :input t
-					      :output t
-					      :element-type 'base-char))
-  #+cmu 
-  (sys:make-fd-stream (ext:connect-to-inet-socket host port)
-		      :input t :output t :element-type 'base-char)
+  "Returns (VALUES STREAM SOCKET)"
+  #+allegro
+  (let ((sock (socket:make-socket :remote-host server
+				  :remote-port port)))
+    (values sock sock))
+  #+lispworks
+  (let ((sock (comm:open-tcp-stream server port)))
+    (values sock sock))
+  #+sbcl
+  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
+			     :type :stream
+			     :protocol :tcp)))
+    (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
+    (values
+     (sb-bsd-sockets:socket-make-stream
+      sock :input t :output t :element-type 'base-char)
+     sock))
+  #+cmu
+  (let ((sock (ext:connect-to-inet-socket host port)))
+    (values
+     (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
+     sock))
+  )
+
+(defun ipaddr-array-to-dotted (array)
+  (format nil "~{~D~^.~}" (coerce array 'list))
+  #+ignore
+  (format nil "~D.~D.~D.~D" 
+	  (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
+
+(defun remote-host (socket)
+  #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
+  #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
+  #+sbcl (ipaddr-array-to-dotted 
+	  (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
+  #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
   )
+  
diff --git a/telnet-server.lisp b/telnet-server.lisp
deleted file mode 100644
index 210943a..0000000
--- a/telnet-server.lisp
+++ /dev/null
@@ -1,96 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          telnet-server.lisp
-;;;; Purpose:       A telnet server
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Apr 2000
-;;;;
-;;;; $Id: telnet-server.lisp,v 1.7 2003/07/09 22:12:52 kevin Exp $
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; KMRCL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :kmrcl)
-
-(defconstant +default-telnet-server-port+ 4000)
-
-(defclass telnetd ()
-  ((listener :initarg :listener :accessor listener
-	     :initform nil)))
-
-(defun start-telnet-server (&key (port +default-telnet-server-port+)
-			    announce users)
-  (let ((listener (make-instance 'listener :port port
-				 :base-name "telnetd"			 
-				 :function 'telnet-worker
-				 :function-args (list users announce)
-				 :format :text
-				 :wait nil
-				 :catch-errors nil)))
-    (init/listener listener :start)))
-
-
-(defun stop-telnet-server (listener)
-  (init/listener listener :stop))
-
-(defun user-authenticated (user-name password users)
-  (some #'(lambda (user-pass)
-	    (and (string= user-name (car user-pass))
-		 (string= password (cdr user-pass))))
-	users))
-
-(defun telnet-worker (conn users announce)
-  (when announce
-    (format conn "~A~%" announce)
-    (force-output conn))
-  (when users
-    (let (user-name password)
-      (format conn "login: ")
-      (force-output conn)
-      (setq user-name (read-telnet-line conn))
-      (format conn "password: ")
-      (force-output conn)
-      (setq password (read-telnet-line conn))
-      (unless (user-authenticated user-name password users)
-	(format conn "Invalid login~%")
-	(force-output conn)
-	(return-from telnet-worker))))
-  ;;#+allegro
-  #+ignore
-  (tpl::start-interactive-top-level
-   conn
-   #'tpl::top-level-read-eval-print-loop
-   nil)
-  #+sbcl
-  ;; FIXME -- use aclrepl
-  (telnet-on-stream conn)
-  ;;#-(or sbcl allegro)
-  (telnet-on-stream conn)
-  )
-
-(defun read-telnet-line (stream)
-  (string-right-trim-one-char #\return
-			      (read-line stream nil nil)))
-
-(defun print-prompt (stream)
-  (format stream "~&~A> " (package-name *package*))
-  (force-output stream))
-
-(defvar *telnet-password* "")
-
-(defun telnet-on-stream (stream)
-  (let ((*standard-input* stream)
-	(*standard-output* stream)
-	(*terminal-io* stream)
-	(*debug-io* stream))
-    (loop
-     (print-prompt stream)
-     (let ((form (read stream)))
-       (fresh-line stream)
-       (format stream "~S~%" (eval form))))))
-- 
2.34.1