X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=telnet-server.lisp;h=210943a23c8eed2ea1f9d1e0199c5e0b57ab9960;hp=6be5c68b6a87e9d703657c75d50289d7f570bd09;hb=0ddc73d14e764eeaede64f92b620a0c6de46cfd3;hpb=30b4f8d91af2bb031e8d4ef7d5a38492739de2bf

diff --git a/telnet-server.lisp b/telnet-server.lisp
index 6be5c68..210943a 100644
--- a/telnet-server.lisp
+++ b/telnet-server.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: telnet-server.lisp,v 1.4 2002/10/10 16:23:48 kevin Exp $
+;;;; $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
 ;;;;
@@ -18,82 +18,79 @@
 
 (in-package :kmrcl)
 
-(defvar *default-telnet-server-port* 4000)
+(defconstant +default-telnet-server-port+ 4000)
 
-#+allegro
-(defun start-telnet-server (&optional (port *default-telnet-server-port*))
-  (let ((passive (socket:make-socket :connect :passive
-				     :local-host "127.1"
-				     :local-port port
-				     :reuse-address t)))
-    (mp:process-run-function
-     "telnet-listener"
-     #'(lambda (pass)
-	 (let ((count 0))
-	   (loop
-	     (let ((con (socket:accept-connection pass)))
-	       (mp:process-run-function
-		(format nil "tel~d" (incf count))
-		#'(lambda (con)
-		    (unwind-protect
-			(tpl::start-interactive-top-level
-			 con
-			 #'tpl::top-level-read-eval-print-loop
-			 nil)
-		      (ignore-errors (close con :abort t))))
-		con)))))
-     passive)))
+(defclass telnetd ()
+  ((listener :initarg :listener :accessor listener
+	     :initform nil)))
 
-#+lispworks
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (require "comm"))
+(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)))
 
-#+lispworks
-(defun sts2  (&optional (port *default-telnet-server-port*))
-  (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))
 
-#+lispworks
-(defun make-telnet-stream (handle)
-  (let ((stream (make-instance 'comm:socket-stream
-		  :socket handle
-		  :direction :io
-		  :element-type
-		  'base-char))) 
-    (mp:process-run-function 
-     (format nil "telnet-session ~D" handle)
-     '()
-     'telnet-on-stream stream)))
+(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 '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
+  (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* "ksec")
+(defvar *telnet-password* "")
 
 (defun telnet-on-stream (stream)
-  (unwind-protect
-      (progn
-	(let ((password (read-telnet-line stream))) 
-	  (unless (and (stringp password)
-		       (string= password *telnet-password*))
-	    (return-from telnet-on-stream)))
-	(print-prompt stream)
-	(loop for line = (read-telnet-line stream)
-	    while line
-	    do
-	      (ignore-errors 
-	       (format stream "~S" (eval (read-from-string line))))
-	      (force-output stream)
-	      (print-prompt stream)))
-    (close stream)))
-
-#+lispworks
-(defun start-telnet-server (&optional (port *default-telnet-server-port*))
-  (comm:start-up-server :service port
-			:process-name (format nil "telnet-~d" port)
-			:function 'kmrcl::make-telnet-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))))))