r5266: *** empty log message ***

[kmrcl.git] / telnet-server.lisp

diff --git a/telnet-server.lisp b/telnet-server.lisp
index 6be5c68b6a87e9d703657c75d50289d7f570bd09..210943a23c8eed2ea1f9d1e0199c5e0b57ab9960 100644 (file)
--- 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))))))