Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

i dont know what the fuck im doing

  • Loading branch information...
commit 7de01364aaa68dce796e701485b92c6761d65840 2 parents 09de463 + e2deeb5
Mike Travers authored
1  aserve.asd
@@ -16,6 +16,7 @@
16 16 (:static-file "ChangeLog")))
17 17 (:cl-file "packages")
18 18 (:cl-file "macs")
  19 + (:cl-file "queue")
19 20 (:cl-file "main")
20 21 (:cl-file "headers")
21 22 (:cl-file "parse")
20 chunker.cl
@@ -38,6 +38,11 @@
38 38 (def-stream-class chunking-stream (single-channel-simple-stream)
39 39 ())
40 40
  41 +(defvar *binary-crlf*
  42 + (make-array 2 :element-type '(unsigned-byte 8)
  43 + :initial-contents '(#.(char-code #\return)
  44 + #.(char-code #\linefeed))))
  45 +
41 46
42 47 (defmethod device-open ((p chunking-stream) dummy options)
43 48 (declare (ignore dummy))
@@ -80,9 +85,10 @@
80 85 (if* (> end start)
81 86 then ; write it out with chunking
82 87 ; chunk header
83   - (format output "~x~a" (- end start) *crlf*)
  88 + (format output "~x" (- end start))
  89 + (write-sequence *binary-crlf* output)
84 90 (write-sequence buffer output :start start :end end)
85   - (write-string *crlf* output)
  91 + (write-sequence *binary-crlf* output)
86 92 (force-output output)))
87 93
88 94 end)
@@ -99,7 +105,9 @@
99 105 (if* (not abort) then (force-output p))
100 106
101 107 ; chunking eof
102   - (format inner-stream "0~a~a" *crlf* *crlf*)
  108 + (write-char #\0 inner-stream)
  109 + (write-sequence *binary-crlf* inner-stream)
  110 + (write-sequence *binary-crlf* inner-stream)
103 111 (force-output inner-stream)
104 112 p))
105 113
@@ -161,7 +169,7 @@
161 169
162 170 (setq buffer (or buffer (slot-value p 'excl::buffer)))
163 171 (setq end (or end (length buffer)))
164   -
  172 +
165 173 (loop
166 174 (let ((state (unchunking-state p))
167 175 (ins (slot-value p 'excl::input-handle)))
@@ -190,14 +198,14 @@
190 198 then (return) ; valid count
191 199 else ; non hex char
192 200 (error "bad chunking count"))))
193   -
  201 +
194 202 ; now skip to newline
195 203 (loop
196 204 (let ((ch (read-byte ins nil nil)))
197 205 (if* (null ch) then (error "premature eof before chunking data"))
198 206 (if* (eq ch #.(char-int #\newline))
199 207 then (return))))
200   -
  208 +
201 209 (if* (zerop count)
202 210 then ; chunking eof, read trailers and trailing crlf
203 211 (let ((seen-stuff-on-line nil))
13 doc/aserve.html
@@ -36,8 +36,15 @@
36 36 </tbody>
37 37 </table>
38 38 <h1 align="center">AllegroServe - A Web Application Server<br>
39   -<small><small><small>version <font face="Courier New">1.3.3</font></small></small></small></h1>
  39 +<small><small><small>version <font face="Courier New">1.3.4</font></small></small></small></h1>
40 40 <p align="left"><strong><small>copyright(c) 2000-2011. Franz Inc</small></strong></p>
  41 +
  42 +<p>
  43 +AllegroServe is available for download as part of Allegro CL (see <a
  44 + href="http://www.franz.com/">www.franz.com</a>) or
  45 + at <a href="https://github.com/franzinc/aserve/">https://github.com/franzinc/aserve/</a>. See <a
  46 + href="http://www.franz.com/support/documentation/current/doc/aserve/aserve.html">www.franz.com/support/documentation/current/doc/aserve/aserve.html</a> for the latest available version of this document.
  47 +</p>
41 48 <h2 align="left">Table of Contents</h2>
42 49 <p align="left"><a href="#introduction">Introduction</a><br>
43 50 <a href="#running-AllegroServe">Running AllegroServe</a><br>
@@ -158,7 +165,7 @@ <h2 align="left">Table of Contents</h2>
158 165 <br>
159 166 </p>
160 167 <h2 align="left">In<a name="introduction"></a>troduction</h2>
161   -<p><strong>AllegroServe </strong>is a webserver&nbsp; written at <a
  168 +<p><strong>AllegroServe</strong> is a webserver&nbsp; written at <a
162 169 href="http://www.franz.com">Franz Inc</a>.&nbsp;&nbsp;AllegroServe is
163 170 designed to work
164 171 with the <a href="htmlgen.html">htmlgen</a> system for generating
@@ -190,7 +197,7 @@ <h2 align="left">In<a name="introduction"></a>troduction</h2>
190 197 latest release of Allegro CL.&nbsp; AllegroServe is supported on
191 198 earlier releases. See <a
192 199 href="http://www.franz.com/support/documentation/">www.franz.com/support/documentation/</a>
193   -for links to documentation of earlier releases.
  200 +for links to documentation of earlier releases.
194 201 <p>&nbsp;</p>
195 202 <h2><a name="running-AllegroServe"></a>Running AllegroServe</h2>
196 203 <p>Running&nbsp; AllegroServe requires that you </p>
6 load.cl
@@ -4,6 +4,8 @@
4 4 ;;
5 5 ;; $Id: load.cl,v 1.69 2008/02/04 21:02:24 jkf Exp $
6 6 ;;
  7 +;; load in aserve
  8 +
7 9
8 10 ;
9 11 ; loading this file will compile and load AllegroServe (+++mt NOT Webactions and examples)
@@ -11,7 +13,8 @@
11 13 ; calling (make-aserve.fasl) will build
12 14 ; aserve.fasl - just allegroserve
13 15 ; webactions/webactions.fasl - just webactions
14   -;
  16 +
  17 +(in-package :user)
15 18
16 19 (defvar *loadswitch* :compile-if-needed)
17 20 (defparameter *aserve-root* (directory-namestring *load-pathname*))
@@ -21,6 +24,7 @@
21 24 '("htmlgen/htmlgen"
22 25 "packages"
23 26 "macs"
  27 + "queue"
24 28 "main"
25 29 "headers"
26 30 "parse"
8 log.cl
@@ -95,7 +95,13 @@
95 95
96 96 (macrolet ((do-log ()
97 97 '(progn (format stream
98   - "~a - - [~a] ~s ~s ~s~%"
  98 + "~A~A~a - - [~a] ~s ~s ~s~%"
  99 + (if* *log-wserver-name*
  100 + then (wserver-name *wserver*)
  101 + else "")
  102 + (if* *log-wserver-name*
  103 + then " "
  104 + else "")
99 105 (socket:ipaddr-to-dotted ipaddr)
100 106 (maybe-universal-time-to-date time)
101 107 (request-raw-request req)
16 macs.cl
@@ -301,6 +301,22 @@
301 301 ((t :macros) `(excl::.atomically (excl::fast ,@body)))
302 302 (nil `(excl::atomically (excl::fast ,@body)))))
303 303
  304 +
  305 +(defmacro atomic-setf-max (place val)
  306 + (smp-case
  307 + (nil (let ((newvar (gensym)))
  308 + `(let ((,newvar ,val))
  309 + (without-interrupts
  310 + (if* (< ,place ,newvar) then (setf ,place ,newvar) t)))))
  311 + ((t :macros) (let ((newvar (gensym)) (oldvar (gensym)))
  312 + `(let ((,newvar ,val) ,oldvar)
  313 + (loop
  314 + (setq ,oldvar ,place)
  315 + (cond ((not (< ,oldvar ,newvar)) (return nil))
  316 + ((atomic-conditional-setf ,place ,newvar ,oldvar)
  317 + (return t)))))))))
  318 +
  319 +
304 320 ;;;;;; end of smp-aware macro definitions
305 321
306 322
142 main.cl
@@ -38,7 +38,7 @@
38 38 #+ignore
39 39 (check-smp-consistency)
40 40
41   -(defparameter *aserve-version* '(1 3 3))
  41 +(defparameter *aserve-version* '(1 3 7))
42 42
43 43 (eval-when (eval load)
44 44 (require :sock)
@@ -158,9 +158,14 @@
158 158 (defun check-for-open-socket-before-gc (socket)
159 159 (if* (open-stream-p socket)
160 160 then (logmess
161   - (format nil
162   - "socket ~s is open yet is about to be gc'ed. It will be closed"
163   - socket))
  161 + (let ((*print-readably* nil))
  162 + ;; explicitly binding *print-readably* nil in order to avoid
  163 + ;; a printer crash if the finalization is run in a thread
  164 + ;; with, say, with-standard-io-syntax that binds *print-readably*
  165 + ;; true.
  166 + (format nil
  167 + "socket ~s is open yet is about to be gc'ed. It will be closed"
  168 + socket)))
164 169 (ignore-errors (close socket))))
165 170
166 171
@@ -181,7 +186,7 @@
181 186
182 187
183 188 ;; more specials
184   -(defvar *max-socket-fd* nil) ; set this to 0 to enable tracking and logging of
  189 +(defvar-mp *max-socket-fd* nil) ; set this to 0 to enable tracking and logging of
185 190 ; the maximum fd returned by accept-connection
186 191 (defvar *aserve-debug-stream* nil) ; stream to which to seen debug messages
187 192 (defvar *debug-connection-reset-by-peer* nil) ; true to signal these too
@@ -222,6 +227,9 @@
222 227
223 228 (defvar *not-modified-entity*) ; used to send back not-modified message
224 229
  230 +(defvar-mp *thread-index* 0) ; globalcounter to gen process names
  231 +
  232 +(defvar *log-wserver-name* nil)
225 233
226 234 ;;;;;;;;;;;;; end special vars
227 235
@@ -340,7 +348,11 @@
340 348 (worker-threads ;; list of threads that can handle http requests
341 349 :initform nil
342 350 :accessor wserver-worker-threads)
343   -
  351 +
  352 + (free-worker-threads
  353 + :initform (make-queue-with-timeout)
  354 + :accessor wserver-free-worker-threads)
  355 +
344 356 (free-workers ;; estimate of the number of workers that are idle
345 357 :initform 0
346 358 :accessor wserver-free-workers)
@@ -389,6 +401,27 @@
389 401 :initform nil
390 402 :initarg :ssl
391 403 :accessor wserver-ssl)
  404 +
  405 + (name
  406 + :initform (format nil "w~d" (atomic-incf *thread-index*))
  407 + :initarg :name
  408 + :reader wserver-name)
  409 +
  410 + ;; The following 3 used to be global variables, but logically they need to
  411 + ;; be specific to each server instance.
  412 + (debug-connection-reset-by-peer
  413 + :initarg :debug-connection-reset-by-peer
  414 + :initform *debug-connection-reset-by-peer*
  415 + :accessor wserver-debug-connection-reset-by-peer)
  416 + (read-request-timeout
  417 + :initarg :read-request-timeout
  418 + :initform *read-request-timeout*
  419 + :accessor wserver-read-request-timeout)
  420 + (read-request-body-timeout
  421 + :initarg :read-request-body-timeout
  422 + :initform *read-request-body-timeout*
  423 + :accessor wserver-read-request-body-timeout)
  424 +
392 425 ))
393 426
394 427
@@ -895,7 +928,6 @@ by keyword symbols and not by strings"
895 928 (defvar *crlf* (make-array 2 :element-type 'character :initial-contents
896 929 '(#\return #\linefeed)))
897 930
898   -(defvar *thread-index* 0) ; globalcounter to gen process names
899 931
900 932
901 933
@@ -1123,6 +1155,7 @@ by keyword symbols and not by strings"
1123 1155 (mp:process-allow-schedule))
1124 1156
1125 1157 (setf (wserver-worker-threads server) nil)
  1158 + (setf (wserver-free-worker-threads server) (make-queue-with-timeout))
1126 1159
1127 1160 (dolist (hook (wserver-shutdown-hooks server))
1128 1161 (funcall hook server))
@@ -1184,30 +1217,40 @@ by keyword symbols and not by strings"
1184 1217 ; create accept thread
1185 1218 (setf (wserver-accept-thread *wserver*)
1186 1219 (mp:process-run-function
1187   - (list :name (format nil "aserve-accept-~d" (incf *thread-index*))
1188   - :initial-bindings
1189   - `((*wserver* . ',*wserver*)
1190   - #+ignore (*debug-io* . ',(wserver-terminal-io *wserver*))
1191   - ,@excl:*cl-default-special-bindings*))
1192   - #'http-accept-thread)))
  1220 + (list :name (format nil "~A-accept-~d"
  1221 + (if* *log-wserver-name*
  1222 + then (wserver-name *wserver*)
  1223 + else "aserve")
  1224 + (atomic-incf *thread-index*))
  1225 + :initial-bindings
  1226 + `((*wserver* . ',*wserver*)
  1227 + #+ignore (*debug-io* . ',(wserver-terminal-io *wserver*))
  1228 + ,@excl:*cl-default-special-bindings*))
  1229 + #'http-accept-thread)))
1193 1230
1194 1231 ;; make-worker-thread wasn't thread-safe before smp. I'm assuming that's
1195 1232 ;; ok, which it will be if only one thread ever calls it, and leaving it
1196 1233 ;; non-thread-safe in the smp version.
1197   -(defun make-worker-thread ()
1198   - (let* ((name (format nil "~d-aserve-worker" (incf *thread-index*)))
  1234 +;; mm 2010-12: this assumption is false if several servers are running.
  1235 +(defun make-worker-thread (&aux (thx (atomic-incf *thread-index*)))
  1236 + (let* ((name (format nil "~d-~A-worker"
  1237 + thx
  1238 + (if* *log-wserver-name*
  1239 + then (wserver-name *wserver*)
  1240 + else "aserve")))
1199 1241 (proc (mp:make-process :name name
1200 1242 :initial-bindings
1201 1243 `((*wserver* . ',*wserver*)
1202 1244 #+ignore (*debug-io* . ',(wserver-terminal-io
1203   - *wserver*))
  1245 + *wserver*))
1204 1246 ,@excl:*cl-default-special-bindings*)
1205 1247 )))
1206 1248 (mp:process-preset proc #'http-worker-thread)
1207 1249 (push proc (wserver-worker-threads *wserver*))
  1250 + (enqueue (wserver-free-worker-threads *wserver*) proc)
1208 1251 (incf-free-workers *wserver* 1)
1209 1252 (setf (getf (mp:process-property-list proc) 'short-name)
1210   - (format nil "w~d" *thread-index*))
  1253 + (format nil "w~d" thx))
1211 1254 ))
1212 1255
1213 1256
@@ -1285,7 +1328,7 @@ by keyword symbols and not by strings"
1285 1328 ((stream-error
1286 1329 #'(lambda (c)
1287 1330 (if* (and
1288   - (not *debug-connection-reset-by-peer*)
  1331 + (not (wserver-debug-connection-reset-by-peer *wserver*))
1289 1332 (connection-reset-error c))
1290 1333 then (throw 'out-of-connection nil)))))
1291 1334 (process-connection sock)))))
@@ -1294,8 +1337,9 @@ by keyword symbols and not by strings"
1294 1337 :report "Abandon this request and wait for the next one"
1295 1338 nil))
1296 1339 (incf-free-workers *wserver* 1)
1297   - (mp:process-revoke-run-reason sys:*current-process* sock))
1298   -
  1340 + (enqueue (wserver-free-worker-threads *wserver*) sys:*current-process*)
  1341 + (mp:process-revoke-run-reason sys:*current-process* sock))
  1342 +
1299 1343 )))
1300 1344
1301 1345 (defun connection-reset-error (c)
@@ -1315,7 +1359,6 @@ by keyword symbols and not by strings"
1315 1359 ;; ignore sporatic errors but stop if we get a few consecutive ones
1316 1360 ;; since that means things probably aren't going to get better.
1317 1361 (let* ((error-count 0)
1318   - (workers nil)
1319 1362 (server *wserver*)
1320 1363 (main-socket (wserver-socket server))
1321 1364 (ipaddrs (wserver-ipaddrs server))
@@ -1351,11 +1394,9 @@ by keyword symbols and not by strings"
1351 1394 ; descriptors
1352 1395 (if* *max-socket-fd*
1353 1396 then (let ((fd (excl::stream-input-fn sock)))
1354   - (if* (> fd *max-socket-fd*)
1355   - then (setq *max-socket-fd* fd)
1356   - (logmess (format nil
1357   - "Maximum socket file descriptor number is now ~d" fd)))))
1358   -
  1397 + (if* (atomic-setf-max *max-socket-fd* fd)
  1398 + then (logmess (format nil
  1399 + "Maximum socket file descriptor number is now ~d" fd)))))
1359 1400
1360 1401 (setq error-count 0) ; reset count
1361 1402
@@ -1364,32 +1405,27 @@ by keyword symbols and not by strings"
1364 1405 ; for one so we can handle cases where the workers are all busy
1365 1406 (let ((looped 0))
1366 1407 (loop
1367   - (if* (null workers)
1368   - then (case looped
1369   - (0 nil)
1370   - ((1 2 3) (logmess "all threads busy, pause")
1371   - (if* (>= (incf busy-sleeps) 4)
1372   - then ; we've waited too many times
1373   - (setq busy-sleeps 0)
1374   - (logmess "too many sleeps, will create a new thread")
1375   - (make-worker-thread)
1376   - else (sleep 1)))
  1408 + (multiple-value-bind (worker found-worker-p) (dequeue (wserver-free-worker-threads server) :wait 1)
  1409 + (if* (not found-worker-p)
  1410 + then (case looped
  1411 + (0 nil)
  1412 + ((1 2 3) (logmess "all threads busy, pause")
  1413 + (if* (>= (incf busy-sleeps) 4)
  1414 + then ; we've waited too many times
  1415 + (setq busy-sleeps 0)
  1416 + (logmess "too many sleeps, will create a new thread")
  1417 + (make-worker-thread)))
1377 1418
1378   - (4 (logmess "forced to create new thread")
1379   - (make-worker-thread))
  1419 + (4 (logmess "forced to create new thread")
  1420 + (make-worker-thread))
1380 1421
1381   - (5 (logmess "can't even create new thread, quitting")
1382   - (return-from http-accept-thread nil)))
  1422 + (5 (logmess "can't even create new thread, quitting")
  1423 + (return-from http-accept-thread nil)))
1383 1424
1384   - (setq workers (wserver-worker-threads server))
1385   - (incf looped))
1386   - (if* (null (mp:process-run-reasons (car workers)))
1387   - then (incf-free-workers server -1)
1388   - (mp:process-add-run-reason (car workers) sock)
1389   - (pop workers)
1390   - (return) ; satisfied
1391   - )
1392   - (pop workers))))
  1425 + (incf looped)
  1426 + else (incf-free-workers server -1)
  1427 + (mp:process-add-run-reason worker sock)
  1428 + (return))))))
1393 1429
1394 1430 (error (cond)
1395 1431 (logmess (format nil "accept: error ~s on accept ~a"
@@ -1454,7 +1490,7 @@ by keyword symbols and not by strings"
1454 1490 (loop
1455 1491 (multiple-value-setq (req error-obj)
1456 1492 (ignore-errors
1457   - (with-timeout-local (*read-request-timeout*
  1493 + (with-timeout-local ((wserver-read-request-timeout *wserver*)
1458 1494 (debug-format :info "request timed out on read~%")
1459 1495 (return-from process-connection nil))
1460 1496 (read-http-request sock chars-seen))))
@@ -1704,7 +1740,7 @@ by keyword symbols and not by strings"
1704 1740 (read-sequence-with-timeout
1705 1741 ret length
1706 1742 (request-socket req)
1707   - *read-request-body-timeout*))
  1743 + (wserver-read-request-body-timeout *wserver*)))
1708 1744
1709 1745 ; netscape (at least) is buggy in that
1710 1746 ; it sends a crlf after
@@ -1735,7 +1771,7 @@ by keyword symbols and not by strings"
1735 1771 :input-chunking t)
1736 1772
1737 1773 (with-timeout-local
1738   - (*read-request-body-timeout* nil)
  1774 + ((wserver-read-request-body-timeout *wserver*) nil)
1739 1775 (let ((ans (make-array
1740 1776 2048
1741 1777 :element-type 'character
@@ -1767,7 +1803,7 @@ by keyword symbols and not by strings"
1767 1803 ""
1768 1804 else ; read until the end of file
1769 1805 (with-timeout-local
1770   - (*read-request-body-timeout*
  1806 + ((wserver-read-request-body-timeout *wserver*)
1771 1807 nil)
1772 1808 (let ((ans (make-array
1773 1809 2048
1  makefile
@@ -30,6 +30,7 @@ build: FORCE
30 30 test: FORCE
31 31 rm -f build.tmp
32 32 echo '(setq excl::*break-on-warnings* t)' >> build.tmp
  33 + echo '(setq util.test::*break-on-test-failures* t)' >> build.tmp
33 34 echo '(load "load.cl")' >> build.tmp
34 35 echo '(dribble "test.out")' >> build.tmp
35 36 echo '(time (load "test/t-aserve.cl"))' >> build.tmp
19 packages.cl
... ... @@ -1,11 +1,18 @@
1 1 #+(version= 8 2)
2   -(sys:defpatch "aserve" 5
  2 +(sys:defpatch "aserve" 7
3 3 "v1: version 1.2.67, implement keep-alive in allegroserve client;
4 4 v2: 1.2.68, obey keep-alive requests for PUT and POST requests;
5 5 v3: 1.2.69, make logging though method specialized on wserver class;
6 6 v4: 1.2.70: add support for Expect: 100-continue requests;
7 7 v5: 1.3.1: compression support, publish-directory :destination can be a
8   - list of directories, and various SSL improvements."
  8 + list of directories, and various SSL improvements;
  9 +v6: 1.3.5: doc updates, make client-request-read-sequence work with
  10 + compressed responses, delay sending headers for computed entities,
  11 + add option to do hidden redirect to an index file in a directory,
  12 + fix prepend-headers so that it works on windows;
  13 +v7: 1.3.7: Add :default-actions to webactions,
  14 + Avoid polling in http-accept-thread,
  15 + smp thread safety changes."
9 16 :type :system
10 17 :post-loadable t)
11 18
@@ -79,9 +86,11 @@ sys::
79 86 (defvar *user-warned-about-deflate* nil)
80 87 (handler-case (require :deflate)
81 88 (error (c)
82   - (when (null *user-warned-about-deflate*)
83   - (format t "~&NOTE: ~a~%" c)
84   - (setq *user-warned-about-deflate* t)))))
  89 + (if* (null *user-warned-about-deflate*)
  90 + then (format t "~&NOTE: ~@<the deflate module could not be loaded, so ~
  91 +server compression is disabled. AllegroServe is completely functional ~
  92 +without compression. Original error loading deflate was:~:@>~%~a~%" c)
  93 + (setq *user-warned-about-deflate* t)))))
85 94
86 95 (defpackage :net.aserve
87 96 (:use :common-lisp :excl :net.html.generator :net.uri :util.zip)
9 parse.cl
@@ -204,6 +204,15 @@
204 204
205 205 (defun header-keywordify (name)
206 206 ;; convert name to keyword.. check cache first
  207 +
  208 + ;; mm 2010-12: This code is not SMP-safe but little is lost thereby.
  209 + ;; The way this is coded, some kw conversions might get lost and
  210 + ;; thus need to be repeated, if a push gets overwritten.
  211 + ;; There may be duplicates in the alist if two threads try to add
  212 + ;; the same kw at the same time.
  213 + ;; But adding a lock seems like overkill.
  214 + ;; Even the cache may be of dubious value (intern may be faster than assoc).
  215 +
207 216 (or (cdr (assoc name *headername-to-kwd* :test #'equal))
208 217 (let ((kwd (intern (if* (eq *current-case-mode* :case-insensitive-upper)
209 218 then (string-upcase name)
13 proxy.cl
@@ -1141,8 +1141,15 @@ cached connection = ~s~%" cond cached-connection))
1141 1141 (start-proxy-cache-processes server pcache)))
1142 1142
1143 1143
1144   -(defun start-proxy-cache-processes (server pcache)
1145   - (let ((name (format nil "~d-cache-cleaner" (incf *thread-index*))))
  1144 +(defun start-proxy-cache-processes (server pcache &aux (thx (atomic-incf *thread-index*)))
  1145 + (let ((name (format nil "~d-~A~Acache-cleaner"
  1146 + thx
  1147 + (if* *log-wserver-name*
  1148 + then (wserver-name server)
  1149 + else "")
  1150 + (if* *log-wserver-name*
  1151 + then "-"
  1152 + else ""))))
1146 1153 (setf (pcache-cleaner pcache)
1147 1154 (mp:process-run-function
1148 1155 name
@@ -1160,7 +1167,7 @@ cached connection = ~s~%" cond cached-connection))
1160 1167 server))
1161 1168 (setf (getf (mp:process-property-list (pcache-cleaner pcache))
1162 1169 'short-name)
1163   - (format nil "c~d" *thread-index*))
  1170 + (format nil "c~d" thx))
1164 1171 )
1165 1172
1166 1173 (publish :path "/cache-stats"
6 publish.cl
@@ -2524,7 +2524,7 @@
2524 2524 then (format-dif :xmit
2525 2525 hsock "Connection: Keep-Alive~aKeep-Alive: timeout=~d~a"
2526 2526 *crlf*
2527   - *read-request-timeout*
  2527 + (wserver-read-request-timeout *wserver*)
2528 2528 *crlf*)
2529 2529 else (format-dif :xmit hsock "Connection: Close~a" *crlf*))
2530 2530
@@ -2593,7 +2593,9 @@
2593 2593 (let ((header-content
2594 2594 (string-to-octets
2595 2595 (get-output-stream-string hsock)
2596   - :null-terminate nil)))
  2596 + :null-terminate nil
  2597 + :external-format :octets
  2598 + )))
2597 2599
2598 2600 (setq reply-stream
2599 2601 (setf (request-reply-stream req)
74 queue.cl
... ... @@ -0,0 +1,74 @@
  1 +(in-package :net.aserve)
  2 +
  3 +#+(version= 8 2)
  4 +(eval-when (:compile-toplevel :load-toplevel :execute)
  5 + (handler-case (dequeue (make-instance 'mp:queue) :timeout 0 :empty-queue-result :foo)
  6 + (error ()
  7 + (pushnew 'queue-does-not-timeout *features*))))
  8 +
  9 +#-(and (version>= 8 2) (not net.aserve::queue-does-not-timeout))
  10 +(progn
  11 +
  12 +(defclass queue-with-timeout ()
  13 + ((items :initform nil :accessor items-of)
  14 + (gate :initform (mp:make-gate nil) :reader gate-of)
  15 + (dequeue-lock :initform (mp:make-process-lock) :reader dequeue-lock-of)))
  16 +
  17 +(defun make-queue-with-timeout ()
  18 + (make-instance 'queue-with-timeout))
  19 +
  20 +(defun enqueue (queue thing)
  21 + (mp:with-process-lock ((dequeue-lock-of queue))
  22 + (push thing (items-of queue))
  23 + (mp:open-gate (gate-of queue)))
  24 + thing)
  25 +
  26 +
  27 +(defun dequeue (queue &key (wait t))
  28 + (flet ((dequeue-without-waiting ()
  29 + (mp:with-process-lock ((dequeue-lock-of queue))
  30 + (unless (null (items-of queue))
  31 + (return-from dequeue
  32 + (multiple-value-prog1 (values (pop (items-of queue)) t)
  33 + (if* (null (items-of queue))
  34 + then (mp:close-gate (gate-of queue)))))))))
  35 + (if* wait
  36 + then (let* ((timeout (and (numberp wait) wait))
  37 + (started-at (get-internal-real-time))
  38 + (wait-until (if* timeout
  39 + then (+ started-at (* timeout internal-time-units-per-second))))
  40 + (timeout-remaining timeout))
  41 + (dequeue-without-waiting)
  42 + (while (or (null timeout-remaining)
  43 + (> timeout-remaining 0.08))
  44 + (if* timeout
  45 + then (mp:process-wait-with-timeout "Waiting for gate on potentially timeoutable queue"
  46 + timeout-remaining
  47 + #'mp:gate-open-p
  48 + (gate-of queue))
  49 + (setf timeout-remaining (max 0 (/ (- wait-until (get-internal-real-time)) internal-time-units-per-second)))
  50 +
  51 + else (mp:process-wait "Waiting for gate on potentially timeoutable queue"
  52 + #'mp:gate-open-p
  53 + (gate-of queue)))
  54 + (dequeue-without-waiting))
  55 + (values nil nil))
  56 + else (dequeue-without-waiting)))))
  57 +
  58 +
  59 +#+(and (version>= 8 2) (not net.aserve::queue-does-not-timeout))
  60 +(progn
  61 +
  62 +(defun make-queue-with-timeout ()
  63 + (make-instance 'mp:queue))
  64 +
  65 +(defun enqueue (queue thing)
  66 + (mp:enqueue queue thing))
  67 +
  68 +(defun dequeue (queue &key (wait t))
  69 + (let* ((failure '#:failure)
  70 + (result (mp:dequeue queue :wait wait :empty-queue-result failure
  71 + :whostate "Waiting on potentially timeoutable queue")))
  72 + (if* (eql result failure)
  73 + then (values nil nil)
  74 + else (values result t)))))
14 test/t-aserve.cl
@@ -1633,7 +1633,8 @@
1633 1633 prefix-local))
1634 1634 (declare (ignore headers))
1635 1635 (test (file-contents
1636   - (concatenate 'string test-dir "testdir3/index.html"))
  1636 + (concatenate 'string test-dir "testdir3/index.html")
  1637 + :external-format :octets)
1637 1638 body
1638 1639 :test #'equal
1639 1640 )
@@ -1650,7 +1651,8 @@
1650 1651 prefix-local))
1651 1652 (declare (ignore headers))
1652 1653 (test (file-contents
1653   - (concatenate 'string test-dir "testdir3/subdir/index.html"))
  1654 + (concatenate 'string test-dir "testdir3/subdir/index.html")
  1655 + :external-format :octets)
1654 1656 body
1655 1657 :test #'equal
1656 1658 )
@@ -1691,7 +1693,9 @@
1691 1693 prefix-local))
1692 1694 (declare (ignore headers))
1693 1695 (test (file-contents
1694   - (concatenate 'string test-dir "testdir3/index.html"))
  1696 + (concatenate 'string test-dir "testdir3/index.html")
  1697 + :external-format :octets
  1698 + )
1695 1699 body
1696 1700 :test #'equal
1697 1701 )
@@ -1708,7 +1712,9 @@
1708 1712 prefix-local))
1709 1713 (declare (ignore headers))
1710 1714 (test (file-contents
1711   - (concatenate 'string test-dir "testdir3/subdir/index.html"))
  1715 + (concatenate 'string test-dir "testdir3/subdir/index.html")
  1716 + :external-format :octets
  1717 + )
1712 1718 body
1713 1719 :test #'equal
1714 1720 )
6 webactions/doc/webactions.html
@@ -327,7 +327,7 @@ <h1 style="text-align: center;">Allegro Webactions<br>
327 327 &nbsp;sessions session-lifetime reap-interval reap-hook-function server
328 328 authorizer<br>
329 329 &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
330   -host access-file clp-content-type external-format)</span><br>
  330 +host access-file clp-content-type default-actions external-format)</span><br>
331 331 <br>
332 332 <span style="font-weight: bold;">webaction-project</span> creates
333 333 project data structures and executes calls to <span
@@ -418,6 +418,10 @@ <h1 style="text-align: center;">Allegro Webactions<br>
418 418 <span style="font-weight: bold;">clp-content-type</span> - a string
419 419 holding the content type for all clp files published in this
420 420 project.&nbsp; The default is "text/html".<br>
  421 +<span style="font-weight: bold;">default-actions</span> -
  422 +the actions to invoke if there are no map-entry matches in the
  423 +map.&nbsp; The default is <span style="font-weight: bold;">nil </span>
  424 +(meaning no default actions).<br>
421 425 <span style="font-weight: bold;">external-format</span> - the external
422 426 format used when sending data back to the browser.&nbsp;&nbsp; The
423 427 default is the value of *default-aserve-external-format*<br>
44 webactions/webact.cl
@@ -97,13 +97,16 @@
97 97 (clp-content-type :accessor webaction-clp-content-type
98 98 :initform nil)
99 99
  100 + ;; default actions when there is no map match
  101 + (default-actions :initform nil
  102 + :accessor webaction-default-actions)
100 103 ))
101 104
102 105 (defparameter *webactions-version* "1.12")
103 106
104 107 (defvar *name-to-webaction* (make-hash-table :test #'equal))
105 108
106   -(defparameter *session-reap-interval* (* 5 60)) ; 5 minutse
  109 +(defparameter *session-reap-interval* (* 5 60)) ; 5 minutes
107 110
108 111 (defun webaction-project (name &key (project-prefix "/")
109 112 (clp-suffixes '("clp"))
@@ -121,6 +124,7 @@
121 124 clp-content-type
122 125 (external-format
123 126 *default-aserve-external-format*)
  127 + (default-actions nil)
124 128 )
125 129 ;; create a webaction project
126 130 ;; and publish all prefixes
@@ -153,6 +157,7 @@
153 157 (setf (webaction-destination wa) destination)
154 158 (setf (webaction-external-format wa) external-format)
155 159 (setf (webaction-clp-content-type wa) clp-content-type)
  160 + (setf (webaction-default-actions wa) default-actions)
156 161
157 162 (if* (and reap-interval (integerp reap-interval) (> reap-interval 0))
158 163 then (setq *session-reap-interval* reap-interval))
@@ -267,7 +272,11 @@
267 272
268 273
269 274
270   -(defun webaction-entity (req ent)
  275 +(defun webaction-entity (req ent
  276 + ;; use-actions is used in an internal recursive call
  277 + ;; when there are no action matches and we turn to
  278 + ;; the webaction's default-actions.
  279 + &key (use-actions nil))
271 280 ;; handle a request in the uri-space of this project
272 281
273 282 ; determine if it's in the action space, if so, find the action
@@ -358,7 +367,8 @@
358 367 ; was found in the url
359 368 ; try to locate the session via a cookie
360 369
361   - (let* ((actions (locate-actions req ent wa following))
  370 + (let* ((actions (or use-actions
  371 + (locate-actions req ent wa following)))
362 372 (redirect))
363 373
364 374 ; there may be a list of flags at the end of
@@ -467,10 +477,30 @@
467 477
468 478 (let ((type (excl::filesys-type realname)))
469 479 (if* (not (eq :file type))
470   - then (if* failed-following
471   - then (logmess (format nil "no map for webaction ~s"
472   - failed-following)))
473   - (return-from webaction-entity (failed-request req)))
  480 + then ;; No regular map entry for webaction. If it has a default
  481 + ;; action, we try it here.
  482 + (if* use-actions
  483 + then ;; I don't think we can actually get here, but
  484 + ;; just in case...
  485 + (if* failed-following
  486 + then (logmess (format nil "~
  487 +no map for webaction with default-actions ~s"
  488 + failed-following)))
  489 + (return-from webaction-entity (failed-request req))
  490 + else (let ((default-actions
  491 + (webaction-default-actions wa)))
  492 + (if* default-actions
  493 + then ;; try again specifying actions
  494 + (return-from webaction-entity
  495 + (webaction-entity
  496 + req ent
  497 + :use-actions default-actions))
  498 + else (if* failed-following
  499 + then (logmess
  500 + (format nil "no map for webaction ~s"
  501 + failed-following)))
  502 + (return-from webaction-entity
  503 + (failed-request req))))))
474 504
475 505 (let ((new-ent (clp-directory-entity-publisher
476 506 req ent realname info

0 comments on commit 7de0136

Please sign in to comment.
Something went wrong with that request. Please try again.