-;;;; -*- 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))))))