;;;; -*- 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.6 2003/07/09 19:19:19 kevin Exp $
;;;;
;;;; 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 Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package :kmrcl)

(defconstant +default-telnet-server-port+ 4000)

(defclass telnetd ()
  ((listener :initarg :listener :accessor listener
	     :initform nil)
   (users :initarg :users :accessor users
	  :initform nil)
   (announce :initarg :announce :accessor announce
	  :initform nil)))

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


(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-one-char #\return
			      (read-line stream nil nil)))

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

(defvar *telnet-password* "")

(defun telnet-on-stream (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)))