;;;; -*- 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.1 2002/10/06 13:21:47 kevin Exp $
;;;;
;;;; This file, part of Genutils, 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.
;;;; *************************************************************************

(in-package :genutils)

(defvar *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)))

#+lispworks
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "comm"))

#+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 read-telnet-line (stream)
  (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))

(defun print-prompt (stream)
  (format stream "~&~A> " (package-name *package*))
  (force-output stream))

(defvar *telnet-password* "ksec")

(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))