r5284: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 11 Jul 2003 07:03:03 +0000 (07:03 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Fri, 11 Jul 2003 07:03:03 +0000 (07:03 +0000)
debian/changelog
kmrcl.asd
listener.lisp
macros.lisp
package.lisp
repl.lisp [new file with mode: 0644]
sockets.lisp
telnet-server.lisp [deleted file]

index 5bd6d3d..4ab1bc8 100644 (file)
@@ -1,3 +1,9 @@
+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
index 34bde48..6216a71 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; 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
 ;;;;
@@ -53,7 +53,7 @@
      (: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"))
      ))
 
 
index dfd70f4..19c7b0c 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; 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)
@@ -40,6 +40,8 @@
    (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)))))))
+  
index 03e3a9f..1697dca 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; 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))
index ff337e9..754aef5 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; 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*
diff --git a/repl.lisp b/repl.lisp
new file mode 100644 (file)
index 0000000..2675426
--- /dev/null
+++ b/repl.lisp
@@ -0,0 +1,96 @@
+;;;; -*- 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)))))
+  
index 6af47d8..259b7b0 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; 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)
@@ -63,23 +63,26 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (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")
   )
@@ -151,19 +154,41 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (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))
   )
+  
diff --git a/telnet-server.lisp b/telnet-server.lisp
deleted file mode 100644 (file)
index 210943a..0000000
+++ /dev/null
@@ -1,96 +0,0 @@
-;;;; -*- 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))))))