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.6 2003/07/09 19:19:19 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    (users :initarg :users :accessor users
  27           :initform nil)
  28    (announce :initarg :announce :accessor announce
  29           :initform nil)))
  30
  31 (defun start-telnet-server (&key (port +default-telnet-server-port+)
  32                             announce
  33                             users)
  34   (let ((telnetd
  35          (make-instance 'telnetd
  36                         :users users
  37                         :listener
  38                         (make-instance 'listener :port port
  39                                  :base-name "telnetd"
  40                                  :function 'telnet-worker
  41                                  :function-args (list users announce)
  42                                  :format :text
  43                                  :wait nil
  44                                  :catch-errors t))))
  45     telnetd))
  46
  47
  48 (defun telnet-worker (conn users announce)
  49   (when announce
  50     (format conn "~A~%" announce))
  51   (when users
  52     (let (user-name password)
  53       (format conn "user: ")
  54       (setq user-name (read-line conn))
  55       (format conn "password: ")
  56       (setq password (read-line conn))
  57       (unless (and (string= user (car users))
  58                    (string= password (cdr users)))
  59         (format conn "Invalid login~%")
  60         (return-from telnet-worker))))
  61   #+allegro
  62   (tpl::start-interactive-top-level
  63    conn
  64    #'tpl::top-level-read-eval-print-loop
  65    nil)
  66   #-allegro
  67   (telnet-on-stream conn)
  68   )
  69
  70 (defun read-telnet-line (stream)
  71   (string-right-trim-one-char #\return
  72                               (read-line stream nil nil)))
  73
  74 (defun print-prompt (stream)
  75   (format stream "~&~A> " (package-name *package*))
  76   (force-output stream))
  77
  78 (defvar *telnet-password* "")
  79
  80 (defun telnet-on-stream (stream)
  81   (print-prompt stream)
  82   (loop for line = (read-telnet-line stream)
  83         while line
  84         do
  85         (ignore-errors
  86           (format stream "~S" (eval (read-from-string line))))
  87         (force-output stream)
  88         (print-prompt stream)))