;;;; 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)
(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)
(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)
;;;; 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)
;;;; 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
;;;; 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
;;;;
(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)
)
(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))))))