(in-package #:modlisp)
(defun modlisp-start (&key (port +default-modlisp-port+)
- (processor 'demo-modlisp-command-processor)
- (processor-args nil)
- (catch-errors t)
- timeout
- number-fixed-workers
- remote-host-checker)
+ (processor 'demo-modlisp-command-processor)
+ (processor-args nil)
+ (catch-errors t)
+ timeout
+ number-fixed-workers
+ remote-host-checker)
(let* ((server (make-instance 'ml-server
- :processor processor
- :processor-args processor-args
- :port port))
- (listener (make-instance 'listener :port port
- :base-name "modlisp"
- :function 'modlisp-command-issuer
- :function-args (list server)
- :format :text
- :wait nil
- :catch-errors catch-errors
- :timeout timeout
- :number-fixed-workers number-fixed-workers
- :remote-host-checker remote-host-checker)))
+ :processor processor
+ :processor-args processor-args
+ :port port))
+ (listener (make-instance 'listener :port port
+ :base-name "modlisp"
+ :function 'modlisp-command-issuer
+ :function-args (list server)
+ :format :text
+ :wait nil
+ :catch-errors catch-errors
+ :timeout timeout
+ :number-fixed-workers number-fixed-workers
+ :remote-host-checker remote-host-checker)))
(setf (listener server) listener)
(init/listener listener :start)
(setf *ml-server* server)
"generates commands from modlisp, issues commands to processor-fun"
(unwind-protect
(progn
- (let ((*number-worker-requests* 0)
- (*close-modlisp-socket* t)
- (*ml-server* server))
- (do ((command (read-modlisp-command) (read-modlisp-command)))
- ((null command))
- (apply (processor server) command (processor-args server))
- (finish-output *modlisp-socket*)
- (incf *number-worker-requests*)
- (incf *number-server-requests*)
- (when *close-modlisp-socket*
- (return)))))
+ (let ((*number-worker-requests* 0)
+ (*close-modlisp-socket* t)
+ (*ml-server* server))
+ (do ((command (read-modlisp-command) (read-modlisp-command)))
+ ((null command))
+ (apply (processor server) command (processor-args server))
+ (finish-output *modlisp-socket*)
+ (incf *number-worker-requests*)
+ (incf *number-server-requests*)
+ (when *close-modlisp-socket*
+ (return)))))
(close-active-socket *modlisp-socket*)))
-
+
(defun header-value (header key)
"Returns the value of a modlisp header"
(cdr (assoc key header :test #'eq)))
(defun read-modlisp-command ()
(ignore-errors
(let* ((header (read-modlisp-header))
- (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 *modlisp-socket*)
- (push (cons :posted-content content) header))
- header)))
+ (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 *modlisp-socket*)
+ (push (cons :posted-content content) header))
+ header)))
(defun read-modlisp-line ()
(kmrcl:string-right-trim-one-char
#\return
- (read-line *modlisp-socket* nil nil)))
+ (read-line *modlisp-socket* nil nil)))
(defun read-modlisp-header ()
(output-html-page (fixed-html-string)))
((equal url "/precompute.lsp")
(with-ml-page (:precompute t)
- (write-precomputed-page)))
+ (write-precomputed-page)))
(t
(with-ml-page (:precompute nil)
- (write-debug-table command))))))
+ (write-debug-table command))))))
(defun write-debug-table (command)
(write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<thead><tr><th>Key</th><th>Value</th></tr></thead>
<tbody>" *modlisp-socket*)
(loop for (key . value) in command do
- (format *modlisp-socket* "<tr><td>~a</td><td>~a</td></tr>" key value))
+ (format *modlisp-socket* "<tr><td>~a</td><td>~a</td></tr>" key value))
(write-string "</tbody></table></body></html>" *modlisp-socket*))
(defun write-request-counts (s)
(format s "<p>Number of server requests: ~D</p>"
- *number-server-requests*)
+ *number-server-requests*)
(format s "<p>Number of worker requests for this socket: ~D</p>"
- *number-worker-requests*))
+ *number-worker-requests*))
-
-;;; A small test bench used to test and time the client/server protocol
+
+;;; 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)
+ 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)
+ 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)
- (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)))
+ (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)))))
+ 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))
#:*number-server-requests*
#:*ml-server*
#:*close-modlisp-socket*
-
+
;; base.lisp
#:modlisp-start
#:modlisp-stop
#:header-value
#:write-header-line
#:set-close-modlisp-socket
-
+
;; utils.lisp
#:output-ml-page
#:output-html-page
(:xml "text/xml")
(:text "text/plain")
(otherwise fmt)))
-
+
(defun format-string (fmt headers)
`(("Content-Type" .
,(format->string fmt))
,result))))
(defmacro with-ml-page ((&key (format :html) (precompute t) headers)
- &body body)
+ &body body)
(if precompute
`(output-ml-page ,format (with-output-to-string (*modlisp-socket*) ,@body) :headers ,headers)
`(write-response (:headers (format-string ,format ,headers)) ,@body)))
(when posted-string
(let ((alist '()))
(dolist (name=val (kmrcl:delimited-string-to-list posted-string #\&)
- (nreverse alist))
- (let ((name-val-list (kmrcl:delimited-string-to-list name=val #\=)))
- (if (= 2 (length name-val-list))
- (destructuring-bind (name val) name-val-list
- (push (cons (if keyword
- (kmrcl:ensure-keyword name)
- name)
- (kmrcl:decode-uri-query-string val))
- alist))
- (cmsg-c :debug "Invalid number of #\= in ~S" name-val-list)))))))
+ (nreverse alist))
+ (let ((name-val-list (kmrcl:delimited-string-to-list name=val #\=)))
+ (if (= 2 (length name-val-list))
+ (destructuring-bind (name val) name-val-list
+ (push (cons (if keyword
+ (kmrcl:ensure-keyword name)
+ name)
+ (kmrcl:decode-uri-query-string val))
+ alist))
+ (cmsg-c :debug "Invalid number of #\= in ~S" name-val-list)))))))
(port :initarg :port :initform nil :accessor port)
(processor :initarg :processor :initform nil :accessor processor)
(processor-args :initarg :processor-args :initform nil
- :accessor processor-args)))
-
-
+ :accessor processor-args)))
+
+
+
-
projects / cl-modlisp.git / commitdiff