;;;; -*- 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.7 2003/07/09 22:12:52 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)))

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


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