;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: telnet-server.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
+;;;; $Id: telnet-server.lisp,v 1.7 2003/07/09 22:12:52 kevin Exp $
;;;;
-;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
-;;;; Genutils users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License.
+;;;; 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 :genutils)
+(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 'gu::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))))))