+cl-kmrcl (1.54-1) unstable; urgency=low
+
+ * listener and repl improvements
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Fri, 11 Jul 2003 01:01:11 -0600
+
cl-kmrcl (1.53-1) unstable; urgency=low
* Listener improvements
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: kmrcl.asd,v 1.39 2003/07/09 19:19:19 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.40 2003/07/11 06:58:32 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(:file "sockets" :depends-on ("macros"))
(:file "processes" :depends-on ("macros"))
(:file "listener" :depends-on ("sockets" "processes"))
- (:file "telnet-server" :depends-on ("listener"))
+ (:file "repl" :depends-on ("listener" "strings"))
))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2003
;;;;
-;;;; $Id: listener.lisp,v 1.4 2003/07/11 02:37:33 kevin Exp $
+;;;; $Id: listener.lisp,v 1.5 2003/07/11 06:58:32 kevin Exp $
;;;; *************************************************************************
(in-package #:kmrcl)
(number-fixed-workers :initform nil :accessor number-fixed-workers
:initarg :number-fixed-workers)
(catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
+ (remote-host-checker :initform nil :accessor remote-host-checker
+ :initarg :remote-host-checker)
(format :initform :text :accessor listener-format :initarg :format)))
(defclass fixed-worker ()
(setf (workers listener)
(remove self (workers listener)))))))))
+(defun accept-and-check-tcp-connection (listener)
+ (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener))
+ (when (and (remote-host-checker listener)
+ (not (funcall (remote-host-checker listener)
+ (remote-host socket))))
+ (cmsg-c :thread "Deny connection from ~A" (remote-host conn))
+ (errorset (close-active-socket conn) nil)
+ (setq conn nil))
+ conn))
+
(defun start-socket-server (listener)
(unwind-protect
(loop
- (let ((connection (accept-tcp-connection (socket listener))))
- (if (wait listener)
- (unwind-protect
- (apply (listener-function listener)
- connection
- (function-args listener))
- (progn
- (errorset (finish-output connection) nil)
- (errorset (close-active-socket connection) nil)))
- (let ((worker (make-instance 'worker :listener listener
- :connection connection
- :name (next-worker-name
- (base-name listener)))))
- (setf (process worker)
- (make-process (name worker) (thread-fun worker)))
- (push worker (workers listener))))))
+ (let ((connection (accept-and-check-tcp-connection listener)))
+ (when connection
+ (if (wait listener)
+ (unwind-protect
+ (apply (listener-function listener)
+ connection
+ (function-args listener))
+ (progn
+ (errorset (finish-output connection) nil)
+ (errorset (close-active-socket connection) nil)))
+ (let ((worker (make-instance 'worker :listener listener
+ :connection connection
+ :name (next-worker-name
+ (base-name listener)))))
+ (setf (process worker)
+ (make-process (name worker) (thread-fun worker)))
+ (push worker (workers listener)))))))
(errorset (close-passive-socket (socket listener)) nil)))
#+lispworks
(defun fixed-worker (name listener)
(loop
- (let ((connection (accept-tcp-connection (socket listener))))
- (flet ((do-work ()
- (apply (listener-function listener)
- connection
- (function-args listener))))
- (unwind-protect
- (handler-case
- (if (catch-errors listener)
- (handler-case
- (if (timeout listener)
- (with-timeout ((timeout listener))
+ (let ((connection (accept-and-check-tcp-connection listener)))
+ (when connection
+ (flet ((do-work ()
+ (apply (listener-function listener)
+ connection
+ (function-args listener))))
+ (unwind-protect
+ (handler-case
+ (if (catch-errors listener)
+ (handler-case
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
+ (do-work))
(do-work))
+ (error (e)
+ (cmsg "Error ~A [~A]" e name)))
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
(do-work))
- (error (e)
- (cmsg "Error ~A [~A]" e name)))
- (if (timeout listener)
- (with-timeout ((timeout listener))
- (do-work))
- (do-work)))
- (error (e)
- (format t "Error: ~A" e)))
- (errorset (finish-output connection) nil)
- (errorset (close connection) nil))))))
+ (do-work)))
+ (error (e)
+ (format t "Error: ~A" e)))
+ (errorset (finish-output connection) nil)
+ (errorset (close connection) nil)))))))
+
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: macros.lisp,v 1.2 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id: macros.lisp,v 1.3 2003/07/11 06:58:32 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(print-seconds secs)
(format t ", time per iteration: ")
(print-seconds (coerce (/ secs ,n) 'double-float))))))))
+
+(defmacro mv-bind (vars form &body body)
+ `(multiple-value-bind ,vars ,form
+ ,@body))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.48 2003/07/09 19:19:19 kevin Exp $
+;;;; $Id: package.lisp,v 1.49 2003/07/11 06:58:32 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
#:alambda
#:it
#:mac
+ #:mv-bind
;; files.lisp
#:print-file-contents
#:seed-random-generator
#:random-choice
- ;; From telnet-server.lisp
- #:start-telnet-server
+ ;; From repl.lisp
+ #:make-repl
+ #:init/repl
;; From web-utils
#:*base-url*
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: repl.lisp
+;;;; Purpose: A repl server
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id: repl.lisp,v 1.1 2003/07/11 06:58:32 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:kmrcl)
+
+(defconstant +default-repl-server-port+ 4000)
+
+(defclass repl ()
+ ((listener :initarg :listener :accessor listener
+ :initform nil)))
+
+(defun make-repl (&key (port +default-repl-server-port+)
+ announce user-checker remote-host-checker)
+ (make-instance 'listener
+ :port port
+ :base-name "repl"
+ :function 'repl-worker
+ :function-args (list user-checker announce)
+ :format :text
+ :wait nil
+ :remote-host-checker remote-host-checker
+ :catch-errors nil))
+
+(defun init/repl (repl state)
+ (init/listener repl state))
+
+
+(defun repl-worker (conn user-checker announce)
+ (when announce
+ (format conn "~A~%" announce)
+ (force-output conn))
+ (when user-checker
+ (let (login password)
+ (format conn "login: ")
+ (finish-output conn)
+ (setq login (read-socket-line conn))
+ (format conn "password: ")
+ (finish-output conn)
+ (setq password (read-socket-line conn))
+ (unless (funcall user-checker login password)
+ (format conn "Invalid login~%")
+ (finish-output conn)
+ (return-from repl-worker))))
+ #+allegro
+ (tpl::start-interactive-top-level
+ conn
+ #'tpl::top-level-read-eval-print-loop
+ nil)
+ #-allegro
+ (repl-on-stream conn)
+ )
+
+(defun read-socket-line (stream)
+ (string-right-trim-one-char #\return
+ (read-line stream nil nil)))
+
+(defun print-prompt (stream)
+ (format stream "~&~A> " (package-name *package*))
+ (force-output stream))
+
+(defun repl-on-stream (stream)
+ (let ((*standard-input* stream)
+ (*standard-output* stream)
+ (*terminal-io* stream)
+ (*debug-io* stream))
+ #|
+ #+sbcl
+ (if (and (find-package 'sb-aclrepl)
+ (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
+ (sb-aclrepl::repl-fun)
+ (%repl))
+ #-sbcl
+ |#
+ (%repl)))
+
+(defun %repl ()
+ (loop
+ (print-prompt *standard-output*)
+ (let ((form (read *standard-input*)))
+ (format *standard-output* "~&~S~%" (eval form)))))
+
;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve
;;;; Date Started: Jun 2003
;;;;
-;;;; $Id: sockets.lisp,v 1.3 2003/07/10 18:52:10 kevin Exp $
+;;;; $Id: sockets.lisp,v 1.4 2003/07/11 06:58:32 kevin Exp $
;;;; *************************************************************************
(in-package #:kmrcl)
(defun accept-tcp-connection (listener)
+ "Returns (VALUES stream socket)"
#+allegro
- (socket:accept-connection listener)
+ (let ((sock (socket:accept-connection listener)))
+ (values sock sock))
#+clisp
- (ext:socket-accept listener)
+ (let ((sock (ext:socket-accept listener)))
+ (value sock sock))
#+cmu
(progn
(mp:process-wait-until-fd-usable listener :input)
- (sys:make-fd-stream
- (nth-value 0 (ext:accept-tcp-connection listener))
- :input t :output t))
+ (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
+ (values (sys:make-fd-stream sock :input t :output t) sock)))
#+sbcl
(when (sb-sys:wait-until-fd-usable
(sb-bsd-sockets:socket-file-descriptor listener) :input)
- (sb-bsd-sockets:socket-make-stream
- (sb-bsd-sockets:socket-accept listener)
- :element-type 'base-char
- :input t :output t))
+ (let ((sock (sb-bsd-sockets:socket-accept listener)))
+ (values
+ (sb-bsd-sockets:socket-make-stream
+ sock :element-type 'base-char :input t :output t)
+ sock)))
#-(or allegro clisp cmu sbcl)
(warn "accept-tcp-connection not supported on this implementation")
)
(defun make-active-socket (server port)
- #+allegro (socket:make-socket :remote-host server
- :remote-port port)
- #+lispworks (comm:open-tcp-stream server port)
- #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream
- :protocol :tcp)))
- (sb-bsd-sockets:socket-connect
- socket (lookup-hostname server) port)
- (sb-bsd-sockets:socket-make-stream socket
- :input t
- :output t
- :element-type 'base-char))
- #+cmu
- (sys:make-fd-stream (ext:connect-to-inet-socket host port)
- :input t :output t :element-type 'base-char)
+ "Returns (VALUES STREAM SOCKET)"
+ #+allegro
+ (let ((sock (socket:make-socket :remote-host server
+ :remote-port port)))
+ (values sock sock))
+ #+lispworks
+ (let ((sock (comm:open-tcp-stream server port)))
+ (values sock sock))
+ #+sbcl
+ (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
+ (values
+ (sb-bsd-sockets:socket-make-stream
+ sock :input t :output t :element-type 'base-char)
+ sock))
+ #+cmu
+ (let ((sock (ext:connect-to-inet-socket host port)))
+ (values
+ (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
+ sock))
+ )
+
+(defun ipaddr-array-to-dotted (array)
+ (format nil "~{~D~^.~}" (coerce array 'list))
+ #+ignore
+ (format nil "~D.~D.~D.~D"
+ (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
+
+(defun remote-host (socket)
+ #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
+ #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
+ #+sbcl (ipaddr-array-to-dotted
+ (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
+ #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
)
+
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: telnet-server.lisp
-;;;; Purpose: A telnet server
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Apr 2000
-;;;;
-;;;; $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
-;;;;
-;;;; KMRCL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :kmrcl)
-
-(defconstant +default-telnet-server-port+ 4000)
-
-(defclass telnetd ()
- ((listener :initarg :listener :accessor listener
- :initform nil)))
-
-(defun start-telnet-server (&key (port +default-telnet-server-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 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)
- (force-output conn))
- (when users
- (let (user-name password)
- (format conn "login: ")
- (force-output conn)
- (setq user-name (read-telnet-line conn))
- (format conn "password: ")
- (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
- #+ignore
- (tpl::start-interactive-top-level
- conn
- #'tpl::top-level-read-eval-print-loop
- nil)
- #+sbcl
- ;; FIXME -- use aclrepl
- (telnet-on-stream conn)
- ;;#-(or sbcl allegro)
- (telnet-on-stream conn)
- )
-
-(defun read-telnet-line (stream)
- (string-right-trim-one-char #\return
- (read-line stream nil nil)))
-
-(defun print-prompt (stream)
- (format stream "~&~A> " (package-name *package*))
- (force-output stream))
-
-(defvar *telnet-password* "")
-
-(defun telnet-on-stream (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))))))
projects / kmrcl.git / commitdiff