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.7 2003/07/09 22:12:52 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 (defconstant +default-telnet-server-port+ 4000)
  22
  23 (defclass telnetd ()
  24   ((listener :initarg :listener :accessor listener
  25              :initform nil)))
  26
  27 (defun start-telnet-server (&key (port +default-telnet-server-port+)
  28                             announce users)
  29   (let ((listener (make-instance 'listener :port port
  30                                  :base-name "telnetd"
  31                                  :function 'telnet-worker
  32                                  :function-args (list users announce)
  33                                  :format :text
  34                                  :wait nil
  35                                  :catch-errors nil)))
  36     (init/listener listener :start)))
  37
  38
  39 (defun stop-telnet-server (listener)
  40   (init/listener listener :stop))
  41
  42 (defun user-authenticated (user-name password users)
  43   (some #'(lambda (user-pass)
  44             (and (string= user-name (car user-pass))
  45                  (string= password (cdr user-pass))))
  46         users))
  47
  48 (defun telnet-worker (conn users announce)
  49   (when announce
  50     (format conn "~A~%" announce)
  51     (force-output conn))
  52   (when users
  53     (let (user-name password)
  54       (format conn "login: ")
  55       (force-output conn)
  56       (setq user-name (read-telnet-line conn))
  57       (format conn "password: ")
  58       (force-output conn)
  59       (setq password (read-telnet-line conn))
  60       (unless (user-authenticated user-name password users)
  61         (format conn "Invalid login~%")
  62         (force-output conn)
  63         (return-from telnet-worker))))
  64   ;;#+allegro
  65   #+ignore
  66   (tpl::start-interactive-top-level
  67    conn
  68    #'tpl::top-level-read-eval-print-loop
  69    nil)
  70   #+sbcl
  71   ;; FIXME -- use aclrepl
  72   (telnet-on-stream conn)
  73   ;;#-(or sbcl allegro)
  74   (telnet-on-stream conn)
  75   )
  76
  77 (defun read-telnet-line (stream)
  78   (string-right-trim-one-char #\return
  79                               (read-line stream nil nil)))
  80
  81 (defun print-prompt (stream)
  82   (format stream "~&~A> " (package-name *package*))
  83   (force-output stream))
  84
  85 (defvar *telnet-password* "")
  86
  87 (defun telnet-on-stream (stream)
  88   (let ((*standard-input* stream)
  89         (*standard-output* stream)
  90         (*terminal-io* stream)
  91         (*debug-io* stream))
  92     (loop
  93      (print-prompt stream)
  94      (let ((form (read stream)))
  95        (fresh-line stream)
  96        (format stream "~S~%" (eval form))))))