;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: base.lisp,v 1.5 2003/07/05 22:59:56 kevin Exp $
+;;;; $Id: base.lisp,v 1.6 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:modlisp)
(defun modlisp-start (&key (port +default-apache-port+)
- (function 'demo-apache-command-processor)
- (function-args nil))
- (let ((listener (make-instance 'listener)))
+ (processor 'demo-apache-command-processor)
+ (processor-args nil))
+ (let ((listener (make-instance 'listener :port port
+ :name (next-server-name)
+ :function 'apache-command-issuer
+ :function-args (cons processor processor-args)
+ :format :text
+ :wait nil)))
(handler-case
- (make-socket-server (next-server-name) function port listener
- :format :text :wait nil
- :function-args function-args)
+ (make-socket-server listener)
(error (e)
(format t "~&Error while trying to start modlisp server~& ~A" e)
(decf *listener-count*)
(values nil nil))
- (:no-error (process socket)
- (setf (process listener) process)
- (setf (socket listener) socket)
+ (:no-error (res)
+ (declare (ignore res))
(push listener *active-listeners*)
listener))))
(cmsg "listener is NIL in modlisp-stop")
(return-from modlisp-stop))
(dolist (worker (workers listener))
- (close-active-socket (socket worker))
+ (close-active-socket (connection worker))
(destroy-process (process worker)))
(setf (workers listener) nil)
(with-slots (process socket) listener
- (handler-case
- (destroy-process process)
- (error (e)
- (format t "~&Error while trying to kill modlisp server~& ~A" e)))
- (when socket
- (ignore-errors (close-passive-socket socket))))
+ (errorset (close-passive-socket socket) t)
+ (errorset (destroy-process process) t))
(setq *active-listeners* (remove listener *active-listeners*)))
-
+
+(defun modlisp-stop-all ()
+ (dolist (listener *active-listeners*)
+ (ignore-errors
+ (progn
+ (modlisp-stop listener)
+ (setq *active-listeners* (remove listener *active-listeners*))))))
+
(defun next-server-name ()
(format nil "modlisp-socket-server-~d" (incf *listener-count*)))
(*number-worker-requests* 0)
(*close-apache-socket* t))
- (defun apache-command-issuer (*apache-socket* processor-fun &rest args)
+ (defun apache-command-issuer (*apache-socket* processor &rest args)
"generates commands from apache, issues commands to processor-fun"
(unwind-protect
(progn
(setq *number-worker-requests* 0)
(do ((command (read-apache-command) (read-apache-command)))
- ((null command) 'done)
- (apply processor-fun command args)
+ ((null command))
+ (apply processor command args)
(force-output *apache-socket*)
(incf *number-worker-requests*)
(incf *number-server-requests*)
(when *close-apache-socket*
(return))))
- (close *apache-socket*)))
+ (close-active-socket *apache-socket*)))
+
(defun get-number-worker-requests ()
*number-worker-requests*)
) ;; closure
+(defun header-value (header key)
+ (cdr (assoc key header :test #'string=)))
+
(defun read-apache-command ()
(ignore-errors
(let* ((header (read-apache-header))
- (content-length (cdr (assoc "content-length" header :test #'equal)))
- (content (when content-length
- (make-string
- (parse-integer content-length :junk-allowed t)))))
+ (content-length (header-value header "content-length"))
+ (content (when content-length
+ (make-string
+ (parse-integer content-length :junk-allowed t)))))
(when content
(read-sequence content *apache-socket*)
(push (cons "posted-content" content) header))
header)))
+(defun read-apache-line ()
+ (kmrcl:string-left-trim-one-char #\return
+ (read-line *apache-socket* nil nil)))
+
(defun read-apache-header ()
- (loop for key = (read-line *apache-socket* nil nil)
- while (and key
- (string-not-equal key "end")
- (> (length key) 1))
- for value = (read-line *apache-socket* nil nil)
- collect (cons key value)))
+ (loop for key = (read-apache-line)
+ while (and key
+ (string-not-equal key "end")
+ (> (length key) 1))
+ for value = (read-apache-line)
+ collect (cons key value)))
(defun write-header-line (key value)
(write-string key *apache-socket*)
(write-string value *apache-socket*)
(write-char #\NewLine *apache-socket*))
-(defun header-value (command key)
- (cdr (assoc key command :test #'string=)))
--- /dev/null
+;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: clit -*-
+;;; $Id: compat.lisp,v 1.1 2003/07/08 06:43:29 kevin Exp $
+
+(in-package #:modlisp)
+
+;; Processes
+
+(defun make-process (name func)
+ #+cmu (mp:make-process func :name name)
+ #+allegro (mp:process-run-function name func)
+ #+lispworks (mp:process-run-function name nil func)
+ #+sb-thread (sb-thread:make-thread func)
+ #+clisp (funcall func)
+ )
+
+(defun destroy-process (process)
+ #+cmu (mp:destroy-process process)
+ #+allegro (mp:process-kill process)
+ #+sbcl-thread (sb-thread:destroy-thread process)
+ #+lispworks (mp:process-kill process)
+ )
+
+(defun make-lock (name)
+ #+allegro (mp:make-process-lock :name name)
+ #+cmu (mp:make-lock name)
+ #+lispworks (mp:make-lock :name name)
+ #+sbcl-thread (sb-thread:make-mutex :name name)
+ )
+
+(defmacro with-lock-held ((lock) &body body)
+ #+allegro
+ `(mp:with-process-lock (,lock) ,@body)
+ #+cmu
+ `(mp:with-lock-held (,lock) ,@body)
+ #+lispworks
+ `(mp:with-lock (,lock) ,@body)
+ #+sbcl-thread
+ `(sb-thread:with-recursive-lock (,lock) ,@body)
+ )
+
+
+;; Sockets
+
+#+lispworks
+(progn
+ (defclass socket ()
+ ((passive-socket :type fixnum
+ :initarg :passive-socket
+ :reader socket-os-fd)))
+
+ (defclass passive-socket (socket)
+ ((element-type :type (member signed-byte unsigned-byte base-char)
+ :initarg :element-type
+ :reader element-type)
+ (port :type fixnum
+ :initarg :port
+ :reader local-port)))
+
+ (defmethod print-object ((passive-socket passive-socket) stream)
+ (print-unreadable-object (passive-socket stream :type t :identity nil)
+ (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
+
+ (defclass binary-socket-stream (comm:socket-stream) ())
+(defclass input-binary-socket-stream (binary-socket-stream)())
+(defclass output-binary-socket-stream (binary-socket-stream)())
+(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
+
+#+unix
+(defun %socket-error-identifier (code)
+ (case code
+ (32 :x-broken-pipe)
+ (98 :address-in-use)
+ (99 :address-not-available)
+ (100 :network-down)
+ (102 :network-reset)
+ (103 :connection-aborted)
+ (104 :connection-reset)
+ (105 :no-buffer-space)
+ (108 :shutdown)
+ (110 :connection-timed-out)
+ (111 :connection-refused)
+ (112 :host-down)
+ (113 :host-unreachable)
+ (otherwise :unknown)))
+
+#+win32
+(defun %socket-error-identifier (code)
+ (case code
+ (10048 :address-in-use)
+ (10049 :address-not-available)
+ (10050 :network-down)
+ (10052 :network-reset)
+ (10053 :connection-aborted)
+ (10054 :connection-reset)
+ (10055 :no-buffer-space)
+ (10058 :shutdown)
+ (10060 :connection-timed-out)
+ (10061 :connection-refused)
+ (10064 :host-down)
+ (10065 :host-unreachable)
+ (otherwise :unknown)))
+
+(defun socket-error (stream error-code action format-string &rest format-args)
+ (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
+ (error 'socket-error :stream stream :code code
+ :identifier (if (keywordp error-code)
+ error-code
+ (%socket-error-identifier error-code))
+ :action action
+ :format-control "~A occured while doing socket IO (~?)"
+ :format-arguments (list 'socket-error format-string format-args))))
+
+
+(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
+ (apply #'socket-error stream error-code :IO format-string format-args))
+
+(defmethod stream-input-available ((fd fixnum))
+ (comm::socket-listen fd))
+
+(defmethod stream-input-available ((stream stream::os-file-handle-stream))
+ (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
+
+(defmethod stream-input-available ((stream comm:socket-stream))
+ (or (comm::socket-listen (comm:socket-stream-socket stream))
+ (listen stream)))
+
+(defmethod stream-input-available ((stream passive-socket))
+ (comm::socket-listen (socket-os-fd stream)))
+
+(defun %new-passive-socket (local-port)
+ (multiple-value-bind (socket error-location error-code)
+ (comm::create-tcp-socket-for-service local-port)
+ (cond (socket socket)
+ (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
+
+) ;; lispworks
+
+#+sbcl
+(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
+ "Create, bind and listen to an inet socket on *:PORT.
+setsockopt SO_REUSEADDR if :reuse is not nil"
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (if reuse
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
+ (sb-bsd-sockets:socket-bind
+ socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
+ (sb-bsd-sockets:socket-listen socket 15)
+ socket))
+
+(defun create-inet-listener (port &key (format :text) (reuse-address t))
+ #+cmu (ext:create-inet-listener port)
+ #+allegro
+ (socket:make-socket :connect :passive :local-port port :format :binary
+ :address-family
+ (if (stringp port)
+ :file
+ (if (or (null port) (integerp port))
+ :internet
+ (error "illegal value for port: ~s" port)))
+ :reuse-address reuse-address)
+ #+sbcl
+ (listen-to-inet-port :port port :reuse reuse-address)
+ #+clisp (ext:socket-server port)
+ #+lispworks
+ (let ((comm::*use_so_reuseaddr* reuse-address))
+ (make-instance 'passive-socket
+ :port port
+ :passive-socket (%new-passive-socket port)
+ :element-type format))
+ )
+
+(defun make-fd-stream (socket &key input output element-type)
+ #+cmu
+ (sys:make-fd-stream socket :input input :output output
+ :element-type element-type)
+ #+sbcl
+ (sb-bsd-sockets:socket-make-stream socket :input input :output output
+ :element-type element-type)
+ #-(or cmu sbcl) (declare (ignore input output element-type))
+ #-(or cmu sbcl) socket
+ )
+
+
+(defun accept-tcp-connection (listener)
+ #+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))
+ #+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))
+ #+allegro
+ (socket:accept-connection listener)
+ #+clisp
+ (ext:socket-accept listener)
+ #+lispworks
+ (when (stream-input-available listener)
+ (make-instance 'bidirectional-binary-socket-stream
+ :socket (comm::get-fd-from-socket
+ (socket-os-fd passive-socket))
+ :direction :io
+ :element-type (element-type listener)))
+
+ )
+
+
+(defmacro errorset (form display)
+ `(handler-case
+ ,form
+ (error (e)
+ (declare (ignorable e))
+ (when ,display
+ (format t "~&Error: ~A~%" e)))))
+
+(defun close-passive-socket (socket)
+ #+allegro (close socket)
+ #+cmu (unix:unix-close socket)
+ #+sbcl (sb-unix:unix-close
+ (sb-bsd-sockets:socket-file-descriptor socket))
+ #+clisp (close socket)
+ #+lispworks (comm::close-socket (socket-os-fd socket))
+ )
+
+
+(defun close-active-socket (socket)
+ (close socket))
+
+#+sbcl
+(defun ipaddr-to-dotted (ipaddr &key values)
+ "Convert from 32-bit integer to dotted string."
+ (declare (type (unsigned-byte 32) ipaddr))
+ (let ((a (logand #xff (ash ipaddr -24)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
+ (if values
+ (values a b c d)
+ (format nil "~d.~d.~d.~d" a b c d))))
+
+#+sbcl
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+ "Convert from dotted string to 32-bit integer."
+ (declare (string dotted))
+ (if errorp
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll)))
+ (ignore-error
+ (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+ (+ (ash (first ll) 24) (ash (second ll) 16)
+ (ash (third ll) 8) (fourth ll))))))
+
+#+sbcl
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+ (sb-bsd-sockets:host-ent-name
+ (sb-bsd-sockets:get-host-by-address
+ (sb-bsd-sockets:make-inet-address ipaddr))))
+
+#+sbcl
+(defun lookup-hostname (host &key ignore-cache)
+ (when ignore-cache
+ (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+ (if (stringp host)
+ (sb-bsd-sockets:host-ent-address
+ (sb-bsd-sockets:get-host-by-name host))
+ (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+
+(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)
+ )
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: demo.lisp,v 1.1 2003/07/05 00:59:49 kevin Exp $
+;;;; $Id: demo.lisp,v 1.2 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:modlisp)
+;;; A small test bench used to test and time the client/server protocol
+;;; From Marc Battyani
+
+(defun fetch-mod-lisp-url (server url &key (num-fetch 1) (port 20123)
+ close-socket)
+ (loop with server-socket and reply
+ repeat num-fetch
+ do (unless server-socket
+ (setf server-socket (make-active-socket server port)))
+ (write-string "url" server-socket)
+ (write-char #\NewLine server-socket)
+ (write-string url server-socket)
+ (write-char #\NewLine server-socket)
+ (write-string "end" server-socket)
+ (write-char #\NewLine server-socket)
+ (force-output server-socket)
+ (setf reply (read-reply server-socket))
+ (when close-socket
+ (close server-socket)
+ (setf server-socket nil))
+ finally
+ (unless close-socket (close server-socket))
+ (return reply)))
+
+(defun read-reply (socket)
+ (let* ((header (loop for key = (read-line socket nil nil)
+ while (and key (string-not-equal key "end"))
+ for value = (read-line socket nil nil)
+ collect (cons key value)))
+ (content-length (cdr (assoc "Content-Length" header :test #'string=)))
+ (content (when content-length (make-string (parse-integer content-length :junk-allowed t)))))
+ (when content
+ (read-sequence content socket)
+ (push (cons "reply-content" content) header))
+ header))
(defvar *processor*)
(let ((*processor* nil))
- (defun make-socket-server (name function port &key wait (format :text))
+ (defun make-socket-server (name function port listener
+ &key wait (format :text) function-args)
(setq *processor* function)
(values
(comm:start-up-server
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: modlisp.asd,v 1.6 2003/07/05 23:04:32 kevin Exp $
+;;;; $Id: modlisp.asd,v 1.7 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:cl-user)
((:file "package")
(:file "compat" :depends-on ("package"))
(:file "variables" :depends-on ("package"))
- (:file #+(or allegro clisp cmu sbcl) "server"
- #+lispworks "impl-lispworks"
+ (:file #+(or allegro clisp cmu sbcl lispworks) "server"
+;; #+lispworks "impl-lispworks"
:depends-on ("compat" "variables"))
(:file "base"
- :depends-on (#+(or allegro clisp cmu sbcl) "server"
- #+lispworks "impl-lispworks"))
+ :depends-on (#+(or allegro clisp cmu sbcl lispworks) "server"
+;; #+lispworks "impl-lispworks"
+ ))
(:file "utils" :depends-on ("base"))
(:file "demo" :depends-on ("utils"))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: package.lisp,v 1.2 2003/07/05 00:51:04 kevin Exp $
+;;;; $Id: package.lisp,v 1.3 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:cl-user)
;; base.lisp
#:modlisp-start
#:modlisp-stop
+ #:modlisp-stop-all
#:header-value
#:write-header-line
#:get-number-worker-requests
(in-package #:modlisp)
-(defun make-socket-server (name function port listener
- &key wait (format :text) function-args)
- (let* ((passive-socket (create-inet-listener port :format format))
- (proc (make-process name
- #'(lambda ()
- (start-socket-server
- passive-socket function listener
- :wait wait
- :function-args function-args)))))
- (values proc passive-socket)))
+(defun make-socket-server (listener)
+ (setf (socket listener) (create-inet-listener
+ (port listener)
+ :format (listener-format listener)))
+ (setf (process listener) (make-process
+ (name listener)
+ #'(lambda () (start-socket-server listener))))
+ listener)
(defmethod initialize-instance :after
- ((self worker) &key listener socket func name function-args
- &allow-other-keys)
- (unless socket
- (error "socket not provided to modlisp-worker"))
+ ((self worker) &key listener connection name &allow-other-keys)
+ (unless connection
+ (error "connection not provided to modlisp-worker"))
(setf (slot-value self 'listener) listener)
- (setf (slot-value self 'func) func)
- (setf (slot-value self 'function-args) function-args)
+ (setf (slot-value self 'name) name)
+ (setf (slot-value self 'connection) connection)
(setf (slot-value self 'thread-fun)
- #'(lambda ()
- (unwind-protect
- (handler-case
- (apply #'apache-command-issuer socket func function-args)
- (error (e)
- (cmsg "Error ~A [~A]" e name)
- ;;(error e)
- ))
+ #'(lambda ()
+ (unwind-protect
+ (handler-case
+ (apply (listener-function listener)
+ connection
+ (function-args listener))
+ (error (e)
+ (cmsg "Error ~A [~A]" e name)
+ (error e)
+ ))
(progn
- (errorset (close-active-socket socket) nil)
+ (errorset (close-active-socket connection) nil)
(cmsg-c :threads "~A ended" name)
(setf (workers listener)
- (remove self (workers listener))))))))
+ (remove self (workers listener))))))))
-(defun start-socket-server (passive-socket function listener
- &key wait function-args)
+(defun start-socket-server (listener)
(unwind-protect
(loop
- (let ((connection (accept-tcp-connection passive-socket)))
- (if wait
- (unwind-protect
- (funcall connection function)
- (errorset (close connection) nil))
- (let ((worker (make-instance 'worker :listener listener
- :func function
- :function-args function-args
- :name (next-worker-name)
- :socket connection)))
+ (let ((connection (accept-tcp-connection (socket listener))))
+ (if (wait listener)
+ (unwind-protect
+ (apply (listener-function listener)
+ connection
+ (function-args listener))
+ (errorset (close connection) nil))
+ (let ((worker (make-instance 'worker :listener listener
+ :connection connection
+ :name (next-worker-name))))
(setf (process worker)
(make-process (name worker) (thread-fun worker)))
(push worker (workers listener))))))
- (errorset (close-passive-socket passive-socket) nil)))
+ (errorset (close-passive-socket (socket listener)) nil)))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: utils.lisp,v 1.2 2003/07/05 00:51:04 kevin Exp $
+;;;; $Id: utils.lisp,v 1.3 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:modlisp)
(setq ,result (progn ,@body)))))
(cond
(,precomp
- (write-header-line "Content-Length" (write-to-string (length ,outstr)))
+ (write-header-line "Content-Length"
+ (write-to-string (length ,outstr)))
(write-header-line "Keep-Socket" "1")
(write-string "end" *apache-socket*)
(write-char #\NewLine *apache-socket*)
(write-string ,outstr *apache-socket*)
+ (force-output *apache-socket*)
(set-close-apache-socket nil))
(t
- (finish-output *apache-socket*)
- (set-close-apache-socket t)))
+ (set-close-apache-socket t)
+ (finish-output *apache-socket*)))
,result)))
(defun redirect-to-location (url)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
-;;;; $Id: variables.lisp,v 1.4 2003/07/05 22:54:00 kevin Exp $
+;;;; $Id: variables.lisp,v 1.5 2003/07/08 06:40:00 kevin Exp $
;;;; *************************************************************************
(in-package #:modlisp)
(defvar *close-apache-socket* t)
(defclass listener ()
- ((process :initarg process :accessor process)
- (socket :initarg socket :accessor socket)
+ ((port :initarg :port :accessor port)
+ (function :initarg :function :accessor listener-function
+ :initform nil)
+ (function-args :initarg :function-args :accessor function-args
+ :initform nil)
+ (process :initarg :process :accessor process)
+ (socket :initarg :socket :accessor socket)
(workers :initform nil :accessor workers
- :documentation "list of worker threads")))
+ :documentation "list of worker threads")
+ (name :initform "" :accessor name :initarg :name)
+ (wait :initform nil :accessor wait :initarg :wait)
+ (format :initform :text :accessor listener-format :initarg :format)))
(defvar *active-listeners* nil
"List of active listeners")
(defclass worker ()
((listener :initarg :listener :accessor listener :initform nil)
+ (connection :initarg :connection :accessor connection :initform nil)
(name :initarg :name :accessor name :initform nil)
- (func :initarg :func :accessor func :initform nil)
- (function-args :initarg :function-args :accessor function-args
- :initform nil)
- (socket :initarg :socket :accessor socket :initform nil)
(thread-fun :initarg :thread-fun :accessor thread-fun :initform nil)
(process :initarg :process :accessor process :initform nil)))
projects / cl-modlisp.git / commitdiff