;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: telnet-server.lisp,v 1.2 2002/10/06 13:30:17 kevin Exp $
+;;;; $Id: telnet-server.lisp,v 1.6 2003/07/09 19:19:19 kevin Exp $
;;;;
-;;;; This file, part of Kmrcl, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; 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 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 :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)
+ (users :initarg :users :accessor users
+ :initform nil)
+ (announce :initarg :announce :accessor announce
+ :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 ((telnetd
+ (make-instance 'telnetd
+ :users users
+ :listener
+ (make-instance 'listener :port port
+ :base-name "telnetd"
+ :function 'telnet-worker
+ :function-args (list users announce)
+ :format :text
+ :wait nil
+ :catch-errors t))))
+ telnetd))
-#+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 telnet-worker (conn users announce)
+ (when announce
+ (format conn "~A~%" announce))
+ (when users
+ (let (user-name password)
+ (format conn "user: ")
+ (setq user-name (read-line conn))
+ (format conn "password: ")
+ (setq password (read-line conn))
+ (unless (and (string= user (car users))
+ (string= password (cdr users)))
+ (format conn "Invalid login~%")
+ (return-from telnet-worker))))
+ #+allegro
+ (tpl::start-interactive-top-level
+ conn
+ #'tpl::top-level-read-eval-print-loop
+ nil)
+ #-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))
-
-
+ (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)))
projects / kmrcl.git / blobdiff