telnet-server.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          telnet-server.lisp
   6 ;;;; Purpose:       A telnet server
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: telnet-server.lisp,v 1.3 2002/10/06 13:35:30 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of Kmrcl, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; Kmrcl users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License.
  16 ;;;; *************************************************************************
  17
  18 (in-package :kmrcl)
  19
  20 (defvar *default-telnet-server-port* 4000)
  21
  22 #+allegro
  23 (defun start-telnet-server (&optional (port *default-telnet-server-port*))
  24   (let ((passive (socket:make-socket :connect :passive
  25                                      :local-host "127.1"
  26                                      :local-port port
  27                                      :reuse-address t)))
  28     (mp:process-run-function
  29      "telnet-listener"
  30      #'(lambda (pass)
  31          (let ((count 0))
  32            (loop
  33              (let ((con (socket:accept-connection pass)))
  34                (mp:process-run-function
  35                 (format nil "tel~d" (incf count))
  36                 #'(lambda (con)
  37                     (unwind-protect
  38                         (tpl::start-interactive-top-level
  39                          con
  40                          #'tpl::top-level-read-eval-print-loop
  41                          nil)
  42                       (ignore-errors (close con :abort t))))
  43                 con)))))
  44      passive)))
  45
  46 #+lispworks
  47 (eval-when (:compile-toplevel :load-toplevel :execute)
  48   (require "comm"))
  49
  50 #+lispworks
  51 (defun sts2  (&optional (port *default-telnet-server-port*))
  52   (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))
  53
  54 #+lispworks
  55 (defun make-telnet-stream (handle)
  56   (let ((stream (make-instance 'comm:socket-stream
  57                   :socket handle
  58                   :direction :io
  59                   :element-type
  60                   'base-char)))
  61     (mp:process-run-function
  62      (format nil "telnet-session ~D" handle)
  63      '()
  64      'telnet-on-stream stream)))
  65
  66 (defun read-telnet-line (stream)
  67   (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
  68
  69 (defun print-prompt (stream)
  70   (format stream "~&~A> " (package-name *package*))
  71   (force-output stream))
  72
  73 (defvar *telnet-password* "ksec")
  74
  75 (defun telnet-on-stream (stream)
  76   (unwind-protect
  77       (progn
  78         (let ((password (read-telnet-line stream)))
  79           (unless (and (stringp password)
  80                        (string= password *telnet-password*))
  81             (return-from telnet-on-stream)))
  82         (print-prompt stream)
  83         (loop for line = (read-telnet-line stream)
  84             while line
  85             do
  86               (ignore-errors
  87                (format stream "~S" (eval (read-from-string line))))
  88               (force-output stream)
  89               (print-prompt stream)))
  90     (close stream)))
  91
  92 #+lispworks
  93 (defun start-telnet-server (&optional (port *default-telnet-server-port*))
  94   (comm:start-up-server :service port
  95                         :process-name (format nil "telnet-~d" port)
  96                         :function 'kmrcl::make-telnet-stream))
  97
  98