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.4 2002/10/10 16:23:48 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 Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package :kmrcl)
  20
  21 (defvar *default-telnet-server-port* 4000)
  22
  23 #+allegro
  24 (defun start-telnet-server (&optional (port *default-telnet-server-port*))
  25   (let ((passive (socket:make-socket :connect :passive
  26                                      :local-host "127.1"
  27                                      :local-port port
  28                                      :reuse-address t)))
  29     (mp:process-run-function
  30      "telnet-listener"
  31      #'(lambda (pass)
  32          (let ((count 0))
  33            (loop
  34              (let ((con (socket:accept-connection pass)))
  35                (mp:process-run-function
  36                 (format nil "tel~d" (incf count))
  37                 #'(lambda (con)
  38                     (unwind-protect
  39                         (tpl::start-interactive-top-level
  40                          con
  41                          #'tpl::top-level-read-eval-print-loop
  42                          nil)
  43                       (ignore-errors (close con :abort t))))
  44                 con)))))
  45      passive)))
  46
  47 #+lispworks
  48 (eval-when (:compile-toplevel :load-toplevel :execute)
  49   (require "comm"))
  50
  51 #+lispworks
  52 (defun sts2  (&optional (port *default-telnet-server-port*))
  53   (comm:start-up-server :service port :function 'comm::make-stream-and-run-listener))
  54
  55 #+lispworks
  56 (defun make-telnet-stream (handle)
  57   (let ((stream (make-instance 'comm:socket-stream
  58                   :socket handle
  59                   :direction :io
  60                   :element-type
  61                   'base-char)))
  62     (mp:process-run-function
  63      (format nil "telnet-session ~D" handle)
  64      '()
  65      'telnet-on-stream stream)))
  66
  67 (defun read-telnet-line (stream)
  68   (string-right-trim '(#\newline #\linefeed #\return #\space #\tab #\backspace) (read-line stream nil nil)))
  69
  70 (defun print-prompt (stream)
  71   (format stream "~&~A> " (package-name *package*))
  72   (force-output stream))
  73
  74 (defvar *telnet-password* "ksec")
  75
  76 (defun telnet-on-stream (stream)
  77   (unwind-protect
  78       (progn
  79         (let ((password (read-telnet-line stream)))
  80           (unless (and (stringp password)
  81                        (string= password *telnet-password*))
  82             (return-from telnet-on-stream)))
  83         (print-prompt stream)
  84         (loop for line = (read-telnet-line stream)
  85             while line
  86             do
  87               (ignore-errors
  88                (format stream "~S" (eval (read-from-string line))))
  89               (force-output stream)
  90               (print-prompt stream)))
  91     (close stream)))
  92
  93 #+lispworks
  94 (defun start-telnet-server (&optional (port *default-telnet-server-port*))
  95   (comm:start-up-server :service port
  96                         :process-name (format nil "telnet-~d" port)
  97                         :function 'kmrcl::make-telnet-stream))
  98
  99