From 1f9d1b0e3fa6500325b7b4fe8b9d10b53009f225 Mon Sep 17 00:00:00 2001 From: Matthew Mondor Date: Thu, 10 Sep 2015 10:46:45 -0400 Subject: [PATCH] Various previously uncommitted changes, test/example applications still need adaptation to new API changes. --- mmsoftware/cl/server/ecl-mp-server.lisp | 199 ++++++++++++++++++++++++-------- mmsoftware/cl/server/html.lisp | 5 +- mmsoftware/cl/server/httpd-config.lisp | 2 +- mmsoftware/cl/server/httpd.lisp | 9 +- 4 files changed, 161 insertions(+), 54 deletions(-) diff --git a/mmsoftware/cl/server/ecl-mp-server.lisp b/mmsoftware/cl/server/ecl-mp-server.lisp index 0ee0c89..70c953b 100644 --- a/mmsoftware/cl/server/ecl-mp-server.lisp +++ b/mmsoftware/cl/server/ecl-mp-server.lisp @@ -55,6 +55,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #:make-server-config #:log-clear #:log-tail + #:log-resize #:log-line #:log-line-nostamp #:with-log-errors @@ -110,7 +111,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (log-syslog t :type boolean) (log-syslog-ident "ecl-mp-server" :type string) (log-syslog-facility syslog:+log-user+ :type fixnum) - (log-fifo-lines 0 :type fixnum) + (log-history-lines 0 :type fixnum) (input-timeout 60 :type fixnum) (children-initial 16 :type fixnum) (children-minspare 16 :type fixnum) @@ -365,46 +366,140 @@ suitable for hashing." (svref addr 3))) -;;; Implementation of a simple thread-safe FIFO buffer with limited entries. +;;; Implementation of a simple thread-safe backlog buffer minimizing consing +;;; Eventually compare to a specialized thread -(defstruct fifo - "A FIFO buffer. See FIFO-APPEND, FIFO-CLEAR. -FIFO objects use an internal lock for safe concurrency." - (head '() :type list) - (tail '() :type list) - (count 0 :type fixnum) +(defstruct (buffer (:constructor %make-buffer)) + "A history backlog buffer designed to minimize consing and fragmentation. +See: MAKE-BUFFER, BUFFER-APPEND, BUFFER-CLEAR, BUFFER-HISTORY, BUFFER-RESIZE. +BUFFER objects use an internal lock for safe concurrency." + (buf #() :type (simple-vector *)) + (head 0 :type fixnum) + (tail 0 :type fixnum) (size 0 :type fixnum) - (lock (mp:make-lock :name 'fifo-lock) :type mp:lock)) - -(defun fifo-append (fifo object) - "Appends OBJECT to FIFO." + (lock (mp:make-lock :name 'buffer-lock :recursive t) :type mp:lock)) + +(defun make-buffer (size) + "Creates a new BUFFER which may hold a history of up to SIZE objects." + (check-type size fixnum) + (let ((size (1+ size))) + (%make-buffer :size size + :buf (make-array size + :initial-element nil + :adjustable nil + :fill-pointer nil)))) + +(defun buffer-append (buffer object) + "Appends OBJECT to BUFFER, discarding the oldest entry if full. +Optimized for speed and consing avoidance as may be called very frequently." (declare (optimize (speed 3) (safety 0) (debug 0))) - (with-accessors ((head fifo-head) (tail fifo-tail) - (count fifo-count) (size fifo-size) - (lock fifo-lock)) fifo - (mp:with-lock (lock) - (if (= (the fixnum count) (the fixnum size)) - (setf head (rest head)) - (incf (the fixnum count))) - (let ((new (cons object nil))) - (if (null head) - (setf head new - tail new) - (setf (rest tail) new - tail new))))) - nil) + (with-accessors ((bhead buffer-head) (btail buffer-tail)) buffer + (mp:with-lock ((buffer-lock buffer)) + (let ((head bhead) + (tail btail) + (size (buffer-size buffer)) + (buf (buffer-buf buffer))) + (declare (type fixnum head tail size) + (type (simple-vector *) buf)) + (let ((newtail (1+ tail))) + (declare (type fixnum newtail)) + (when (= newtail size) + (setf newtail 0)) + (setf (svref buf tail) object + btail newtail) + (when (= newtail head) + (incf head) + (when (= head size) + (setf head 0)) + (setf bhead head)))))) + (values)) -(defun fifo-clear (fifo) - "Resets/clears FIFO." - (mp:with-lock ((fifo-lock fifo)) - (let ((list '())) - (setf (fifo-head fifo) list - (fifo-tail fifo) list - (fifo-count fifo) 0))) - nil) +(defun buffer-clear (buffer) + "Resets/clears BUFFER. Objects may remain referenced until the buffer +fills again to override them." + (mp:with-lock ((buffer-lock buffer)) + (setf (buffer-head buffer) 0 + (buffer-tail buffer) 0)) + (values)) + +(defun buffer-history (buffer) + "Returns a list holding all the currently held objects of BUFFER. +Conses but is rarely called versus BUFFER-APPEND." + (declare (optimize (speed 3) (safety 0) (debug 0))) + (check-type buffer buffer) + (mp:with-lock ((buffer-lock buffer)) + (loop + with vector of-type (simple-vector *) = (buffer-buf buffer) + with head of-type fixnum = (buffer-head buffer) + with tail of-type fixnum = (buffer-tail buffer) + with size of-type fixnum = (buffer-size buffer) + for i of-type fixnum = head then (the fixnum (1+ (the fixnum i))) + when (= size i) do (setf i 0) + until (= tail i) + collect (svref vector i)))) + +(defmacro with-buffer-iterator ((buffer entry) &body body) + "Iterates over all currently held objects of BUFFER, binds ENTRY to it and +evaluates BODY." + (let ((buffer-s (gensym)) + (vector-s (gensym)) + (head-s (gensym)) + (tail-s (gensym)) + (size-s (gensym)) + (i-s (gensym))) + `(let ((,buffer-s ,buffer)) + (mp:with-lock ((buffer-lock ,buffer-s)) + (loop + with ,vector-s of-type (symple-vector *) = + (buffer-buf ,buffer-s) + with ,head-s of-type fixnum = (buffer-head ,buffer-s) + with ,tail-s of-type fixnum = (buffer-tail ,buffer-s) + with ,size-s of-type fixnum = (buffer-size ,buffer-s) + for ,i-s of-type fixnum = + ,head-s then (the fixnum (1+ (the fixnum ,i-s))) + when (= ,size-s ,i-s) do (setf ,i-s 0) + until (= ,tail-s ,i-s) + do + (let ((,entry (svref ,vector-s ,i-s))) + ,@body)))))) + +(defun buffer-resize (buffer newsize) + "Resizes BUFFER to be able to hold SIZE number of items. +The old history is preserved but may be partial if the size is shrunk." + (declare (optimize (speed 3) (safety 0) (debug 0)) + (type fixnum newsize)) + (check-type buffer buffer) + (check-type newsize fixnum) + (incf newsize) + (mp:with-lock ((buffer-lock buffer)) + (with-accessors ((bbuf buffer-buf) + (bhead buffer-head) + (btail buffer-tail) + (bsize buffer-size)) buffer + (let ((oldbuf bbuf) + (oldhead (the fixnum bhead)) + (oldtail (the fixnum btail)) + (oldsize (the fixnum bsize))) + (declare (type (simple-vector *) oldbuf) + (type fixnum oldhead oldtail oldsize)) + (setf bbuf (make-array newsize + :initial-element nil + :adjustable nil + :fill-pointer nil) + bhead 0 + btail 0 + bsize newsize) + (loop + for i of-type fixnum = oldhead then + (the fixnum (1+ (the fixnum i))) + when (= oldsize i) do (setf i 0) + until (= oldtail i) + do + (buffer-append buffer (svref oldbuf i)))))) + (values)) -;;; Simple memory log implementation using the above FIFO, +;;; Simple memory log implementation using the above buffer, ;;; or using syslog(3) (defvar *log-syslog* nil) @@ -420,8 +515,8 @@ time." (when *log-syslog* (syslog:syslog syslog:+log-info+ l)) (when *log-buffer* - (fifo-append *log-buffer* - (format nil "~A ~A" (server-time-posix) l)))) + (buffer-append *log-buffer* + (format nil "~A ~A" (server-time-posix) l)))) (values)) (declaim (inline log-line-nostamp)) @@ -433,24 +528,32 @@ time." (when *log-syslog* (syslog:syslog syslog:+log-info+ l)) (when *log-buffer* - (fifo-append *log-buffer* l))) + (buffer-append *log-buffer* l))) (values)) (defun log-clear () "Clears the in-memory server log." (when *log-buffer* - (fifo-clear *log-buffer*)) + (buffer-clear *log-buffer*)) (values)) (defun log-tail () "Writes to *STANDARD-OUTPUT* the contents of the server log." (when *log-buffer* (loop - for line in (fifo-head *log-buffer*) + with lines = (buffer-history *log-buffer*) + for line in lines do (write-string (format nil "~A~%" line)))) (values)) +(defun log-resize (backlog) + "Resizes the log history buffer. +The old backlog is preserved but may be partial if the buffer is shrunk." + (when *log-buffer* + (buffer-resize *log-buffer* backlog)) + (values)) + (declaim (inline log-connection)) (defun log-connection (connect session address port) (log-line "~X ~A: [~A:~A]" @@ -605,9 +708,9 @@ server threads." (setf (stream-external-format *standard-output*) '(:LATIN-1 :LF))) (ext:catch-signal ext:+sigpipe+ :ignore) (setf *server-socket* (bind-socket)) - (let ((log-fifo-lines (config-log-fifo-lines *config*))) - (unless (zerop log-fifo-lines) - (setf *log-buffer* (make-fifo :size log-fifo-lines)))) + (let ((log-history-lines (config-log-history-lines *config*))) + (unless (zerop log-history-lines) + (setf *log-buffer* (make-buffer log-history-lines)))) (when (config-log-syslog *config*) (syslog:openlog (config-log-syslog-ident *config*) (logior syslog:+log-ndelay+ syslog:+log-pid+) @@ -1031,14 +1134,12 @@ in which case output will not preserve the original bytes. To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT." (declare (type fixnum max) (optimize (speed 3) (safety 0) (debug 0))) - (macrolet ((add-char (c orelse) + (macrolet ((add-char (c) `(if (<= nchars max) (progn (vector-push-extend ,c line 1024) (the fixnum (incf (the fixnum nchars)))) - ,(if (eq :finish orelse) - '(loop-finish) - 'nil)))) + (loop-finish)))) (loop with line = (make-array max :element-type 'character @@ -1055,7 +1156,7 @@ To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT." when (= o 10) do (invoke-restart 'use-value (code-char o)) else do - (add-char (code-char o) :finish)) + (add-char (code-char o))) (invoke-restart 'continue))) (simple-error #'(lambda (e) @@ -1071,7 +1172,7 @@ To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT." :errno 0)))) (read-char stream)) until (= (char-code c) 10) do ; Inlines better than CHAR= - (add-char c :finish) + (add-char c) finally (if (= 0 (length line)) (return line) (progn diff --git a/mmsoftware/cl/server/html.lisp b/mmsoftware/cl/server/html.lisp index 98b81a7..3faf7bf 100644 --- a/mmsoftware/cl/server/html.lisp +++ b/mmsoftware/cl/server/html.lisp @@ -32,6 +32,9 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; XXX TODO XXX ;;;; - Also add a few URL utilities (i.e. to create and properly escape ;;;; or unescape them). +;;;; - We use FORMAT when not using WRITE-STRING, which can be slow, see if +;;;; we could safely and correctly use a lower level primitive such as +;;;; PRINC, PRINC-TO-STRING, WRITE, etc. ;;; XXX If SAFETY is 1 compiling code using DO-HTML may segfault! @@ -234,7 +237,7 @@ are suffixed with ' /', automatically." (mapcar #'(lambda (i) (if (stringp i) `(write-string ,i ,s) - `(format ,s "~A" ,i))) + `(princ ,i s))) l))) `(let ((*print-pretty* nil)) ,(if stream diff --git a/mmsoftware/cl/server/httpd-config.lisp b/mmsoftware/cl/server/httpd-config.lisp index 6fc2819..47eea60 100644 --- a/mmsoftware/cl/server/httpd-config.lisp +++ b/mmsoftware/cl/server/httpd-config.lisp @@ -8,7 +8,7 @@ :children-minspare 32 :children-maxspare 32 :children-maximum 32 - :log-fifo-lines 0 + :log-history-lines 0 :log-syslog t :log-syslog-facility syslog:+log-authpriv+ diff --git a/mmsoftware/cl/server/httpd.lisp b/mmsoftware/cl/server/httpd.lisp index 25fa698..98d7853 100644 --- a/mmsoftware/cl/server/httpd.lisp +++ b/mmsoftware/cl/server/httpd.lisp @@ -260,7 +260,8 @@ The application should then only trust the objects returned by this function. Returns NIL if PATH is invalid. On success, returns a PATH object with: REAL: System-wide absolute real fullpath, to be used to access the - file/directory in question + file/directory in question by the application, which should not + be disclosed to the user. VIRTUAL: The virtual ROOT-based absolute fullpath, useful to report to the user. Note that the supplied ROOT should previously have been passed through @@ -1498,6 +1499,8 @@ a single range covering the whole document, NIL is returned." collect optimized into final finally (return (sort final #'(lambda (a b) (< (first a) (first b))))))) + ;; (member optimized final :test #'equal) ? + ;; (sort final #'< :key #'first) ? ;; Coalesce any redundant contiguous ranges together (coalesced-ranges @@ -1530,8 +1533,8 @@ a single range covering the whole document, NIL is returned." (cond ,@(loop for pair in match-code-pairs - for (string code) = pair - collect `((,test-function ,string ,s-var) ,code)) + for (string . code) = pair + collect `((,test-function ,string ,s-var) ,@code)) (t ,default))))) ;;; Utility macro which hashes VAR at runtime but has every constant object -- 2.9.0