From 0ddc73d14e764eeaede64f92b620a0c6de46cfd3 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 9 Jul 2003 22:12:52 +0000 Subject: [PATCH] r5266: *** empty log message *** --- listener.lisp | 17 +++++++++-- processes.lisp | 6 ++-- sockets.lisp | 8 ++++-- telnet-server.lisp | 70 ++++++++++++++++++++++++++-------------------- 4 files changed, 62 insertions(+), 39 deletions(-) diff --git a/listener.lisp b/listener.lisp index 5995405..d37d72d 100644 --- a/listener.lisp +++ b/listener.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: listener.lisp,v 1.1 2003/07/08 16:12:40 kevin Exp $ +;;;; $Id: listener.lisp,v 1.2 2003/07/09 22:12:52 kevin Exp $ ;;;; ************************************************************************* (in-package #:kmrcl) @@ -46,7 +46,14 @@ (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil) (process :initarg :process :accessor process :initform nil))) +(defmethod print-object ((obj listener) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port obj)))) +(defmethod print-object ((obj worker) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port (listener obj))))) + ;; High-level API (defun init/listener (listener state) @@ -74,11 +81,15 @@ (return-from init/listener listener)) (dolist (worker (workers listener)) (close-active-socket (connection worker)) - (destroy-process (process worker))) + (destroy-process (process worker)) + (setf (connection worker) nil) + (setf (process worker) nil)) (setf (workers listener) nil) (with-slots (process socket) listener (errorset (close-passive-socket socket) t) - (errorset (destroy-process process) t)) + (errorset (destroy-process process) t) + (setf process nil) + (setf socket nil)) (setq *active-listeners* (remove listener *active-listeners*))) (:restart (init/listener listener :stop) diff --git a/processes.lisp b/processes.lisp index 0c9175f..64921f7 100644 --- a/processes.lisp +++ b/processes.lisp @@ -7,18 +7,18 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: June 2003 ;;;; -;;;; $Id: processes.lisp,v 1.1 2003/07/08 16:12:40 kevin Exp $ +;;;; $Id: processes.lisp,v 1.2 2003/07/09 22:12:52 kevin Exp $ ;;;; ************************************************************************* (in-package #:kmrcl) (defun make-process (name func) - #+cmu (mp:make-process func :name name) #+allegro (mp:process-run-function name func) + #+cmu (mp:make-process func :name name) #+lispworks (mp:process-run-function name nil func) #+sb-thread (sb-thread:make-thread func) - #+clisp (funcall func) + #-(or allegro cmu lispworks sb-thread) (funcall func) ) (defun destroy-process (process) diff --git a/sockets.lisp b/sockets.lisp index 116e155..a0d4472 100644 --- a/sockets.lisp +++ b/sockets.lisp @@ -7,12 +7,16 @@ ;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve ;;;; Date Started: Jun 2003 ;;;; -;;;; $Id: sockets.lisp,v 1.1 2003/07/08 16:12:40 kevin Exp $ +;;;; $Id: sockets.lisp,v 1.2 2003/07/09 22:12:52 kevin Exp $ ;;;; ************************************************************************* (in-package #:kmrcl) -;; Sockets +(eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (require :sb-bsd-sockets) + #+lispworks (require "comm") + #+allegro (require :socket)) + #+lispworks (progn diff --git a/telnet-server.lisp b/telnet-server.lisp index cf95ad4..210943a 100644 --- a/telnet-server.lisp +++ b/telnet-server.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: telnet-server.lisp,v 1.6 2003/07/09 19:19:19 kevin Exp $ +;;;; $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 ;;;; @@ -22,48 +22,55 @@ (defclass telnetd () ((listener :initarg :listener :accessor listener - :initform nil) - (users :initarg :users :accessor users - :initform nil) - (announce :initarg :announce :accessor announce - :initform nil))) + :initform nil))) (defun start-telnet-server (&key (port +default-telnet-server-port+) - announce - users) - (let ((telnetd - (make-instance 'telnetd - :users users - :listener - (make-instance 'listener :port 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 t)))) - telnetd)) + :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)) + (format conn "~A~%" announce) + (force-output conn)) (when users (let (user-name password) - (format conn "user: ") - (setq user-name (read-line conn)) + (format conn "login: ") + (force-output conn) + (setq user-name (read-telnet-line conn)) (format conn "password: ") - (setq password (read-line conn)) - (unless (and (string= user (car users)) - (string= password (cdr users))) + (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 + ;;#+allegro + #+ignore (tpl::start-interactive-top-level conn #'tpl::top-level-read-eval-print-loop nil) - #-allegro + #+sbcl + ;; FIXME -- use aclrepl + (telnet-on-stream conn) + ;;#-(or sbcl allegro) (telnet-on-stream conn) ) @@ -78,11 +85,12 @@ (defvar *telnet-password* "") (defun telnet-on-stream (stream) - (print-prompt stream) - (loop for line = (read-telnet-line stream) - while line - do - (ignore-errors - (format stream "~S" (eval (read-from-string line)))) - (force-output stream) - (print-prompt 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)))))) -- 2.34.1