Minor comment change
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
a2c1546f 1;;;; $Id: httpd.lisp,v 1.52 2012/09/29 11:27:47 mmondor Exp $
c0aa17ee
MM
2
3#|
4
5Copyright (c) 2012, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
00f0bd59 30;;;; Crow-httpd, an interactively developed HTTP server for ECL on POSIX
c0aa17ee
MM
31
32;;;; XXX TODO XXX
33;;;; - There is a race condition related to MP:PROCESS-KILL used by the
34;;;; thread manager of ecl-mp-server.lisp.
35;;;; Try an alternative ecl-mp-server, which launches a configured number
36;;;; of fixed accept-threads, which then delegate FDs to a dynamic pool
37;;;; of threads. Use the new MP:MAILBOX API for interthread communication,
38;;;; and introduce a special message to notify an extraneous thread to exit.
39;;;; To mitigate this, we currently configure the server to not downscale
40;;;; the threads pool.
9856c64a 41;;;; - Perhaps make the interface to REPLY, REPLY-SEND and
c0aa17ee
MM
42;;;; HTTP-ERROR better so that user code doesn't always have to carry
43;;;; and care about STREAM, etc. *CONNECTION* already holds it...
486bec2d
MM
44;;;; - The same as above in relation to *REQUEST*, avoiding REQ to be passed
45;;;; around.
c0aa17ee
MM
46;;;; - Perhaps support chunked streams
47;;;; - Multipart POST parsing so that files can be uploaded.
48;;;; Unfortunately, the silly standard does not make Content-Length
49;;;; obligatory, so less efficient ad-hoc line-based parsing must be used
50;;;; when it's absent.
51;;;; - Session helper code, with support for session ID cookie and
52;;;; anti-XSS GET session-tied IDs, URL generator to use these IDs,
53;;;; user session-specific variables/objects
a837d3f7 54;;;; - Possibly also generic authentication features (HTTP and form-based)
96d815ab 55;;;; with "captcha" support when a graphics library is supported
c0aa17ee
MM
56;;;; - Form generator with form-instance IDs for matching responses to
57;;;; queries
c0aa17ee
MM
58;;;; - Possibly implement simple filter types to allow the equivalent to the
59;;;; following directive for Apache+secmod:
60;;;; SecRule HTTP_User-Agent "GSLFbot" "deny,log,status:403"
61;;;; Determine if we should support these per-vhost, global or both.
62;;;; We might also want to define a hook system for configuration files
63;;;; to easily create custom filter code.
64;;;; - Perhaps make error handlers configurable. This could either be done
65;;;; using CLOS generic functions or a simpler, possibly faster dispatch
66;;;; system. Maybe also make the page indexer configurable.
a837d3f7
MM
67;;;; - Make dynamic dispatching matching more powerful such that user
68;;;; code could perform custom dispatching, i.e. all of / with path
69;;;; supplied, all of /foo/<n> with <n> supplied, etc.
00f0bd59
MM
70;;;; Either we could allow patterns, which entries would be in a list
71;;;; rather than a hash table as iteration would be necessary, or either
72;;;; we'd have to lookup for each level of the path...
73;;;; Or should we simply allow user code to provide custom dispatching?
a837d3f7
MM
74;;;; - Perhaps consider CLOS to allow user code to customize dispatching
75;;;; and error pages... but also test the performance impact.
0fd8b8a2
MM
76;;;; - Verify why file transfers are done in 1024 byte blocks rather than
77;;;; 65536 ones. Perhaps the underlaying stdio buffering, if any...
96d815ab 78;;;; If so, verify if we can use setvbuf(3) via Lisp or C.
00f0bd59
MM
79;;;; Actually, after looking at the ECL code, it seems that if the buffer
80;;;; was disabled, it'd write one char/byte at a time! Thus it'd probably
81;;;; be simpler to use actual write(2) via FFI, or to set a new buffer
82;;;; size for the underlaying C FILE.
6f477d7a 83;;;; - Logging format customization
96d815ab
MM
84;;;; - Support standalone option which will use an embedded-compiled
85;;;; configuration file and not allow the executable to load one
a8904179
MM
86;;;; - Perhaps eventually support static linking of everything to ease
87;;;; deployment even more. This however might violate the LGPL license
88;;;; which ECL uses unless also distributing the HTTPd source, but this
89;;;; edition is already open-source, it could suffice to provide a link
90;;;; to this source as part of the documentation or logs.
00f0bd59
MM
91;;;; - For standalone :sleep mode, should probably at least open "/dev/null"
92;;;; and set the streams to it. Could perhaps even drop privileges and
93;;;; fork after binding the socket(s)...
94;;;; - See if we want to wrap calls to WRITE-SEQUENCE which signal a
95;;;; SIMPLE-ERROR condition when the client unexpectedly disconnects
96;;;; and we're still writing (EPIPE). Verify if it should instead signal
97;;;; a FILE-ERROR condition as well, or perhaps even a special error which
98;;;; is more friendly to errno such as C-ERROR with ERRNO and object
99;;;; slots... or at least END-OF-FILE.
889469c2
MM
100;;;; - Ability to produce a configuration file corresponding to the current
101;;;; vhosts and handlers and parameters would be nice.
544431a9
MM
102;;;; - More resilient auto-indexing when permissions are troublesome for
103;;;; a file (i.e. FILE-ERROR for dumb DCOP directories on Linux).
104;;;; We should ideally skip the troublesome file and continue.
105;;;; This might actually also be an opportunity to provide a saner
106;;;; interface to directory and file information than what CL provides
a2c1546f 107;;;; - Verify what to export for things like REQUEST, PATH etc
c0aa17ee
MM
108
109
110(declaim (optimize (speed 3) (safety 1) (debug 3)))
111
4bcf8ca1
MM
112#+:mm-ecl-standalone
113(setf *load-verbose* nil)
114(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
c0aa17ee
MM
115 (load "ecl-mp-server")
116 (load "html")
de2a1441
MM
117 (load "character")
118 (load "const-file")
ace88c7a
MM
119 (load "embedded-files")
120 (load "io"))
c0aa17ee
MM
121
122(defpackage :httpd
de2a1441 123 (:use :cl :server :html :character :const-file)
c0aa17ee
MM
124 (:export #:httpd-config
125 #:make-httpd-config
126 #:httpd-init
6f477d7a
MM
127 #:path-valid
128 #:path-valid-virtual
129 #:path-extension
c0aa17ee
MM
130 #:vhost
131 #:make-vhost
132 #:vhost-register
133 #:vhost-unregister
ba1e0c5a 134 #:vhost-list
6f477d7a 135 #:vhost-query
c0aa17ee
MM
136 #:vhost-handler-register
137 #:vhost-handler-list
138 #:vhost-handler-unregister
6f477d7a 139 #:vhost-handler-query
c0aa17ee 140 #:mime-register
6f477d7a 141 #:mime-register-list
c0aa17ee
MM
142 #:mime-unregister
143 #:mime-query
144 #:mime-load
145 #:mime-reload
9856c64a
MM
146 #:reply
147 #:make-reply
148 #:reply-code-set
149 #:reply-header-set
150 #:reply-header-get
151 #:reply-header-unset
152 #:reply-header-set-nocache
153 #:reply-headers-string
154 #:reply-content-add
155 #:reply-content-clear
156 #:reply-log-time
157 #:reply-flush
158 #:reply-send
c0aa17ee
MM
159 #:http-error
160 #:http-redirect
161 #:url-decode
162 #:url-encode
163 #:req-var
22b9809f 164 #:with-http-let
451d8738 165 #:range-validate
6f477d7a 166 #:*debug*
c0aa17ee
MM
167 #:debug-feature))
168
169(in-package :httpd)
170
171(defparameter *rcsid*
a2c1546f 172 "$Id: httpd.lisp,v 1.52 2012/09/29 11:27:47 mmondor Exp $")
c0aa17ee
MM
173
174(defparameter *server-version*
175 (let ((parts (string-split *rcsid*
176 :separators '(#\Space #\,))))
177 (concatenate 'string
6f477d7a
MM
178 "Crow" "/0." (svref parts 3)))
179 "Version string presented in the Server HTTP response header.")
c0aa17ee
MM
180
181
182(defstruct (httpd-config (:conc-name config-))
6f477d7a 183 "Structure used to configure HTTPD."
c0aa17ee
MM
184 (server-config nil :type (or null
185 server:server-config))
186 ;; Supported DEBUG features:
a2c1546f 187 ;; :log-requests :log-connections :log-errors :log-handlers :test :beep
6f477d7a 188 (debug '(:log-errors :test) :type list)
c0aa17ee 189
6f477d7a
MM
190 ;; For the standalone-mode swank server (:sleep :swank :repl)
191 (standalone-mode :sleep :type keyword)
51017907
MM
192 (swank-loader "/home/foo/slime/swank-loader" :type string)
193 (swank-address "127.0.0.1" :type string)
194 (swank-port 4005 :type fixnum)
195
c0aa17ee
MM
196 (request-timeout 60 :type fixnum)
197 (request-max-size 4096 :type fixnum)
198 (request-keepalive-timeout 20 :type fixnum)
199 (request-keepalive-max 100 :type fixnum)
200 (request-log t :type boolean)) ; XXX Optional?
201
6f477d7a
MM
202(defvar *config* (make-httpd-config :server-config (make-server-config))
203 "HTTP server configuration.")
c0aa17ee
MM
204
205
206;;; Paths
207
c0aa17ee 208(defun path-valid (path)
6f477d7a
MM
209 "Returns a copy of PATH if valid, or NIL. The returned path always
210begins with '/', with multiple '/' collapsed into one. Makes sure
211that PATH only contains allowed characters and is shorter than 255
212characters. Does not allow '.' at the beginning of PATH or after any '/'."
de2a1441 213 (declare (optimize (speed 3) (safety 0) (debug 0)))
ba6d650d
MM
214 (let ((path-max 255)
215 (out (make-array (1+ (length path))
c0aa17ee
MM
216 :element-type 'character
217 :fill-pointer 0)))
ba6d650d 218 (declare (type fixnum path-max))
7f0ff025
MM
219 (flet ((add-char (c)
220 (vector-push c out)))
221 (declare (inline add-char))
c0aa17ee
MM
222 (add-char #\/)
223 (if
224 (loop
c0aa17ee
MM
225 with last of-type character = #\/
226 for c of-type character across path
227 do
ba6d650d
MM
228 (block continue
229 (when (char= #\/ last)
230 ;; Collapse multiple '/' and prohibit '.' at start
231 (if (char= #\/ c)
232 (return-from continue)
233 (when (char= #\. c)
234 (return nil))))
235 (unless (member-character-intervals-p c
236 (#\a #\z) (#\A #\Z) (#\0 #\9) #\. #\/ #\- #\_)
237 (return nil))
238 (add-char c)
239 (setf last c))
c0aa17ee 240 finally (return out))
ba6d650d 241 (if (> (length out) path-max)
c0aa17ee
MM
242 nil
243 out)
244 nil))))
245
246(defstruct path
6f477d7a 247 "Path object returned from PATH-VALID-VIRTUAL."
c0aa17ee
MM
248 real virtual)
249
c0aa17ee 250(defun path-valid-virtual (root path)
6f477d7a
MM
251 "Should always be called when processing user-supplied paths.
252The application should then only trust the objects returned by this
253function. Returns NIL if PATH is invalid. On success, returns a PATH
254object with:
255 REAL: System-wide absolute real fullpath, to be used to access the
256 file/directory in question
257 VIRTUAL: The virtual ROOT-based absolute fullpath, useful to report to
258 the user.
259Note that the supplied ROOT should previously have been passed through
a8904179
MM
260PATH-VALID, and that both ROOT and PATH should be absolute paths.
261The exception is if ROOT is NIL, in which case REAL will also be NIL,
262for virtual hosts without static content."
c0aa17ee 263 (let* ((virtual (path-valid (concatenate 'string "/" path)))
a8904179
MM
264 (real (if (null root)
265 nil
266 (if virtual (path-valid
267 (concatenate 'string
268 "/" root "/" virtual))
269 nil))))
270 (if (and virtual (or real (null root)))
c0aa17ee
MM
271 (make-path :real real
272 :virtual virtual)
273 nil)))
274
275(defun path-extension (path)
6f477d7a 276 "Given PATH, returns the file extension in lowercase, if any, or NIL."
c0aa17ee
MM
277 (let ((dot (position #\. path
278 :test #'char=
279 :from-end t)))
de2a1441 280 (declare (type (or fixnum null) dot))
c0aa17ee 281 (if dot
de2a1441 282 (string-downcase (subseq path (the fixnum (1+ (the fixnum dot)))))
c0aa17ee
MM
283 nil)))
284
285
286;;; VHosts
287
6f477d7a
MM
288(defvar *vhost-default* nil
289 "The current default virtual host (a VHOST object).")
c0aa17ee
MM
290
291(defstruct vhost
6f477d7a 292 "Structure to configure/describe a virtual host."
c0aa17ee 293 (hostname "" :type string :read-only t)
a8904179
MM
294 ;; If ROOT is NIL this VHOST only supports dynamic handlers, no files.
295 (root nil :type (or null string))
c0aa17ee
MM
296 (index "/index.html" :type string)
297 (charset :utf-8 :type keyword)
298 (autoindex nil :type boolean)
299 (post-max-size 1048576 :type integer)
300 (post-timeout 240 :type fixnum)
301 (%handlers (make-hash-table :test #'equal) :type hash-table :read-only t))
302
303(defvar *vhosts* (make-hash-table :test #'equal))
304(defvar *vhosts-lock* (mp:make-lock :name 'vhosts-lock))
305
306(defun vhost-register (vhost &key (aliases '()) (default nil))
6f477d7a
MM
307 "Given the virtual host configuration object VHOST, registers it
308by hostname and optional ALIASES names. Sets VHOST as the default one
309if DEFAULT is T. May override pre-existing vhosts and aliases."
c0aa17ee
MM
310 (check-type vhost vhost)
311 (check-type aliases list)
312 (check-type default boolean)
313 (with-accessors ((name vhost-hostname)
314 (root vhost-root)
315 (index vhost-index)) vhost
a8904179
MM
316 (when root
317 (unless (path-valid root)
318 (error "Invalid root path \"~A\"" root)))
c0aa17ee
MM
319 (unless (path-valid index)
320 (error "Invalid index path \"~A\"" index))
321 (mp:with-lock (*vhosts-lock*)
322 (let ((vhosts *vhosts*))
323 (setf (gethash (string-downcase name) vhosts) vhost)
324 (loop
325 for alias in aliases
326 do
327 (setf (gethash (string-downcase alias) vhosts) vhost))
328 (when default
3187dd24
MM
329 (setf *vhost-default* vhost))))
330 (vhost-handler-register vhost
331 '(("/images/crow-httpd-logo.png"
332 :embedded embedded-files:*crow-httpd-logo-png*)
333 ("/images/crow-httpd-icon.png"
334 :embedded embedded-files:*crow-httpd-icon-png*)
335 ("/images/valid-xhtml.png"
336 :embedded embedded-files:*valid-xhtml-png*)
337 ("/css/crow-httpd.css"
338 :embedded embedded-files:*crow-httpd-css*))))
6f477d7a 339 (values))
c0aa17ee 340
ba1e0c5a
MM
341(defun vhost-list ()
342 "Returns a list of currently registered virtual hosts and their aliases.
343Every sublist represents a virtual host and consists of two lists, the
344actual hostname of the virtual host, followed by a list of the name of each
345alias."
346 (let ((list '()))
347 (mp:with-lock (*vhosts-lock*)
348 (loop
349 with vhosts = *vhosts*
350 for key being each hash-key of vhosts using (hash-value val)
351 for hostname = (vhost-hostname val)
352 for aliases = (loop
353 for key2 being each hash-key of vhosts using
354 (hash-value val2)
355 when (and (not (string= hostname key2))
356 (eq val val2))
a2c1546f
MM
357 collect key2 into aliases
358 finally (return (sort aliases #'string<)))
ba1e0c5a
MM
359 do (pushnew `(,hostname ,aliases) list
360 :test #'eq :key #'first)))
361 (sort list #'string< :key #'first)))
362
3187dd24
MM
363(defun vhost-query (designator &key (default nil))
364 "Looks up in the virtual hosts table any match for hostname or alias
365DESIGNATOR and returns the matching VHOST object if found, or NIL.
366 If DEFAULT is T, returns the VHOST object for the default virtual host if
367DESIGNATOR cannot not be found. If DESIGNATOR is already a VHOST object,
368returns it."
de2a1441 369 (declare (optimize (speed 3) (safety 0) (debug 0)))
3187dd24
MM
370 (if (vhost-p designator)
371 designator
372 (mp:with-lock (*vhosts-lock*)
373 (multiple-value-bind (vhost exists-p)
374 (gethash (string-downcase designator) *vhosts*)
375 (let ((vhost-default *vhost-default*))
376 (cond ((and default vhost-default (not exists-p))
377 vhost-default)
378 (exists-p
379 vhost)
380 (t
381 nil)))))))
382
d0a7503d
MM
383;;; Internal version for use when already holding the lock
384(declaim (inline %vhost-query-nolock))
385(defun %vhost-query-nolock (designator)
386 (declare (optimize (speed 3) (safety 0) (debug 0)))
387 (if (vhost-p designator)
388 designator
389 (multiple-value-bind (vhost exists-p)
390 (gethash (string-downcase designator) *vhosts*)
391 (if exists-p
392 vhost
393 nil))))
394
3187dd24
MM
395(defun vhost-unregister (designator)
396 "Looks up in the virtual hosts table any match for hostname or alias
397DESIGNATOR then unregisters/deletes that VHOST if found. Returns T if the
398virtual host was found and unregistered, or NIL if DESIGNATOR did not match
399any."
d0a7503d
MM
400 (mp:with-lock (*vhosts-lock*)
401 (let ((vhost (%vhost-query-nolock designator)))
402 (if vhost
3187dd24 403 (loop
ba1e0c5a 404 with vhosts = *vhosts*
3187dd24 405 for key being each hash-key of vhosts using (hash-value val)
d0a7503d
MM
406 when (eq val vhost) do (remhash key vhosts)
407 finally (return t))
408 nil))))
409
410(defun vhost-alias-register (designator alias)
411 "Looks up the virtual hosts table for a VHOST matching DESIGNATOR.
412If found, ensures that the ALIAS hostname string also points to it, and
413returns T. Returns NIL otherwise. Previously existing aliases for any
414virtual host may be overriden."
415 (mp:with-lock (*vhosts-lock*)
416 (let* ((alias-lowcase (string-downcase alias))
417 (vhost (%vhost-query-nolock designator)))
418 (cond ((and vhost
419 (string/= alias-lowcase (vhost-hostname vhost)))
420 (setf (gethash alias-lowcase *vhosts*) vhost)
421 t)
422 (t nil)))))
423
424(defun vhost-alias-unregister (alias)
425 "Lookups up the virtual hosts table for an alias matching ALIAS.
426If found, and alias does not consist of the main VHOST hostname, the alias
427is deleted, and T is returned. Returns NIL otherwise."
428 (mp:with-lock (*vhosts-lock*)
429 (let* ((alias-lowcase (string-downcase alias))
430 (vhost (%vhost-query-nolock alias-lowcase)))
431 (cond ((and vhost
432 (string/= alias-lowcase (vhost-hostname vhost)))
433 (remhash alias-lowcase *vhosts*)
434 t)
435 (t nil)))))
c0aa17ee 436
a8904179 437(declaim (inline vhost-path))
c0aa17ee 438(defun vhost-path (vhost path)
6f477d7a 439 "Validates user-supplied PATH for VHOST, and returns a PATH object if
a8904179 440valid, or NIL. See PATH-VALID-VIRTUAL for more details."
de2a1441 441 (declare (optimize (debug 0)))
c0aa17ee
MM
442 (path-valid-virtual (vhost-root vhost) path))
443
de2a1441 444;;; Special VHost resource handlers
3187dd24
MM
445(defun vhost-handler-register (vhost-designator handlers)
446 "Registers the supplied HANDLERS for the VHOST matching VHOST-DESIGNATOR.
de2a1441
MM
447HANDLERS should be a list of lists, with every sublist holding three
448items. The first item consists of a fullpath to match, the second of a
449handler type keyword symbol and the third a parameter. The supported
450formats are as follows:
451
452 (PATH :DYNAMIC FUNCTION-DESIGNATOR)
453 A dynamic application handler. FUNCTION-DESIGNATOR will be called to
454 handle this resource.
455
456 (PATH :EMBEDDED CONST-FILE)
457 PATH should be handled by serving a static embedded-file.
458 CONST-FILE should be an object of type CONST-FILE, previously created by
459 CONST-FILE-EMBED.
460
461 (PATH :AUTOINDEX BOOLEAN)
462 May override the INDEX slot value of the VHOST for the specified PATH
463 which should point to an existing directory in the static ROOT tree.
464
e529c610 465 (PATH :REDIRECT-PERMANENTLY TO-PATH)
de2a1441
MM
466 Specifies that accesses to the resource PATH should be redirected to
467 the resource TO-PATH.
468
e529c610
MM
469 (PATH :REDIRECT-TEMPORARILY TO-PATH)
470 Like :REDIRECT-PERMANENTLY but using the 302 Moved Temporarily response.
471
de2a1441 472Previously registered handlers for VHOST may be overridden."
d0a7503d
MM
473 (mp:with-lock (*vhosts-lock*)
474 (let ((vhost (%vhost-query-nolock vhost-designator)))
475 (check-type vhost vhost)
476 (check-type handlers list)
477 (mapc #'(lambda (sublist)
478 (destructuring-bind (path type parameter) sublist
479 (check-type path string)
480 (check-type type keyword)
481 (ecase type
482 (:dynamic (progn
483 (check-type parameter (or symbol function))
484 (when (symbolp parameter)
485 (check-type (symbol-function parameter)
486 function))))
487 (:embedded (progn
488 (check-type parameter
489 (or symbol const-file))
490 (when (symbolp parameter)
491 (check-type (symbol-value parameter)
492 const-file))))
493 (:autoindex (check-type parameter boolean))
494 ((:redirect-permanently :redirect-temporarily)
495 (progn
496 (check-type parameter string)
497 (setf parameter
498 (string-downcase (path-valid parameter))))))
499 (let ((vpath (string-downcase (path-valid path))))
c0aa17ee 500 (setf (gethash vpath (vhost-%handlers vhost))
d0a7503d
MM
501 (list type parameter)))))
502 handlers)))
6f477d7a 503 (values))
c0aa17ee 504
3187dd24
MM
505(defun vhost-handler-list (vhost-designator)
506 "Finds the VHOST object matching VHOST-DESIGNATOR, and returns a list of
6f477d7a 507previously registered handlers for that virtual host."
d0a7503d
MM
508 (let ((list '()))
509 (mp:with-lock (*vhosts-lock*)
510 (let ((vhost (%vhost-query-nolock vhost-designator)))
511 (when vhost
512 (maphash #'(lambda (k v)
513 (push (append `(,k) v) list))
514 (vhost-%handlers vhost)))))
c0aa17ee
MM
515 (sort list #'string< :key #'first)))
516
3187dd24
MM
517(defun vhost-handler-unregister (vhost-designator handlers)
518 "Finds the the VHOST object matching VHOST-DESIGNATOR, and if found,
6f477d7a
MM
519unregister any supplied handler in HANDLERS for that virtual host, if it
520exists. HANDLERS should be a list of strings, each string representing
521a path."
d0a7503d
MM
522 (mp:with-lock (*vhosts-lock*)
523 (let ((vhost (%vhost-query-nolock vhost-designator)))
524 (when (and vhost handlers)
525 (mapc #'(lambda (path)
526 (check-type path string)
de2a1441
MM
527 (let ((handler (gethash path (vhost-%handlers vhost))))
528 (when handler
d0a7503d
MM
529 (remhash path (vhost-%handlers vhost)))))
530 handlers))))
6f477d7a 531 (values))
c0aa17ee 532
f6526a2e 533(declaim (inline vhost-handler-query))
c0aa17ee 534(defun vhost-handler-query (vhost vpath)
6f477d7a 535 "Given the virtual host object VHOST, lookup for a registered handler
d0a7503d
MM
536matching VPATH. If found, return the assiciated handler list. Returns NIL
537otherwise."
de2a1441 538 (declare (optimize (speed 3) (safety 0) (debug 0)))
d0a7503d 539 (let ((handler nil))
c0aa17ee 540 (mp:with-lock (*vhosts-lock*)
d0a7503d
MM
541 (let ((h (gethash vpath (vhost-%handlers vhost))))
542 (setf handler h)))
543 handler))
c0aa17ee
MM
544
545
546;;; Mime types
547
548(defvar *mime-type-table* (make-hash-table :test #'equal))
549(defvar *mime-type-lock* (mp:make-lock :name 'mime-type-lock))
550(defvar *mime-type-file* "mime-types.lisp")
551(defvar *mime-types*)
552
553(defun mime-register (mimetype extensions)
6f477d7a
MM
554 "Registers file extensions supplied as strings in the list EXTENSION
555for the mime-type string MIMETYPE. May override some links extention to
556mime-type links."
c0aa17ee
MM
557 (let ((type (string-downcase mimetype)))
558 (mp:with-lock (*mime-type-lock*)
559 (mapc #'(lambda (e)
560 (setf (gethash (string-downcase e) *mime-type-table*) type))
561 extensions))
562 type))
563
564(defun mime-register-list (types)
6f477d7a
MM
565 "Calls MIME-REGISTER for each list in TYPES, which must hold the same
566arguments as MIME-REGISTER each, namely a mime-type string and a list of
567extension strings."
c0aa17ee
MM
568 (mapc #'(lambda (type)
569 (destructuring-bind (mimetype extensions) type
570 (mime-register mimetype extensions)))
571 types)
6f477d7a 572 (values))
c0aa17ee
MM
573
574(defun mime-unregister (extension)
6f477d7a
MM
575 "Looks up for a mime-type matching the file extension supplied by the
576EXTENSION string. If found, unregisters that mime-type as well as any
577extension to mime-type links associated to it and returns T. Returns
578NIL there was no match."
579 (let ((found nil))
580 (mp:with-lock (*mime-type-lock*)
581 (let ((table *mime-type-table*))
582 (multiple-value-bind (type exists-p)
583 (gethash (string-downcase extension) table)
584 (when exists-p
585 (setf found t)
586 (loop
587 for key being each hash-key of table using (hash-value val)
588 when (eq val type) do (remhash key table))))))
589 found))
c0aa17ee 590
f6526a2e 591(declaim (inline mime-query))
c0aa17ee 592(defun mime-query (extension &optional (default "application/octet-stream"))
6f477d7a
MM
593 "Looks for a mime-type match to the supplied file EXTENSION string.
594Returns the matching mime-type string or DEFAULT (which defaults to
595\"application/octet-stream\"."
de2a1441 596 (declare (optimize (speed 3) (safety 0) (debug 0)))
c0aa17ee
MM
597 (mp:with-lock (*mime-type-lock*)
598 (multiple-value-bind (type exists-p)
599 (gethash (string-downcase extension) *mime-type-table*)
600 (if exists-p
601 type
602 default))))
603
a2c1546f
MM
604(defun mime-list ()
605 "Returns a list of currently registered mime types and their extensions.
606Every sublist represents a mime-type and consists of two lists, the actual
607mime-type, followed by a list of each file extension assigned to it."
608 (let ((list '()))
609 (mp:with-lock (*mime-type-lock*)
610 (loop
611 with types = *mime-type-table*
612 for extension being each hash-key of types using (hash-value type)
613 for extensions = (loop
614 for extension2 being each hash-key of types
615 using (hash-value type2)
616 when (eq type type2)
617 collect extension2 into extensions
618 finally (return (sort extensions #'string<)))
619 do (pushnew `(,type ,extensions) list
620 :test #'eq :key #'first)))
621 (sort list #'string< :key #'first)))
622
623;;; XXX These could avoid using LOAD and *MIME-TYPES*
c0aa17ee 624(defun mime-load (file)
6f477d7a
MM
625 "Loads a mime-types database list from FILE. Remembers the location of
626FILE for MIME-RELOAD."
c0aa17ee
MM
627 (load file)
628 (setf *mime-type-file* file)
629 (mime-register-list *mime-types*))
630
631(defun mime-reload ()
6f477d7a
MM
632 "Reloads the mime-types database list from file, which was remembered
633from a previous call to MIME-LOAD."
c0aa17ee
MM
634 (load *mime-type-file*)
635 (mime-register-list *mime-types*))
636
637
638;;; HTTP reply
639
640;;; Dynamically bound to request object for us
6f477d7a 641(defvar *request* nil
9856c64a 642 "Dynamically bound to the current REQUEST object.")
c0aa17ee
MM
643
644;;; Useful to elegantly longjmp back to the request reader as soon as a
645;;; request is flushed.
9856c64a 646(define-condition signal-reply
c0aa17ee
MM
647 (simple-error)
648 ())
649
9856c64a
MM
650(define-condition signal-reply-no-keepalive
651 (signal-reply)
c0aa17ee
MM
652 ())
653
9856c64a 654(defstruct (reply (:constructor %make-reply))
6f477d7a 655 "Object used to prepare an HTTP reply.
9856c64a 656MAKE-REPLY uses *REQUEST*, if bound, to supply some default values."
451d8738
MM
657 (date (server-time-rfc) :type string)
658 (code 200 :type real)
659 (description "Ok" :type string)
660 (mime-type "text/html" :type string)
661 (charset :utf-8 :type keyword)
662 (headers '() :type list)
663 (content '() :type list)
664 (protocol 0.9 :type float)
665 (no-keepalive nil :type boolean)
666 (flush-log t :type boolean)
667 (flush-len t :type boolean)
668 (flush-signal t :type boolean))
669
9856c64a
MM
670(defun make-reply (&rest keys)
671 "REPLY constructor. Uses *REQUEST*, if bound, to supply some default
6f477d7a 672values."
de2a1441 673 (declare (optimize (speed 3) (safety 0) (debug 0)))
9856c64a 674 (let* ((reply (apply #'%make-reply keys))
451d8738 675 (request *request*))
9856c64a 676 (setf (reply-headers reply)
451d8738
MM
677 (list `("Server" . ,*server-version*)
678 '("Accept-Ranges" . "bytes")))
679 (when request
9856c64a
MM
680 (setf (reply-charset reply)
681 (vhost-charset (request-vhost request))
682 (reply-protocol reply)
683 (let ((protocol (request-protocol request)))
451d8738
MM
684 (if protocol
685 protocol
686 0.9))
9856c64a
MM
687 (reply-charset reply)
688 (vhost-charset (request-vhost request))))
451d8738
MM
689 reply))
690
9856c64a
MM
691(declaim (inline reply-code-set))
692(defun reply-code-set (reply code description)
6f477d7a 693 "Applies the supplied HTTP CODE (real) and related DESCRIPTION (string)
9856c64a 694to the specified REPLY object."
de2a1441 695 (declare (optimize (speed 3) (safety 0) (debug 0)))
9856c64a
MM
696 (check-type reply reply)
697 (setf (reply-code reply) code
698 (reply-description reply) description)
f6526a2e
MM
699 (values))
700
9856c64a 701(defun reply-header-set (reply &rest pairs)
6f477d7a
MM
702 "Assign in the HTTP headers of REPLY each key/value pair in PAIRS.
703The first item of a pair should be a string, but the second value may be
704a string or a FORMAT control string followed by multiple objects to form
705the value."
de2a1441 706 (declare (optimize (debug 1)))
9856c64a 707 (with-accessors ((headers reply-headers)) reply
451d8738
MM
708 (loop
709 for pair in pairs
710 do
711 (destructuring-bind (key fmt &rest fmt-args) pair
712 (let* ((match (assoc key headers :test #'string-equal))
713 (line (if fmt-args
714 (apply #'format nil fmt fmt-args)
715 fmt)))
716 (if match
717 (rplacd match line)
718 (setf headers (acons key line headers)))))))
719 (values))
720
9856c64a 721(defun reply-header-get (reply key)
6f477d7a
MM
722 "Returns the value associated with the HTTP header KEY string for REPLY,
723or NIL if it is unbound."
9856c64a 724 (let ((pair (assoc key (reply-headers reply) :test #'string-equal)))
486bec2d
MM
725 (if pair
726 (cdr pair)
727 nil)))
451d8738 728
9856c64a 729(defun reply-header-unset (reply &rest keys)
6f477d7a 730 "Unset/unbind each HTTP header of REPLY specified in KEYS strings."
9856c64a 731 (with-accessors ((headers reply-headers)) reply
0fd8b8a2
MM
732 (loop
733 for key in keys
734 for match = (assoc key headers :test #'string-equal)
735 when match do (rplacd match nil)))
451d8738
MM
736 (values))
737
9856c64a
MM
738(declaim (inline reply-header-set-nocache))
739(defun reply-header-set-nocache (reply)
6f477d7a
MM
740 "Adds the needed headers to REPLY to tell the client not to cache these
741results."
451d8738
MM
742 ;; We can't use PAIRLIS as we're later iterating through the list
743 ;; which must be a set, and PAIRLIS may insert or append...
9856c64a 744 (reply-header-set reply
486bec2d 745 '("Expires" "Mon, 26 Jul 1997 05:00:00 GMT")
9856c64a 746 `("Last-Modified" ,(reply-date reply))
486bec2d
MM
747 '("Cache-Control" "no-cache, must-revalidate")
748 '("Pragma" "no-cache")))
451d8738
MM
749
750(defvar *crlf* (concatenate 'string '(#\Return #\LineFeed)))
751
9856c64a 752(defun reply-headers-string (reply)
6f477d7a 753 "Returns a formatted STRING for the existing HTTP headers of REPLY."
451d8738 754 (with-output-to-string (out)
de2a1441 755 (declare (optimize (debug 1)))
451d8738
MM
756 (loop
757 with crlf = *crlf*
9856c64a 758 with alist = (reply-headers reply)
451d8738
MM
759 for item in alist
760 for (key . line) = item
761 when line
762 do
763 (format out "~:(~A~): ~A~A" key line crlf)
764 finally (write-string crlf out))))
c0aa17ee 765
9856c64a
MM
766(declaim (inline reply-content-add))
767(defun reply-content-add (reply content)
768 "Appends CONTENT string to REPLY, to be flushed with REPLY-FLUSH."
769 (push content (reply-content reply)))
c0aa17ee 770
9856c64a 771(defun reply-content-clear (reply)
6f477d7a 772 "Clears any existing content previously set for REPLY using
9856c64a
MM
773REPLY-CONTENT-ADD."
774 (setf (reply-content reply) '()))
6f477d7a 775
9856c64a
MM
776(declaim (inline reply-log-time))
777(defun reply-log-time (&optional (ut (server-time)))
6f477d7a
MM
778 "Returns an HTTP-log friendly timestamp for UT (a universal-time which
779defaults to the current time)."
c0aa17ee
MM
780 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
781 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
7f0ff025 782 (declare (type (simple-array string (12)) months))
c0aa17ee
MM
783 (multiple-value-bind
784 (second minute hour date month year)
785 (decode-universal-time ut 0)
786 (format nil "[~2,'0D/~A/~4,'0D:~2,'0D:~2,'0D:~2,'0D -0000]"
787 date (svref months (1- month)) year
788 hour minute second))))
789
9856c64a
MM
790(defun reply-flush (reply stream &optional (size nil))
791 "Attempts to flush the supplied REPLY object to STREAM.
6f477d7a 792This includes HTTP headers as well as any content added using
9856c64a 793REPLY-CONTENT-ADD. If SIZE is not provided or is 0, a condition
6f477d7a
MM
794is internally signaled in order for control to be resumed to handling
795the next HTTP request, so this function may be considered an exit point
796for user code. If SIZE is provided, control is not transfered and user
797code may proceed to send custom data. In some cases, it may be handy
798for control to not be transfered without a SIZE being set, in which case
9856c64a
MM
799user code may set the REPLY-FLUSH-SIGNAL slot of the REPLY object to
800NIL (it defaults to T for new reply objects). See also
801REPLY-HEADERS-STRING. This function should normally only be called once
802per REPLY instance. If control is transfered, the value of the REPLY slot
803REPLY-NO-KEEPALIVE determines if connection will also be closed immediately
804with the client or if further requests will be allowed as-per Keep-Alive.
805The default for REPLY-NO-KEEPALIVE is NIL."
c0aa17ee
MM
806 (let* ((config *config*)
807 (request *request*)
808 (encoding (if request
9856c64a 809 (vhost-charset (request-vhost request))
c0aa17ee
MM
810 (vhost-charset *vhost-default*)))
811 (content (if (eq :utf-8 encoding)
812 (mapcar #'utf-8-string-encode
9856c64a
MM
813 (reply-content reply))
814 (reply-content reply)))
c0aa17ee
MM
815 (content-len (if size
816 size
817 (loop
818 for s in content
819 sum (length s) into len of-type fixnum
451d8738 820 finally (return len)))))
c0aa17ee
MM
821
822 (when request
823 (let ((connection *connection*))
9856c64a
MM
824 (when (reply-no-keepalive reply)
825 (request-disable-keepalive request))
c0aa17ee
MM
826 (macrolet ((field (f &optional (type :string))
827 `(let ((%f ,f))
828 ,(if (eq type :string)
829 `(if %f %f "-")
830 `(if (zerop %f) "-" %f)))))
451d8738 831 (when (and (config-request-log config)
9856c64a 832 (reply-flush-log reply))
c0aa17ee
MM
833 (log-line-nostamp "~X ~A - - ~A ~A ~S ~A ~A \"~A\" \"~A\""
834 (connection-session connection)
835 (connection-address-string connection)
9856c64a
MM
836 (reply-log-time)
837 (vhost-hostname (request-vhost request))
838 (first (request-raw request))
839 (reply-code reply)
c0aa17ee 840 (field content-len :integer)
9856c64a
MM
841 (field (request-referer request))
842 (field (request-agent request)))))))
843
844 (when (> (reply-protocol reply) 0.9)
845 (with-accessors ((headers reply-headers)) reply
846 (reply-header-set reply
847 (list "Date" (reply-date reply)))
848 (when (reply-flush-len reply)
849 (reply-header-set reply
850 (list "Content-Length" "~D" content-len)
851 (list "Content-Type" "~A; charset=~A"
852 (reply-mime-type reply)
853 (symbol-name (reply-charset reply)))))
c0aa17ee 854 (if (and request
9856c64a
MM
855 (request-keepalive request))
856 (when (= 1.0 (request-protocol request))
857 (reply-header-set reply
858 (list "Keep-Alive" "timeout=~D, max=~D"
859 (config-request-keepalive-timeout config)
860 (config-request-keepalive-max config))
861 '("Connection" "Keep-Alive")))
862 (reply-header-set reply '("Connection" "close")))
451d8738 863 (format stream "HTTP/1.1 ~A ~A~A"
9856c64a
MM
864 (reply-code reply)
865 (reply-description reply)
451d8738 866 *crlf*)
9856c64a 867 (write-string (reply-headers-string reply) stream)))
ace88c7a
MM
868 ;; XXX Strangely enough using IO:VECTOR-WRITE here affects stability.
869 ;; But since content can also contain small blocks, using stdio is not
870 ;; that much of a problem here compared to for file transfers.
871 ;; This issue is still interesting however, as it does not seem to
872 ;; occur more often for file transfers as it did with the standard
873 ;; sequence functions (very rarely). However, we could coalesce
874 ;; those buffers here, and code using HTML may often generate a single
875 ;; large content block.
876 ;; What happens is that all threads eventually remain busy yet idle
877 ;; after being stressed enough using Apache ab(8).
c0aa17ee 878 (unless size
ace88c7a
MM
879#|
880 (finish-output stream)
881 (loop
882 with rcontent = (reverse content)
883 with fd = (stream-fd stream)
884 for s in rcontent
885 do
886 (io:vector-write fd s))
887|#
c0aa17ee
MM
888 (loop
889 with rcontent = (reverse content)
890 for s in rcontent
891 do
892 (write-sequence s stream)))
893 (finish-output stream))
9856c64a 894 (when (and (reply-flush-signal reply)
451d8738 895 (or (null size) (zerop size)))
9856c64a
MM
896 (error (if (reply-no-keepalive reply)
897 'signal-reply-no-keepalive
898 'signal-reply)))
c0aa17ee
MM
899 t)
900
9856c64a
MM
901(defun reply-send (stream fmt &rest fmt-args)
902 "Handy utility function which creates a REPLY object, adds the string
903FMT (or result of applying FORMAT to FMT and FMT-ARGS) and then immediately
904flushes the reply using REPLY-FLUSH to STREAM."
905 (reply-flush
906 (make-reply :content (list
907 (if fmt-args
908 (apply #'format nil fmt fmt-args)
909 fmt)))
72740378 910 stream))
c0aa17ee
MM
911
912(defun http-error (stream code message &optional fmt &rest fmt-args)
6f477d7a
MM
913 "Handy utility function to create and flush an HTTP error to STREAM.
914CODE consist of a real number of the HTTP error code, MESSAGE of its
915associated string response, and the optional further details can be
916given as a string or FORMAT control string and arguments.
917The reply will contain no-cache headers and Keep-Alive will be disabled,
918for this connection, causing it to be closed immediately."
9856c64a
MM
919 (let ((reply (make-reply :code code
920 :description message
921 :no-keepalive t))
c0aa17ee 922 (description (if fmt
451d8738
MM
923 (if fmt-args
924 (apply #'format nil fmt fmt-args)
925 nil)
c0aa17ee 926 nil)))
9856c64a
MM
927 (reply-header-set-nocache reply)
928 (reply-content-add reply
929 (let ((title (html-escape (format nil "~A - ~A" code message))))
930 (do-html nil
931 (:html (:head (:title title)
932 (:/link :rel "stylecheet"
933 :href "/css/crow-httpd.css"
934 :type "text/css")
935 (:/link :rel "shortcut icon"
936 :href "/images/crow-httpd-icon.png"
937 :type "image/png"))
938 (:body
939 (:h1 title)
940 (do-html-when description
941 (:p (html-escape description)))
942 (:small (html-escape *server-version*)))))))
943 (reply-flush reply stream)))
c0aa17ee 944
6f477d7a 945;;; Special case of HTTP-ERROR which also sets the Allow header.
c0aa17ee 946(defun http-error-unimplemented (stream)
9856c64a
MM
947 (let ((reply (make-reply :code 501
948 :description "Method Not Implemented"
949 :no-keepalive t)))
950 (reply-header-set-nocache reply)
951 (reply-header-set reply '("Allow" "GET, HEAD, POST"))
952 (reply-content-add reply
953 (let ((title "501 - Method Not Implemented"))
954 (do-html nil
955 (:html (:head (:title title)
956 (:/link :rel "stylecheet"
957 :href "/css/crow-httpd.css"
958 :type "text/css")
959 (:/link :rel "shortcut icon"
960 :href "/images/crow-httpd-icon.png"
961 :type "image/png"))
962 (:body
963 (:h1 title)
964 (:small (html-escape *server-version*)))))))
965 (reply-flush reply stream)))
c0aa17ee 966
e529c610 967(defun http-redirect (stream req vpath temporary)
6f477d7a 968 "Utility function to redirect the client to another resource, VPATH.
9856c64a 969The reply will be made to STREAM for the REQUEST object REQ.
e529c610
MM
970301 (Moved Permanently) is issued by default, but if TEMPORARY is T,
971302 (Moved Temporarily) is issued."
9856c64a 972 (let* ((vhost (request-vhost req))
c0aa17ee 973 (path (vhost-path vhost vpath))
e529c610
MM
974 (code (if temporary 302 301))
975 (descr (if temporary "Moved Temporarily" "Moved Permanently"))
976 (descr2 (if temporary "temporarily" "permanently"))
9856c64a
MM
977 (reply (make-reply :code code
978 :description descr
979 :charset (vhost-charset vhost)))
c0aa17ee 980 (movedto (format nil "http://~A~A"
9856c64a 981 (or (request-host req)
9c896c30 982 (vhost-hostname vhost))
c0aa17ee 983 (if path (path-virtual path) nil)))
e529c610 984 (title (format nil "~D - ~A" code descr)))
c0aa17ee
MM
985 (unless path
986 (http-error stream 403 "Forbidden"
a837d3f7 987 "You do not have the permission to access this resource."))
9856c64a
MM
988 (reply-header-set-nocache reply)
989 (reply-header-set reply (list "Location" "~A" movedto))
990 (reply-content-add reply
991 (do-html nil
992 (:html (:head (:title title)
993 (:/link :rel "stylesheet"
994 :href "/css/crow-httpd.css"
995 :type "text/css")
996 (:/link :rel "shortcut icon"
997 :href "/images/crow-httpd-icon.png"
998 :type "image/png"))
999 (:body
1000 (:h1 title)
1001 (:p
1002 "The document was " descr2 " moved to "
1003 (:a :href movedto
1004 movedto) ".")
1005 (:small (html-escape *server-version*))))))
1006 (reply-flush reply stream)))
1007
1008
1009(declaim (inline index-time))
1010(defun index-time (&optional (ut (server-time)))
c0aa17ee
MM
1011 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
1012 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
6f477d7a 1013 (declare (type (simple-array string (12)) months))
c0aa17ee
MM
1014 (multiple-value-bind
1015 (second minute hour date month year)
1016 (decode-universal-time ut 0)
1017 (format nil "~2,'0D-~A-~4,'0D~C~2,'0D:~2,'0D:~2,'0D"
1018 date (svref months (1- month)) year #\U00A0
1019 hour minute second))))
1020
9856c64a
MM
1021(declaim (inline index-size))
1022(defun index-size (bytes)
c0aa17ee
MM
1023 (format nil "~,3F&nbsp;KB" (float (/ bytes 1024))))
1024
9856c64a 1025(defun index-send (stream path)
c0aa17ee
MM
1026 (let ((title (html-escape (format nil "Index of ~A" (path-virtual path))))
1027 (dirs
1028 (sort (remove-if-not
1029 #'path-valid
1030 (mapcar #'(lambda (d)
1031 (concatenate 'string
1032 (car (last (pathname-directory d)))
1033 "/"))
1034 (directory
1035 (concatenate 'string
1036 (path-real path) "/*/"))))
1037 #'string-lessp))
1038 (files
1039 (sort (remove-if-not
1040 #'path-valid
1041 (mapcar #'file-namestring
1042 (directory
1043 (concatenate 'string
1044 (path-real path) "/*.*"))))
1045 #'string-lessp)))
9856c64a
MM
1046 (reply-send stream
1047 (do-html nil
1048 (:html (:head (:title title)
1049 (:/link :rel "stylesheet"
1050 :href "/css/crow-httpd.css"
1051 :type "text/css")
1052 (:/link :rel "shortcut icon"
1053 :href "/images/crow-httpd-icon.png"
1054 :type "image/png"))
1055 (:body
1056 (:h1 title)
1057 (:/hr)
1058 (:ul (:li (:a :href "../"
1059 (:code "../") " (Parent directory)")))
1060 (do-html-unless (or dirs files)
1061 (:/hr)
1062 (:h2 "Directory empty."))
1063 (do-html-when dirs
1064 (:/hr)
1065 (:h2 "Directories")
1066 (:ul
1067 (do-html-loop (for i in dirs
1068 for l = (html-escape i))
1069 (:li (:a :href l (:code l))))))
1070 (do-html-when files
1071 (:/hr)
1072 (:h2 "Files")
1073 (:table :cellpadding "3"
c0aa17ee
MM
1074 (:tr (:th :width "70%" :align "left" (:b "Name"))
1075 (:th :width "10%" :align "right" (:b "Size"))
1076 (:th :width "20%" :align "center"
1077 (:b "Modified&nbsp;(UTC)")))
1078 (do-html-loop (for i in files
1079 for c from 0
1080 for color = (if (evenp c)
1081 "#b0b0b0"
1082 "#c0c0c0")
1083 for l = (html-escape i)
1084 for rpath = (concatenate 'string
1085 (path-real path)
1086 "/" i)
1087 for lastmod = (html-escape
9856c64a 1088 (index-time
c0aa17ee 1089 (file-write-date rpath)))
a837d3f7
MM
1090 for size = (handler-case
1091 (with-open-file
1092 (s rpath
1093 :direction :input)
1094 (file-length s))
1095 (file-error ()
1096 nil))
1097 unless size do (incf c)
1098 when size)
c0aa17ee
MM
1099 (:tr :style (format nil "background: ~A;" color)
1100 (:td (:a :href l (:code l)))
9856c64a 1101 (:td :align "right" (:code (index-size size)))
c0aa17ee 1102 (:td :align "center" (:code lastmod))))))
9856c64a
MM
1103 (:/hr)
1104 (:small (html-escape *server-version*))))))))
c0aa17ee
MM
1105
1106
1107;;; HTTP request parsing
1108
c0aa17ee 1109(defun url-decode (string)
6f477d7a
MM
1110 "Decodes the client-supplied URL supplied in STRING to another string,
1111returning it. Attempts to be resilient to bad input."
7f0ff025 1112 (declare (optimize (speed 3) (safety 0) (debug 0)))
c0aa17ee
MM
1113 (macrolet ((get-octet ()
1114 `(if (= input-max input-pos)
1115 (loop-finish)
1116 (prog1
1117 (aref input input-pos)
1118 (the fixnum (incf (the fixnum input-pos))))))
1119 (put-octet (o)
ba6d650d
MM
1120 `(vector-push ,o output))
1121 (hex-digit-p (c) ; Faster than DIGIT-CHAR-P
1122 `(member-character-intervals-p ,c
1123 (#\0 #\9) (#\A #\F) (#\a #\f))))
c0aa17ee
MM
1124 (loop
1125 with input = (utf-8-string-encode string)
1126 with input-pos of-type fixnum = 0
1127 with input-max of-type fixnum = (length input)
1128 with output = (make-array (length input)
1129 :element-type '(unsigned-byte 8)
1130 :fill-pointer 0)
7f0ff025
MM
1131 with byte-string = (make-string 2)
1132
c0aa17ee 1133 for o of-type (unsigned-byte 8) = (get-octet)
7f0ff025
MM
1134
1135 ;; Below, (map 'string #'identity `(,c1 ,c2)) is slower
c0aa17ee
MM
1136 when (= 37 o) do (let ((c1 (code-char (get-octet)))
1137 (c2 (code-char (get-octet))))
ba6d650d
MM
1138 ;; Below is faster than DIGIT-CHAR-P
1139 (when (and (hex-digit-p c1)
1140 (hex-digit-p c2))
7f0ff025
MM
1141 (setf (char byte-string 0) c1
1142 (char byte-string 1) c2)
1143 (put-octet (parse-integer byte-string
1144 :radix 16))))
c0aa17ee
MM
1145 else when (= 43 o) do (put-octet 32)
1146 else do (put-octet o)
7f0ff025 1147
c0aa17ee
MM
1148 finally (return (utf-8-string-decode output)))))
1149
ba6d650d 1150;;; Written in a way to be very efficient for ECL.
7f0ff025 1151(defun url-encode (string)
6f477d7a
MM
1152 "Encodes the supplied URL in STRING to a proper URL, returning that new
1153string."
7f0ff025
MM
1154 (declare (optimize (speed 3) (safety 0) (debug 0)))
1155 (with-output-to-string (out)
1156 (loop
1157 with nibbles of-type (simple-vector 16) =
1158 #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)
1159 with bytes of-type (vector unsigned-byte-8 *) =
1160 (utf-8-string-encode string)
1161 with out-string = (make-string 3)
1162
1163 for byte of-type unsigned-byte-8 across bytes
1164 for char of-type character = (code-char byte)
1165
1166 ;; Unfortunately using CHAR<= below causes function calls.
ba6d650d
MM
1167 ;; Same if using BYTE instead of a temporary FIXNUM with CHAR-CODE.
1168 ;; MEMBER-CHARACTER-INTERVALS-P expands into proper code.
1169 when (member-character-intervals-p char
1170 (#\A #\Z) (#\a #\z) (#\0 #\9))
7f0ff025
MM
1171 do (write-char char out)
1172
1173 else
1174 do
1175 (let ((n1 (the fixnum (ash (the fixnum (logand (the fixnum byte)
1176 (the fixnum #Xf0)))
1177 -4)))
1178 (n2 (the fixnum (logand (the fixnum byte)
1179 (the fixnum #X0f)))))
1180 (declare (type fixnum n1 n2))
1181 (setf (char out-string 0) #\%
1182 (char out-string 1) (svref nibbles n1)
1183 (char out-string 2) (svref nibbles n2))
1184 (write-string out-string out)))))
1185
486bec2d
MM
1186;;; Supplied with a hash-table or alist and a string set statement in the
1187;;; form "variable=value" or "#variable=value", add the association binding.
ab618abd
MM
1188;;; If the variable name begins with '#', it denotes that the variable
1189;;; is a vector, in which case multiple values may be accumulated into it.
486bec2d 1190(defun property-set (dict str)
ba6d650d 1191 (declare (optimize (speed 3) (safety 0) (debug 0)))
486bec2d
MM
1192 (let ((alist (listp dict))
1193 (parts (string-split str :separators '(#\=) :max 2)))
c0aa17ee
MM
1194 (when (= (length parts) 2)
1195 (let ((var (string-downcase (svref parts 0)))
ab618abd 1196 (val (if (= 1 (length parts)) "" (svref parts 1))))
c0aa17ee
MM
1197 ;; Escape and sanity-check VAR
1198 (setf var (url-decode var))
1199 (when (and (> (length var) 0)
ab618abd 1200 ;; Faster than EVERY, ALPHANUMERICP and MEMBER
ba6d650d
MM
1201 (loop
1202 for c of-type character across var
1203 unless (member-character-intervals-p c
486bec2d 1204 (#\0 #\9) (#\a #\z) #\- #\#)
ba6d650d
MM
1205 return nil
1206 finally (return t)))
c0aa17ee
MM
1207 ;; Unescape VAL
1208 (setf val (url-decode val))
486bec2d
MM
1209 (let ((o nil) (exists-p nil))
1210 (if alist
1211 (let ((pair (assoc var (car dict) :test #'string=)))
1212 (if pair
1213 (setf o (cdr pair)
1214 exists-p t)))
1215 (multiple-value-bind (s-o s-exists-p)
1216 (gethash var dict)
1217 (setf o s-o
1218 exists-p s-exists-p)))
ab618abd
MM
1219 (cond ((and (> (length var) 0)
1220 (char= #\# (char var 0)))
c0aa17ee
MM
1221 ;; Array
1222 (when (not exists-p)
1223 (setf o (make-array 16
1224 :element-type 'string
1225 :adjustable t
486bec2d
MM
1226 :fill-pointer 0))
1227 (if alist
1228 (setf (car dict) (push `(,var . ,o) (car dict)))
1229 (setf (gethash var dict) o)))
c0aa17ee
MM
1230 (vector-push-extend val o 16))
1231 (t
1232 ;; Normal associative variable
486bec2d
MM
1233 (if alist
1234 (setf (car dict) (push `(,var . ,val) (car dict)))
1235 (setf (gethash var dict) val))))))))))
c0aa17ee 1236
ba6d650d 1237
9856c64a
MM
1238(declaim (inline get-parse))
1239(defun get-parse (ht str)
c0aa17ee
MM
1240 (loop
1241 with parts = (string-split str
1242 :separators '(#\&)
1243 :trim-parts '(#\Newline #\Return))
1244 for p across parts
1245 do
1246 (property-set ht p)))
1247
1248;;; Reads the HTTP client request from STREAM, and returns two values,
1249;;; a status keyword symbol and a list consisting of the collected lines.
1250;;; :NO-REQUEST no request was sent (empty request)
1251;;; :REQUEST-SIZE-EXCEEDED request exceeded allowed request size
1252;;; :REQUEST-TIMEOUT allowed time for request to complete exceeded
1253;;; :SUCCESS success
9856c64a 1254(defun request-read (stream)
4a360be1 1255 (declare (optimize (speed 3) (debug 0) (safety 0)))
c0aa17ee
MM
1256 (loop
1257 with config = *config*
1258 with max-time of-type integer = (+ (server-time)
1259 (config-request-timeout config))
1260 with request-max-size of-type fixnum = (config-request-max-size config)
1261 with timeout-signal = nil
1262 for line = (handler-case
1263 (line-read stream)
1264 (sb-bsd-sockets:operation-timeout-error ()
1265 (setf timeout-signal t)
1266 "<TIMEOUT>"))
1267 for words = (if (= nlines 0)
1268 (string-split line :max 3)
1269 #())
1270 until timeout-signal ; Timeout signal
1271 while (< chars request-max-size) ; Request size exceeded
1272 while (< (server-time) max-time) ; Request timeout
1273 until (string= "" line) ; End of HTTP/1.x request
1274 until (and (= nlines 0) ; End of HTTP/0.x request
1275 (< (length words) 3))
1276 sum (length line) into chars of-type fixnum
1277 count line into nlines of-type fixnum
1278 collect line into lines
1279 finally
1280 (return
1281 (values (cond
1282 ((and (= nlines 0)
1283 (= (length words) 0))
1284 :no-request)
1285 ((> chars request-max-size)
1286 :request-size-exceeded)
1287 ((or (>= (server-time) max-time)
1288 timeout-signal)
1289 :request-timeout)
1290 ((and (= nlines 0)
1291 (< (length words) 3))
1292 (push line lines)
1293 :success)
1294 (t
1295 :success))
1296 lines))))
1297
1298;;; Request parsing preprocessor.
451d8738 1299;;; Extracts query from the first request line and coalesces continuing
c0aa17ee
MM
1300;;; header lines. Returns the request line as first value and the list
1301;;; of preprocessed lines as second value.
9856c64a 1302(defun request-parse-1 (lines)
c0aa17ee
MM
1303 (values (pop lines)
1304 (loop
1305 with list = '()
1306 with last = nil
1307 for line in lines
1308 do
1309 (cond ((and (let ((c (schar line 0)))
1310 (or (char= #\Space c) (char= #\Tab c)))
1311 last)
1312 (setf (car last)
1313 (concatenate 'string (car last) " "
1314 (string-trim '(#\Space #\Tab)
1315 line))))
1316 (t
1317 (let ((words
1318 (string-split line
1319 :separators '(#\:)
1320 :trim-parts '(#\Space #\Tab)
1321 :max 2)))
1322 (when (= 2 (length words))
1323 (push line list)
1324 (setf last list)))))
1325 finally (return list))))
1326
1327
9856c64a 1328(defstruct request
486bec2d
MM
1329 "Control data for a received and parsed client/user HTTP request.
1330Client-sent headers which are necessary for the HTTPd are also provided
1331slots for efficiency, although the VARS-HEADER slot provides an alist with
1332all of them for user code convenience, with the key of every entry in
1333lower-case. These are available via the REQ-VAR and WITH-HTTP-LET
1334interfaces along with GET, POST and COOKIE variables."
c0aa17ee
MM
1335 (raw nil)
1336 (protocol 0.9 :type (or null float))
1337 (method nil)
1338 (host nil)
1339 (vhost *vhost-default*)
1340 (path nil)
1341 (query nil)
1342 (post nil)
486bec2d
MM
1343 (vars-header (list '())) ; alist
1344 (vars-get (list '())) ; alist
1345 (vars-post (make-hash-table :test 'equal)) ; We expect large forms
1346 (vars-cookie (list '())) ; alist
c0aa17ee
MM
1347 (agent nil)
1348 (referer nil)
9856c64a 1349 (keepalive nil :type boolean)
c0aa17ee
MM
1350 (content-type "application/x-www-form-urlencoded")
1351 (content-length -1 :type integer)
1352 (modified-since nil)
1353 (unmodified-since nil)
1354 (range nil))
1355
9856c64a
MM
1356(declaim (inline request-disable-keepalive))
1357(defun request-disable-keepalive (request)
1358 (setf (request-keepalive request) nil))
c0aa17ee 1359
451d8738
MM
1360;;; Parses an HTTP Range of the format [bytes=][from]-[to][,[from]-[to]...]
1361;;; and returns a list of (or null integer) pairs. The range is not
1362;;; checked for sanity yet, as this also requires knowing the size of
1363;;; the resource. NIL is returned if the range(s) could not be parsed.
1364;;; User code may use RANGE-VALIDATE to perform further validation and
1365;;; processing.
1366(defun range-parse (line)
1367 (let* ((pos (search "bytes=" line :test #'string-equal))
1368 (spos (if pos 6 0)))
1369 ;; LOOP has better inlining potential than MAP below and is as clean
1370 (loop
1371 with l = (loop
1372 with v = (string-split line
1373 :separators '(#\,)
1374 :start spos
1375 :max 16)
1376 for p across v
1377 collect (concatenate 'string " " p " "))
1378 for p in l
1379 collect (loop
1380 with v = (string-split p
1381 :separators '(#\-)
1382 :trim-parts '(#\Space)
1383 :max 2)
1384 for n across v
1385 collect (parse-integer n :junk-allowed t)))))
1386
1387;;; This part of RFC 2616 seems to have been designed for humans, yet
1388;;; software must deal with it, but this is a common theme in HTTP, like
1389;;; the parsing of RFC 822/850/1123 dates intended for humans.
1390;;; XXX Eventually cleanup this messy function
1391(defun range-validate (req size)
1392 "Attempts to validate client-provided range(s), if supplied.
1393SIZE specifies the size of the resource to serve (i.e. a file length).
1394On success, returns a list of pre-processed range pair(s) filled with actual
1395byte offsets. On failure, returns :NOT-SATISFIABLE or NIL (empty list).
1396The returned range has any overlapping ranges optimized and any redundant
1397contiguous ranges coalesced for the caller. If the result only consists of
1398a single range covering the whole document, NIL is returned."
9856c64a 1399 (unless (request-range req)
451d8738
MM
1400 (return-from range-validate nil))
1401 ;; First convert human-friendly ambiguous ranges to actual byte ranges
1402 (let* ((byte-ranges
1403 (loop
9856c64a 1404 with ranges = (request-range req)
451d8738
MM
1405 for r in ranges
1406 for (from to) = r
1407 do
1408 (cond ((null from)
1409 (when (null to)
1410 (return nil))
1411 (if (>= to size)
1412 (setf from 0
1413 to (1- size))
1414 (setf from (- size to)
1415 to (1- size))))
1416 ((null to)
1417 (when (null from)
1418 (return nil))
1419 (setf to (1- size)))
1420 (t
1421 (when (>= to size)
1422 (setf to (1- size)))))
1423 (unless (<= from to)
1424 (return nil))
1425 (unless (< to size)
1426 (return :not-satisfiable))
1427 collect (list from to)))
1428
1429 ;; Optimize any overlapping ranges, eliminating redundant ones
1430 (optimized-ranges
1431 (loop
1432 for r1 in byte-ranges
1433 for r2 = (loop
1434 for r3 in byte-ranges
1435 when (and (<= (first r1) (second r3))
1436 (>= (second r1) (first r3)))
1437 collect r3)
1438 for optimized = (list (reduce #'min r2 :key #'first)
1439 (reduce #'max r2 :key #'second))
1440 unless (member optimized final
1441 :test #'(lambda (a b)
1442 (and (= (first a) (first b))
1443 (= (second a) (second b)))))
1444 collect optimized into final
1445 finally (return (sort final #'(lambda (a b)
1446 (< (first a) (first b)))))))
1447
1448 ;; Coalesce any redundant contiguous ranges together
1449 (coalesced-ranges
1450 (loop
1451 for r on optimized-ranges
1452 when (and (cdr r)
1453 (= (second (car r))
1454 (1- (first (cadr r)))))
1455 collect (prog1
1456 (list (first (car r)) (second (cadr r)))
1457 (setf r (cdr r)))
1458 else
1459 collect (car r))))
1460
1461 ;; If there only remains a single range which covers the whole
1462 ;; document, ignore it.
1463 (if (and coalesced-ranges
1464 (destructuring-bind (from to) (first coalesced-ranges)
1465 (and (= 0 from) (= (1- size) to))))
1466 nil
1467 coalesced-ranges)))
1468
00f0bd59
MM
1469;;; Similar to COND but requires less explicit code. Similar to CASE but
1470;;; can use a custom test predicate. Is simpler to both in that we don't
1471;;; need a default case nor multiple matchs per result form.
486bec2d
MM
1472(defmacro do-predicate-case ((test-function var &optional (default nil))
1473 &rest match-code-pairs)
00f0bd59
MM
1474 (let ((s-var (gensym)))
1475 `(let ((,s-var ,var))
1476 (cond
1477 ,@(loop
1478 for pair in match-code-pairs
1479 for (string code) = pair
1480 collect `((,test-function ,string ,s-var) ,code))
486bec2d 1481 (t ,default)))))
00f0bd59
MM
1482
1483;;; Utility macro which hashes VAR at runtime but has every constant object
1484;;; case hashed at compile-time, to numerically compare matches instead of
1485;;; calling a full-comparison function.
1486(defmacro do-sxhash-case ((var) &rest match-code-pairs)
1487 (let ((var-hash (gensym)))
1488 `(let ((,var-hash (sxhash ,var)))
1489 (declare (type fixnum ,var-hash))
1490 (cond
1491 ,@(loop
4a360be1 1492 with unique-hashes = '()
00f0bd59
MM
1493 for pair in match-code-pairs
1494 for (const-object code) = pair
4a360be1
MM
1495 for hash = (sxhash const-object)
1496 for new-hashes = (adjoin hash unique-hashes :test #'=)
1497 when (eq new-hashes unique-hashes) do
1498 (error "SXHASH collision in DO-SXHASH-CASE for constant ~S"
1499 const-object)
1500 else do
1501 (setf unique-hashes new-hashes)
1502 collect `((= ,hash ,var-hash) ,code))))))
00f0bd59
MM
1503
1504;;; Verify for headers which interest us and fill the REQ structure slots
486bec2d 1505;;; as appropriate. Also fill the HEADERS slot alist.
9856c64a 1506(defun request-apply-headers (req headers)
00f0bd59
MM
1507 (loop
1508 for line in headers
1509 for column of-type fixnum = (position #\: line) ; Should never be NIL
1510 for var = (string-trim '(#\Space)
1511 (string-downcase (subseq line 0 column)))
1512 for val = (string-trim '(#\Space)
1513 (subseq line (the fixnum (1+ column))))
486bec2d 1514 collect `(,var . ,val) into alist
00f0bd59
MM
1515 do
1516 (do-sxhash-case (var)
1517 ("host"
1518 (let* ((pos (position #\: val :from-end t))
1519 (h (if pos
1520 (subseq val 0 pos)
1521 val)))
9856c64a
MM
1522 (setf (request-host req) val
1523 (request-vhost req) (vhost-query h :default t))))
00f0bd59 1524 ("user-agent"
9856c64a 1525 (setf (request-agent req) val))
00f0bd59 1526 ("referer"
9856c64a 1527 (setf (request-referer req) val))
00f0bd59 1528 ("cookie"
9856c64a 1529 (property-set (request-vars-cookie req) val))
00f0bd59
MM
1530 ("connection"
1531 (do-predicate-case (string-equal val)
1532 ("keep-alive"
9856c64a 1533 (setf (request-keepalive req) t))
00f0bd59 1534 ("close"
9856c64a 1535 (setf (request-keepalive req) nil))))
00f0bd59 1536 ("content-type"
9856c64a 1537 (setf (request-content-type req) val))
00f0bd59 1538 ("content-length"
9856c64a 1539 (setf (request-content-length req)
00f0bd59
MM
1540 (handler-case
1541 (parse-integer val)
1542 (t ()
1543 -1))))
1544 ("if-modified-since"
9856c64a 1545 (setf (request-modified-since req)
00f0bd59
MM
1546 (server-time-rfc-parse val)))
1547 ("if-unmodified-since"
9856c64a 1548 (setf (request-unmodified-since req)
00f0bd59
MM
1549 (server-time-rfc-parse val)))
1550 ("range"
9856c64a 1551 (setf (request-range req) (range-parse val))))
486bec2d 1552 finally
9856c64a 1553 (setf (car (request-vars-header req)) alist)))
451d8738 1554
c0aa17ee
MM
1555;;; Reads and parses POST data request if any
1556;;; XXX Should at least also support "multipart/form-data" enctype
9856c64a 1557(defun post-parse (stream)
c0aa17ee 1558 (let* ((req *request*)
9856c64a
MM
1559 (req-length (request-content-length req))
1560 (req-vhost (request-vhost req))
1561 (req-type (let* ((type (request-content-type req))
c0aa17ee
MM
1562 (pos (position #\; type)))
1563 (if pos
1564 (subseq type 0 pos)
1565 type))))
9856c64a
MM
1566 (unless (eq (request-method req) :post)
1567 (return-from post-parse))
c0aa17ee
MM
1568 (unless (string= req-type "application/x-www-form-urlencoded")
1569 (http-error stream 415 "Unsupported Media Type"
1570 "The POST enctype \"~A\" is unsupported." req-type))
1571 (when (= -1 req-length)
1572 (http-error stream 411 "Length Required"))
1573 (unless (< 0 req-length (vhost-post-max-size req-vhost))
1574 (http-error stream 413 "Request Entity Too Large"))
1575 (let ((pd
1576 (handler-case
1577 (loop
1578 with max-time of-type integer = (+ (server-time)
1579 (vhost-post-timeout
1580 req-vhost))
1581 with timeout-signal = nil
1582 with vector = (make-array req-length
1583 :element-type 'character
1584 :initial-element #\Nul)
1585 sum (handler-case
1586 (read-sequence vector stream
1587 :start read-length)
1588 (simple-error ()
1589 (setf timeout-signal t)
1590 0)) into read-length
1591 until timeout-signal
1592 while (< (server-time) max-time)
1593 while (< read-length req-length)
1594 finally
1595 (progn
1596 (when (or (>= (server-time) max-time)
1597 timeout-signal)
1598 (http-error stream 408 "Request Timeout"))
1599 (return vector)))
1600 (ext:stream-decoding-error ()
1601 (http-error stream 500 "Internal Server Error"
1602 "Character decoding error.")))))
1603 (if pd
1604 (progn
9856c64a 1605 (get-parse (request-vars-post req) pd)
c0aa17ee
MM
1606 pd)
1607 nil))))
1608
1609;;; To avoid constant INTERNing, simply match method strings to keywords.
4a360be1
MM
1610;;; Matching symbols using EQ afterwards is simple and as efficient as
1611;;; matching numbers.
f6526a2e 1612(declaim (inline method-keyword))
c0aa17ee 1613(defun method-keyword (method)
4a360be1
MM
1614 (or (do-sxhash-case (method)
1615 ("GET" :get)
1616 ("POST" :post)
1617 ("HEAD" :head)
1618 ("PUT" :put)
1619 ("DELETE" :delete)
1620 ("TRACE" :trace)
1621 ("CONNECT" :connect)
1622 ("OPTIONS" :options))
1623 :unknown))
c0aa17ee
MM
1624
1625;;; Used to parse the HTTP version
f6526a2e 1626(declaim (inline parse-float))
c0aa17ee
MM
1627(defun parse-float (string)
1628 (when (char= #\. (char string 0))
1629 (setf string (concatenate 'string "0" string)))
1630 (let ((w (string-split string :separators '(#\.) :max 2)))
1631 (if (= 2 (length w))
1632 (let ((i1 (handler-case
1633 (parse-integer (aref w 0))
1634 (t ()
1635 nil)))
1636 (i2 (handler-case
1637 (parse-integer (aref w 1))
1638 (t ()
1639 nil))))
1640 (if (and i1 i2)
1641 (float (+ i1 (/ i2 (expt 10 (length (aref w 1))))))
1642 nil))
1643 nil)))
1644
1645;;; Parse supplied HTTP version STRING, returning NIL on error or
1646;;; a floating point representing the number.
f6526a2e 1647(declaim (inline version-parse))
c0aa17ee
MM
1648(defun version-parse (string)
1649 (let ((w (string-split string :separators '(#\/) :max 2)))
1650 (if (and (= 2 (length w))
1651 (string-equal "HTTP" (aref w 0)))
1652 (parse-float (aref w 1))
1653 nil)))
1654
1655;;; Actual request parsing function.
9856c64a 1656(defun request-parse (lines stream)
c0aa17ee
MM
1657 ;; Preprocessing
1658 (multiple-value-bind (request headers)
9856c64a
MM
1659 (request-parse-1 lines)
1660 (let ((req (make-request))
c0aa17ee 1661 (valid nil))
9856c64a 1662 (setf (request-raw req) lines)
c0aa17ee
MM
1663
1664 ;; Request method/path/protocol
1665 (let* ((words (string-split request :max 4))
1666 (nwords (length words)))
1667 (cond ((< nwords 3)
9856c64a
MM
1668 (setf (request-method req) (method-keyword (svref words 0))
1669 (request-path req) (if (= 2 (length words))
1670 (svref words 1)
1671 "/")
c0aa17ee
MM
1672 valid t))
1673 ((= 3 nwords)
9856c64a
MM
1674 (setf (request-protocol req) (version-parse (svref words 2))
1675 (request-method req) (method-keyword (svref words 0))
1676 (request-path req) (svref words 1) valid t))))
c0aa17ee
MM
1677
1678 ;; Keep-Alive on by default for >= HTTP/1.1, headers might change it
9856c64a 1679 (let ((protocol (request-protocol req)))
c0aa17ee 1680 (when (and protocol (>= protocol 1.1))
9856c64a 1681 (setf (request-keepalive req) t)))
c0aa17ee
MM
1682
1683 ;; Headers
1684 (when valid
9856c64a 1685 (request-apply-headers req headers))
c0aa17ee
MM
1686
1687 ;; Separate path from query variables; fill in GET variables if any.
9856c64a 1688 (let* ((path (request-path req))
c0aa17ee
MM
1689 (pos (position #\? path :test #'char=))
1690 (epos (position #\; path :test #'char= :from-end t)))
1691 (when pos
1692 (let ((get (subseq path (1+ pos) (if epos epos (length path)))))
9856c64a
MM
1693 (setf (request-path req) (subseq path 0 pos)
1694 (request-query req) get)
1695 (get-parse (request-vars-get req) get))))
c0aa17ee
MM
1696
1697 ;; Read and parse POST data if any
1698 (let ((*request* req))
9856c64a 1699 (setf (request-post req) (post-parse stream)))
c0aa17ee
MM
1700
1701 ;; Finally return request object for eventual dispatching
1702 req)))
1703
1704
38e2dc27
MM
1705;;; HTTP variable access for user code
1706
c0aa17ee 1707(defun req-var (req type &optional name default)
486bec2d
MM
1708 "Queries the request environment REQ for a variable of TYPE :GET, :POST,
1709:COOKIE or :HEADER named NAME \(may be a symbol or a string\). DEFAULT is
c0aa17ee 1710returned if no such binding exists \(which defaults to NIL\). If NAME is
486bec2d
MM
1711omited, an alist is returned of all variable bindings of the specified
1712TYPE."
1713 (declare (optimize (speed 3) (safety 0) (debug 0)))
1714 (let ((dict (do-predicate-case (eq type :nil)
9856c64a
MM
1715 (:get (request-vars-get req))
1716 (:post (request-vars-post req))
1717 (:cookie (request-vars-cookie req))
1718 (:header (request-vars-header req)))))
486bec2d
MM
1719 (when (eq :nil dict)
1720 (error "TYPE not one of :GET :POST :COOKIE :HEADER for ~S"
1721 name))
1722 (typecase dict
1723 (list ; An alist
1724 (if name
1725 (let ((pair (assoc (string name) (car dict)
1726 :test #'string-equal)))
1727 (if pair
1728 (cdr pair)
1729 default))
1730 (car dict)))
1731 (t ; Must be a hash-table
1732 (if name
c0aa17ee 1733 (multiple-value-bind (val exists-p)
486bec2d 1734 (gethash (string-downcase (string name)) dict)
c0aa17ee
MM
1735 (if exists-p
1736 val
486bec2d
MM
1737 default))
1738 (loop
1739 for key being each hash-key of dict using (hash-value val)
1740 collect `(,key . ,val)))))))
c0aa17ee 1741
486bec2d 1742(defmacro with-http-let (bindings &body body)
c0aa17ee 1743 "Helper macro for REQ-VAR. Permits to perform multiple local bindings
486bec2d
MM
1744with variables bound in the request environment *REQUEST*. BINDINGS
1745consists of a list of LET-like bindings with the following elements:
c0aa17ee 1746\(VAR TYPE &optional NAME DEFAULT\) where VAR is the variable to lexically
486bec2d
MM
1747bind, TYPE is one of :GET, :POST, :COOKIE or :HEADER, NAME is the name of
1748the variable in the environment \(represented by a symbol or string\), and
c0aa17ee
MM
1749DEFAULT is the default value to bind to VAR if NAME is not bound \(defaults
1750to NIL\). If NAME is omited, a list of all bound variables of TYPE in
1751REQ is bound to VAR."
1752 (let ((s-req (gensym)))
486bec2d 1753 `(let ((,s-req *request*))
c0aa17ee
MM
1754 (let (,@(loop
1755 for binding in bindings
1756 for (var type name default) = binding
1757 collect `(,var (req-var ,s-req ,type ,name ,default))))
1758 ,@body))))
1759
1760
1761;;; Debugging
1762
6f477d7a
MM
1763(defvar *debug* '(:log :log-errors :test)
1764 "Currently enabled debugging features. Supported features:
1765 :log-requests :log-connections :log-errors :test :beep
9856c64a 1766 :log-requests - Log the REQUEST object of every request
6f477d7a
MM
1767 :log-connections - Log connection/disconnections, not only requests
1768 :log-errors - Log common errors such as no-request, disconnection, etc.
1769 :test - Enable the \"/test\" page
1770 :beep - Emit a beep sound at the arrival of a request (NetBSD-specific)
1771User code may use custom features. See the DEBUG slot of the HTTPD-CONFIG
1772object, as well as the DEBUG-FEATURE function for more information.")
c0aa17ee 1773
f6526a2e 1774(declaim (inline debug-feature))
c0aa17ee 1775(defun debug-feature (keyword)
4a360be1
MM
1776 "Returs T if debug feature KEYWORD is enabled, or NIL.
1777See the *DEBUG* documentation for more details."
c0aa17ee
MM
1778 (let ((debug *debug*))
1779 (and debug (position keyword debug :test #'eq))))
1780
1781(defun beep ()
451d8738
MM
1782 (ignore-errors
1783 (with-open-file (s "/dev/speaker" :direction :output)
1784 (write-string "O1L15D" s))))
c0aa17ee 1785
c0aa17ee
MM
1786
1787(defun html-test-page (req connection)
9856c64a
MM
1788 (reply-send (connection-stream connection)
1789 (do-html nil
1790 (:html (:head (:title "Crow-HTTPd")
1791 (:/link :rel "stylesheet"
1792 :href "/css/crow-httpd.css"
1793 :type "text/css")
1794 (:/link :rel "shortcut icon"
1795 :href "/images/crow-httpd-icon.png"
1796 :type "image/png"))
1797 (:body
1798 (:h1 "Crow-HTTPd")
1799 (:/img :src "/images/crow-httpd-logo.png"
1800 :alt "Crow-HTTPd Logo")
1801 (:h2 "An interactively developed server in Common Lisp")
1802 (:p "This page, forms and server code may change anytime "
1803 "without interruption; a live SWANK connection can "
1804 "be maintained from "
1805 (:a :href "http://www.gnu.org/software/emacs/" "Emacs")
1806 " and "
1807 (:a :href
1808 "http://www.common-lisp.net/project/slime/" "SLIME")
1809 " to the server, and the system is developed "
1810 "interactively as spare time permits. A particularity "
1811 "of "
1812 (:a :href "http://en.wikipedia.org/wiki/Common_Lisp"
1813 "Common Lisp")
1814 " is that it can be used as a scripting language "
1815 "interactively, with wanted modified code blocks "
1816 "reapplied in the live image. "
1817 "These code blocks may be reapplied as compiled bytecode "
1818 "for interpretation (or in this case, using "
1819 (:a :href "http://ecls.sourceforge.net/" "ECL")
1820 ", be recompiled efficiently to C, linked as a dynamic "
1821 "loadable module and reloaded immediately, which typing "
1822 (:code "C-c C-c") " on a code block in Emacs automates). "
1823 "Incremental, iterative development is possible, with "
1824 "the possibility of later profiling and optimizing by "
1825 "adding type annotations, etc.")
1826 (:h3 "Related links")
1827 (:ul (:li (:a :href "http://mmondor.pulsar-zone.net/"
1828 "The author's site, hosted by Crow-HTTPd"))
1829 (:li (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/~checkout~/mmondor/mmsoftware/cl/server/README?content-type=text%2Fplain"
1830 :target "_blank"
1831 "The README document with more information and "
1832 "a features list"))
1833 (:li (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1834 :target "_blank"
1835 "The source code of this server"))
1836 (do-html-when (find-package :test-applications)
1837 (:li (:a :href "/chat"
1838 :target "_blank"
1839 "The first test application written for "
1840 " Crow, a type of \"chat\" wall"))
1841 (:li (:a :href "/names"
1842 :target "_blank"
1843 "A second application used to help "
1844 "accumulate name suggestions"))))
1845
1846 (:h2 "Test form")
1847 (:form :action (html-escape
1848 (format nil
1849 "/test?id=~64,'0X" (random
1850 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
1851 :method "post"
1852 "First name: "
1853 (:/input :name "first-name"
1854 :type "text"
1855 :size "32"
1856 :maxlength "64"
1857 :value (html-escape
1858 (req-var req :post :first-name
1859 "First name")))
1860 (:/br)
1861 "Last name: "
1862 (:/input :name "last-name"
1863 :type "text"
1864 :size "32"
1865 :maxlength "64"
1866 :value (html-escape
1867 (req-var req :post :last-name
1868 "Last name")))
1869 (:/br)
1870 (do-html-loop (for i from 1 to 10
1871 for s = (format nil "~2,'0D" i)
1872 for v = (format nil "box-~2,'0D" i))
1873 "Box " s
1874 (let* ((a (req-var req :post :#box nil))
1875 (c (if a (find v a :test #'string=) nil)))
1876 (do-html-if c
1877 (:/input :name "#box"
1878 :type "checkbox"
1879 :value v
1880 :/checked)
1881 (:/input :name "#box"
1882 :type "checkbox"
1883 :value v))))
1884 (:/br)
1885 (:textarea :name "message"
1886 :rows 10
1887 :cols 60
1888 (html-escape
1889 (req-var req :post :message
1890 "Message text.")))
1891 (:/br)
1892 (:/input :type "submit" :value "Post message"))
1893 (:h2 "Test form 2 (multipart/form-data)")
1894 (:p (:em "This test is expected to fail for now."))
1895 (:form :action "/test"
1896 :method "post"
1897 :enctype "multipart/form-data"
1898 (:/input :name "description"
1899 :type "text"
1900 :size "32"
1901 :maxlength "64"
1902 :value (html-escape
1903 (req-var req :post :description
1904 "File description")))
1905 (:/br)
1906 (:/input :name "file"
1907 :type "file"
1908 :size "32"
1909 :maxlength "64"
1910 :value "File to send")
1911 (:/br)
1912 (:/input :type "submit"
1913 :value "Upload file"))
1914
1915 (:h2 "Client information")
1916 (:h3 "Originator")
1917 (:p (connection-address-string connection) ":"
1918 (connection-port connection))
1919 (:h3 "Browser request")
1920 (:pre
1921 (do-html-loop (for line in (request-raw req))
1922 (html-escape (format nil "~A~%" line))))
1923
1924 (:h2 "Request state information")
a2c1546f
MM
1925 (:h3 "Method, Path and VHost")
1926 (:p (html-escape (format nil "~A on ~S on ~S"
1927 (string (request-method req))
9856c64a
MM
1928 (request-path req)
1929 (vhost-hostname
1930 (request-vhost req)))))
1931 (with-http-let ((bindings :get))
1932 (do-html-when bindings
1933 (:h3 "GET variables")
1934 (:pre
1935 (do-html-loop
1936 (for (key . val) in bindings)
1937 (html-escape (format nil "~A = ~S~%"
1938 key val))))))
1939 (with-http-let ((bindings :post))
1940 (do-html-when bindings
1941 (:h3 "POST variables")
1942 (:pre
1943 (do-html-loop
1944 (for (key . val) in bindings)
1945 (html-escape (format nil "~A = ~S~%"
1946 key val))))))
1947 (with-http-let ((bindings :cookie))
1948 (do-html-when bindings
1949 (:h3 "COOKIE variables")
1950 (:pre
1951 (do-html-loop
1952 (for (key . val) in bindings)
1953 (html-escape (format nil "~A = ~S~%"
1954 key val))))))
1955 (with-http-let ((bindings :header))
1956 (do-html-when bindings
1957 (:h3 "HEADER variables")
1958 (:pre
1959 (do-html-loop
1960 (for (key . val) in bindings)
1961 (html-escape (format nil "~A = ~S~%"
1962 key val))))))
1963
1964 (:h2 "Server information")
1965 (:p *server-version* " "
1966 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
1967 :target "_blank"
1968 "(Source available here)."))
1969 (:p (do-html-loop
1970 (with packages = (list-all-packages)
1971 for p in packages
1972 for s = (find-symbol "*RCSID*" p)
1973 for v = (if (and s (boundp s))
1974 (html-escape (symbol-value s)) nil)
1975 when v)
1976 (:code v) (:/br)))
1977 (:p "HTTP server uptime: " (server-uptime))
1978 (:code (html-escape (lisp-implementation-type)) " "
1979 (html-escape (lisp-implementation-version)) " ("
1980 (html-escape (first (mp::uname))) ")")
1981 (:p (:a :href "http://validator.w3.org/check?uri=referer"
1982 (:/img :src "/images/valid-xhtml.png"
1983 :alt "Valid XHTML 1.0 Transitional"
1984 :height "31"
1985 :width "88"))))))))
1986
a2c1546f 1987(defun dispatch-dynamic (req connection function)
9856c64a 1988 (let ((method (request-method req))
c0aa17ee
MM
1989 (stream (connection-stream connection)))
1990 (cond
1991 ;; HEAD not allowed for HTTP/0.9
9856c64a 1992 ((and (< (request-protocol req) 1.0) (eq :head method))
c0aa17ee
MM
1993 (http-error stream 400 "Bad Request"
1994 "HTTP versions <= 0.9 have no HEAD method."))
1995 ;; Allow these for dynamic handlers
1996 ((member method '(:get :head :post) :test #'eq))
1997 ;; But forbid these
1998 ((member method '(:options :delete :trace) :test #'eq)
1999 (http-error stream 405 "Method Not Allowed"
2000 "Method not allowed for dynamic handlers."))
2001 ((eq :connect method)
2002 (http-error stream 405 "NO CARRIER")) ; Easter egg
2003 ;; Any other is unimplemented for dynamic content
2004 (t
2005 (http-error-unimplemented stream)))
de2a1441
MM
2006
2007 (handler-case
2008 (funcall function req connection)
9856c64a 2009 ((not (or signal-reply signal-reply-no-keepalive)) (c)
de2a1441
MM
2010 (log-error c)
2011 (http-error stream 500 "Internal Error"
2012 "A temporary internal error has occurred."))))
2013 (values))
c0aa17ee 2014
de2a1441
MM
2015(defvar *autoindex-permission* nil)
2016
9856c64a
MM
2017(defun dispatch-static (req connection path embedded)
2018 (let ((vhost (request-vhost req))
c0aa17ee
MM
2019 (stream (connection-stream connection))
2020 truepath)
2021
2022 ;; Allowed method?
9856c64a 2023 (let ((method (request-method req)))
c0aa17ee
MM
2024 (cond
2025 ;; HEAD not allowed for HTTP/0.9
9856c64a 2026 ((and (< (request-protocol req) 1.0) (eq :head method))
c0aa17ee
MM
2027 (http-error stream 400 "Bad Request"
2028 "HTTP versions <= 0.9 have no HEAD method."))
2029 ;; Allow these for static content
2030 ((member method '(:get :head) :test #'eq))
2031 ;; But forbid these
2032 ((member method '(:options :delete :trace :post)
2033 :test #'eq)
2034 (http-error stream 405 "Method Not Allowed"
2035 "Method not allowed for static resources."))
2036 ((eq :connect method)
2037 (http-error stream 405 "NO CARRIER")) ; Easter egg
2038 ;; Any other is unimplemented for static content
2039 (t
2040 (http-error-unimplemented stream))))
a2c1546f
MM
2041
2042 ;; VHOST has a NIL ROOT and resource not handled by a handler?
2043 (unless (or (path-real path) embedded)
2044 (http-error stream 404 "Not Found"
2045 "\"~A\" could not be found."
2046 (path-virtual path)))
c0aa17ee 2047
d371ed9e 2048 ;; Special fast-path for EMBEDDED files.
de2a1441 2049 ;; Since these files should be small, we don't yet support If-Modified
404e3498
MM
2050 ;; or Range for them. XXX We should abstract the code that does so and
2051 ;; use it here.
de2a1441
MM
2052 (when embedded
2053 (let* ((const-file (if (symbolp embedded)
2054 (symbol-value embedded)
2055 embedded))
9856c64a
MM
2056 (reply (make-reply :mime-type (const-file-type const-file)
2057 :charset (vhost-charset vhost))))
2058 (reply-header-set reply
de2a1441 2059 (list "Last-Modified" "~A"
404e3498 2060 (server-time-rfc (const-file-modified const-file))))
9856c64a 2061 (return-from dispatch-static
de2a1441
MM
2062 (file-send-full-embedded req reply stream const-file))))
2063
a837d3f7
MM
2064 ;; File/directory exists? 404 if not, 403 on error.
2065 (handler-case
2066 (unless (setf truepath (probe-file (path-real path)))
2067 (http-error stream 404 "Not Found"
2068 "\"~A\" could not be found."
2069 (path-virtual path)))
2070 (file-error ()
2071 (http-error stream 403 "Forbidden"
de2a1441
MM
2072 "You do not have the permission to access \"~A\"."
2073 (path-virtual path))))
c0aa17ee
MM
2074
2075 ;; If a directory, send index file if exists, but 403 otherwise.
2076 (let ((s-truepath (directory-namestring truepath)))
2077 (when (and (= 0 (length (file-namestring truepath)))
2078 (eql (position #\/ s-truepath :test #'char= :from-end t)
2079 (1- (length s-truepath))))
2080 ;; Points to a directory, make sure that "/" is part of the path
2081 ;; not to confuse browsers
2082 (let ((vpath (path-virtual path)))
2083 (unless (char= #\/ (schar vpath (1- (length vpath))))
2084 (http-redirect stream req (concatenate 'string
889469c2 2085 vpath "/") nil)))
c0aa17ee
MM
2086 ;; Check if we can find the index
2087 (let ((tp
2088 (probe-file
2089 (path-valid (concatenate 'string
2090 "/" (path-real path) "/"
2091 (vhost-index vhost))))))
2092 (setf truepath nil)
2093 (if tp
2094 (setf truepath tp)
de2a1441 2095 (if *autoindex-permission*
9856c64a 2096 (index-send stream path)
c0aa17ee
MM
2097 (http-error stream 403 "Forbidden"
2098 "You do not have the permission to access \"~A\"."
2099 (path-virtual path)))))))
2100
2101 ;; Prepare to send file
2102 (when truepath
2103 (let* ((mime-type (mime-query
2104 (path-extension (file-namestring truepath))))
9856c64a
MM
2105 (reply (make-reply :mime-type mime-type
2106 :charset (vhost-charset vhost)))
c0aa17ee
MM
2107 (lastmodsecs (file-write-date truepath))
2108 (lastmod (server-time-rfc lastmodsecs)))
2109
2110 ;; If-modified/If-unmodified
9856c64a 2111 (let ((modified-since (request-modified-since req)))
c0aa17ee
MM
2112 (when (and modified-since
2113 (<= lastmodsecs modified-since))
9856c64a
MM
2114 (reply-code-set reply 304 "Not Modified")
2115 (reply-flush reply stream 0)))
2116 (let ((unmodified-since (request-unmodified-since req)))
c0aa17ee
MM
2117 (when (and unmodified-since
2118 (> lastmodsecs unmodified-since))
9856c64a
MM
2119 (reply-code-set reply 412 "Precondition Failed")
2120 (reply-flush reply stream 0)))
c0aa17ee 2121
c0aa17ee 2122 ;; Finally send file (except for HEAD)
9856c64a 2123 (reply-header-set reply (list "Last-Modified" "~A" lastmod))
451d8738 2124
a837d3f7
MM
2125 (handler-case
2126 (progn
ecdf3a46
MM
2127 (with-open-file (file-stream truepath
2128 :direction :input
2129 :element-type '(unsigned-byte 8))
2130 (let* ((size (file-length file-stream))
451d8738
MM
2131 (ranges (range-validate req size)))
2132 (when (eq :not-satisfiable ranges)
2133 (http-error stream 416
2134 "Requested Range Not Satisfiable"))
ecdf3a46 2135 (if ranges
1f844812
MM
2136 (file-send-ranges req reply stream file-stream size
2137 ranges)
2138 (file-send-full req reply stream file-stream size)))))
a837d3f7
MM
2139 (file-error ()
2140 (http-error stream 403 "Forbidden"
451d8738
MM
2141 "You do not have the permission to access \"~A\"."
2142 (path-virtual path)))))))
2143 (values))
2144
de2a1441
MM
2145(declaim (inline file-send-full-embedded))
2146(defun file-send-full-embedded (req reply stream const-file)
2147 (let ((data (const-file-data const-file)))
9856c64a
MM
2148 (reply-flush reply stream (length data))
2149 (unless (eq :head (request-method req))
ace88c7a
MM
2150 (io:vector-write (stream-fd stream) data)))
2151#|
de2a1441
MM
2152 (write-sequence data stream)
2153 (finish-output stream)))
ace88c7a 2154|#
de2a1441
MM
2155 (values))
2156
f6526a2e 2157(declaim (inline file-send-full))
1f844812 2158(defun file-send-full (req reply stream file-stream size)
9856c64a
MM
2159 (reply-flush reply stream size)
2160 (unless (eq :head (request-method req))
ecdf3a46
MM
2161 (loop
2162 with seq = *buffer*
ace88c7a
MM
2163 with seqsize = (array-dimension seq 0)
2164 with socket-fd of-type fixnum = (stream-fd stream)
2165 with file-fd of-type fixnum = (ext:file-stream-fd file-stream)
2166 for len of-type fixnum = (io:vector-read *buffer* file-fd)
2167 do (io:vector-write socket-fd *buffer*)
2168 while (= seqsize len)))
2169#|
2170 (loop
2171 with seq = *buffer*
ecdf3a46
MM
2172 with seqsize of-type fixnum = (array-dimension seq 0)
2173 for len of-type fixnum = (read-sequence seq file-stream)
2174 do (write-sequence seq stream :end len)
2175 while (= seqsize len))
2176 (finish-output stream))
ace88c7a 2177|#
ecdf3a46
MM
2178 (values))
2179
1f844812 2180(defun file-send-ranges (req reply stream file-stream size ranges)
ecdf3a46 2181 (let ((multiple-ranges-p (> (length ranges) 1))
11057264
MM
2182 (boundary-string nil)
2183 (parts '()))
ecdf3a46
MM
2184 (cond (multiple-ranges-p
2185
11057264 2186 (let ((mr-content-length 0)
9856c64a 2187 (mr-reply (make-reply)))
11057264
MM
2188 (setf boundary-string (format nil "~64,'0X" (random
2189 #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
2190
2191 ;; Populate PARTS and set MR-CONTENT-LENGTH.
2192 ;; This allows us to calculate the total reply Content-Length.
9856c64a
MM
2193 (reply-header-unset mr-reply "Server" "Accept-Ranges")
2194 (reply-header-set mr-reply
ef3ef099 2195 (list "Content-Type" "~A; charset=~A"
9856c64a
MM
2196 (reply-mime-type reply)
2197 (symbol-name (reply-charset reply))))
ef3ef099
MM
2198 (loop
2199 with orig-size = size
2200 with crlf = *crlf*
2201 for range in ranges
2202 for (from to) = range
2203 for size = (- (1+ to) from)
2204 for headers = (with-output-to-string (out)
2205 (format out "--~A~A" boundary-string crlf)
9856c64a 2206 (reply-header-set mr-reply
ef3ef099 2207 (list "Content-Range" "bytes ~D-~D/~D"
11057264 2208 from to orig-size))
ef3ef099 2209 (write-string
9856c64a 2210 (reply-headers-string mr-reply) out))
ef3ef099
MM
2211 sum (+ (length headers)
2212 size
2213 2) into content-length of-type fixnum
2214 collect (list from to size headers) into list
2215 finally
2216 (setf mr-content-length (+ content-length 64 7) ; XXX odd
2217 parts list))
11057264
MM
2218
2219 ;; Setup initial REPLY object and flush its headers
9856c64a
MM
2220 (setf (reply-flush-signal reply) nil
2221 (reply-flush-len reply) nil)
2222 (reply-code-set reply 206 "Partial Content")
2223 (reply-header-set reply
ef3ef099
MM
2224 (list "Content-Type" "multipart/byteranges; boundary=~A"
2225 boundary-string)
2226 (list "Content-Length" "~D" mr-content-length))
9856c64a 2227 (reply-flush reply stream)))
ecdf3a46
MM
2228
2229 (t
11057264 2230
ef3ef099 2231 ;; Single range.
11057264 2232 ;; Fill PARTS and adapt and flush existing REPLY headers
9856c64a 2233 (reply-code-set reply 206 "Partial Content")
ecdf3a46 2234 (destructuring-bind (from to) (first ranges)
9856c64a 2235 (reply-header-set reply
ef3ef099 2236 (list "Content-Range" "bytes ~D-~D/~D" from to size))
9856c64a 2237 (reply-flush reply stream (- (1+ to) from))
11057264
MM
2238 (setf parts (list (list from to (- (1+ to) from) nil))))))
2239
9856c64a 2240 (unless (eq :head (request-method req))
ecdf3a46 2241 (loop
ef3ef099 2242 with offset = 0
ecdf3a46 2243 with crlf = *crlf*
11057264
MM
2244 for part in parts
2245 for (from to size headers) = part
ecdf3a46
MM
2246 when (/= offset from) do (progn
2247 (file-position file-stream from)
2248 (setf offset from))
2249 do
2250 (when multiple-ranges-p
11057264 2251 (write-string headers stream))
ace88c7a
MM
2252 ;; XXX Because of fseek(3) it's too risky to directly use
2253 ;; fast IO operations with the file descriptor, unless we
2254 ;; also add support for lseek(2). So let's use standard
2255 ;; functions for now in this rarer case of partial transfers.
ecdf3a46
MM
2256 (loop
2257 with seq = *buffer*
2258 with seqsize of-type fixnum = (array-dimension seq 0)
2259 for len of-type fixnum = (read-sequence
2260 seq file-stream
2261 :end (min seqsize size))
2262 do
2263 (write-sequence seq stream :end len)
2264 (decf size len)
2265 while (and (/= 0 len) (= seqsize len)))
2266 (when multiple-ranges-p
2267 (write-string crlf stream))
2268 (finish-output stream)
2269 finally
2270 (when multiple-ranges-p
2271 (format stream "--~A--~A" boundary-string crlf)
2272 (finish-output stream)))))
2273 (values))
c0aa17ee
MM
2274
2275;;; Actual entry point from SERVER
2276(defun http-serve (connection)
2277 (loop
2278 with config = *config*
2279 with max-size = (config-request-max-size config)
9856c64a
MM
2280 with keepalive of-type boolean = nil
2281 with keepalive-max of-type fixnum = (config-request-keepalive-max
2282 config)
2283 for keepalive-count of-type fixnum from 0 below keepalive-max
c0aa17ee
MM
2284 do
2285 (when (debug-feature :beep)
2286 (beep))
2287 (handler-case
2288 (let* ((stream (connection-stream connection))
2289 (session (connection-session connection)))
2290
9856c64a 2291 (when (= 1 keepalive-count)
c0aa17ee
MM
2292 (setf (connection-input-timeout connection)
2293 (config-request-keepalive-timeout config)))
2294 (multiple-value-bind (status lines)
9856c64a 2295 (request-read stream)
c0aa17ee
MM
2296
2297 (when (eq :no-request status)
9856c64a 2298 (unless keepalive
c0aa17ee 2299 (when (debug-feature :log-errors)
51017907
MM
2300 (log-line "~X ~A No request"
2301 session
2302 (connection-address-string connection))))
c0aa17ee
MM
2303 (return-from http-serve nil))
2304
9856c64a 2305 (let* ((req (request-parse lines stream))
c0aa17ee 2306 (*request* req)
9856c64a
MM
2307 (vhost (request-vhost req))
2308 (path (vhost-path vhost (request-path req))))
c0aa17ee 2309
9856c64a
MM
2310 (unless keepalive
2311 (setf keepalive (request-keepalive req)))
c0aa17ee
MM
2312
2313 (when (debug-feature :log-requests)
2314 (let ((*print-pretty* nil))
51017907
MM
2315 (log-line "~X ~A ~S"
2316 session
2317 (connection-address-string connection)
2318 req)))
c0aa17ee
MM
2319
2320 (cond ((eq :success status))
2321 ((eq :request-size-exceeded status)
2322 (when (debug-feature :log-errors)
51017907
MM
2323 (log-line "~X ~A Query length exceeds ~A bytes"
2324 session
2325 (connection-address-string connection)
2326 max-size))
c0aa17ee
MM
2327 (http-error stream 413 "Request Entity Too Large"
2328 "Query length exceeds ~A bytes."
2329 max-size))
2330 ((eq :request-timeout status)
9856c64a 2331 (unless keepalive
c0aa17ee 2332 (when (debug-feature :log-errors)
51017907
MM
2333 (log-line "~X ~A Request Timeout"
2334 session
2335 (connection-address-string
2336 connection)))
c0aa17ee
MM
2337 (http-error stream 408 "Request Timeout"))
2338 (return-from http-serve nil)))
2339
2340 ;; We could alternatively accept HTTP > 1.1 and behave
2341 ;; like for HTTP 1.1.
2342 ;; XXX Also see RFC 2616 section 3.1 and RFC 2145
2343 ;; about replying with a version Entity.
9856c64a 2344 (let ((protocol (request-protocol req)))
c0aa17ee
MM
2345 (when (or (null protocol)
2346 (>= protocol 2.0))
2347 (when (debug-feature :log-errors)
51017907
MM
2348 (log-line "~X ~A Unsupported protocol version ~A"
2349 session
2350 (connection-address-string connection)
2351 protocol))
c0aa17ee
MM
2352 (http-error stream 505 "Version Not Supported"
2353 "This server supports HTTP versions <= 2.0.")))
9856c64a
MM
2354 (when (and (>= (request-protocol req) 1.1)
2355 (null (request-host req)))
c0aa17ee
MM
2356 (http-error stream 400 "Bad Request"
2357 "HTTP versions >= 1.1 require a Host header."))
2358
a2c1546f
MM
2359 (unless path
2360 (http-error stream 403 "Forbidden"
2361 "You do not have the permission to access that resource."))
2362
de2a1441
MM
2363 (when (and (debug-feature :test)
2364 (string= "/test" (path-virtual path)))
2365 (html-test-page req connection))
2366
2367 ;; First verify for special handlers which take precedence
2368 (let* ((vpath (path-virtual path))
2369 (handler (vhost-handler-query vhost vpath))
2370 (*autoindex-permission* (vhost-autoindex vhost))
2371 (static
2372 (if handler
2373 (destructuring-bind (type parameter) handler
a2c1546f
MM
2374 (when (debug-feature :log-handlers)
2375 (let ((*print-pretty* nil))
2376 (log-line
2377 "~X ~A ~A ~S matches handler ~S"
2378 (connection-session connection)
2379 (connection-address-string
2380 connection)
2381 (vhost-hostname vhost)
2382 vpath handler)))
de2a1441 2383 (do-predicate-case (eq type :static)
e529c610 2384 (:dynamic
9856c64a 2385 (dispatch-dynamic req connection
a2c1546f 2386 parameter))
e529c610 2387 (:embedded
9856c64a
MM
2388 (dispatch-static req connection
2389 path parameter))
e529c610
MM
2390 (:redirect-permanently
2391 (http-redirect stream req parameter nil))
2392 (:redirect-temporarily
2393 (http-redirect stream req parameter t))
2394 (:autoindex
2395 (progn
2396 ;; Local binding only
2397 (setf *autoindex-permission* parameter)
2398 :static))))
de2a1441
MM
2399 :static)))
2400 (when (eq :static static)
a2c1546f 2401 (dispatch-static req connection path nil))))))
c0aa17ee 2402
9856c64a 2403 (signal-reply-no-keepalive ()
c0aa17ee 2404 (loop-finish))
9856c64a 2405 (signal-reply ()
c0aa17ee
MM
2406 t)
2407 (end-of-file ()
9856c64a 2408 (unless keepalive
c0aa17ee 2409 (when (debug-feature :log-errors)
51017907
MM
2410 (log-line "~X ~A End of file"
2411 (connection-session connection)
2412 (connection-address-string connection))))
c0aa17ee 2413 (loop-finish)))
9856c64a 2414 while keepalive)
c0aa17ee
MM
2415 nil)
2416
2417;;; Second entry point from SERVER to handle errors
2418(defun http-overflow (connection reason)
2419 (declare (ignore reason))
2420 (handler-case
2421 (let ((stream (connection-stream connection)))
2422 (http-error stream 403.9 "Too many connections"
2423 "Connection limit exceeded for your address. Try again later."))
9856c64a 2424 (signal-reply ()
c0aa17ee
MM
2425 t))
2426 nil)
2427
2428
2429;;; Initialization and startup
2430
2431(defvar *initialized* nil)
2432
486bec2d 2433;;; Set a minimal default vhost
c0aa17ee 2434(vhost-register (make-vhost :hostname "localhost"
de2a1441
MM
2435 :root nil
2436 :autoindex nil)
2437 :default t)
2438
2439(vhost-handler-register
2440 "localhost"
2441 '(("/"
e529c610 2442 :redirect-temporarily "/test")
de2a1441 2443 ("/index.html"
e529c610 2444 :redirect-temporarily "/test")))
de2a1441 2445
c0aa17ee 2446
486bec2d 2447;;; XXX We should probably remove this for use as a library
c0aa17ee
MM
2448#-:mm-ecl-standalone
2449(eval-when (:load-toplevel :execute)
2450 ;; Not standalone, attempt to load config file in current path
4bcf8ca1
MM
2451 (handler-case
2452 (load "httpd-config.lisp")
2453 (error (e)
2454 (format *error-output* "~%Error loading configuration file~%~A~%"
2455 e))))
c0aa17ee
MM
2456
2457(defun httpd-init ()
486bec2d
MM
2458 "HTTPD-INIT is used to launch Crow-HTTPd.
2459According to the configuration set in *CONFIG*, it binds and listens to the
9856c64a 2460socket(s) and launches the background thread manager and server threads.
486bec2d 2461Also see HTTPD-CLEANUP."
c0aa17ee 2462 (check-type *config* httpd-config)
f1f7c601
MM
2463 (let* ((config *config*)
2464 (server-config (config-server-config config)))
c0aa17ee
MM
2465 (check-type server-config server-config)
2466 (setf *debug* (config-debug config)
2467 (server::config-serve-function server-config) #'http-serve
2468 (server::config-overflow-function server-config) #'http-overflow
2469 (server::config-buffer server-config) 65536
2470 (server::config-log-connections server-config) (debug-feature
2471 :log-connections))
7f0ff025
MM
2472 (with-accessors ((ident server::config-log-syslog-ident)) server-config
2473 (when (string= "ecl-mp-server" ident)
2474 (setf ident "crow-httpd")))
c0aa17ee
MM
2475 (server-init server-config)
2476 (setf *config* config
2477 *initialized* t))
2478 t)
2479
c0aa17ee
MM
2480(defun httpd-cleanup ()
2481 (if *initialized*
2482 (progn
2483 (server-cleanup)
2484 (setf *initialized* nil)
2485 t)
2486 nil))
2487
51017907
MM
2488
2489;;; Initialize implicitely if started in interactive mode
2490
486bec2d 2491;;; XXX We should possibly remove this for use as a library
51017907 2492#-:mm-ecl-standalone
486bec2d 2493(unless (member :crow-application *features* :test #'eq)
544431a9 2494 (defvar *httpd-initialized* (httpd-init)))
51017907
MM
2495
2496
2497;;; Standalone/daemon mode handling
2498
c0aa17ee 2499#+:mm-ecl-standalone
6f477d7a 2500(defun standalone-main-loop ()
51017907
MM
2501 ;; Set the default debug hook to log and exit
2502 (setf *debugger-hook* #'(lambda (condition hook)
2503 (declare (ignore hook))
2504 (server::log-error condition)
2505 (ext:exit -1)))
2506
6f477d7a
MM
2507 (cond ((eq :swank (config-standalone-mode *config*))
2508 ;; Launch Swank
51017907
MM
2509 (push :unix *features*)
2510 (load (config-swank-loader *config*))
2511 (with-input-from-string (s
2512"(swank-loader:init :delete nil
2513 :reload nil
2514 :load-contribs nil)")
2515 (with-log-errors
2516 (eval (read s))))
2517 (with-input-from-string (s (format nil
2518"(let ((swank::*loopback-interface* ~S))
2519 (swank:create-server :dont-close t
2520 :port ~D)))"
2521 (config-swank-address *config*)
2522 (config-swank-port *config*)))
2523 (with-log-errors
2524 (eval (read s)))
2525 (ext:exit)))
6f477d7a
MM
2526 ((eq :repl (config-standalone-mode *config*))
2527 ;; Use ECL's native REPL loop
2528 (si:top-level))
51017907 2529 (t
6f477d7a 2530 ;; Just sleep XXX Ideally detach/fork and bind std FDs to null...
51017907
MM
2531 (with-log-errors
2532 (loop
2533 do
2534 (sleep 60)))
2535 (ext:exit))))
2536
c0aa17ee
MM
2537#+:mm-ecl-standalone
2538(defparameter config-file nil)
51017907 2539
c0aa17ee
MM
2540#+:mm-ecl-standalone
2541(defun standalone-main ()
2542 (let ((ext:*lisp-init-file-list* nil))
2543 (defun help (stream)
6f477d7a
MM
2544 (format stream "~%Usage:~%~A -config <file>~%"
2545 (first ext:*command-args*))
c0aa17ee
MM
2546 (ext:quit 1))
2547
2548 (handler-case
2549 (ext:process-command-args
2550 :rules '(("-config" 1 (setf config-file 1) :noloadrc)
2551 ("*DEFAULT*" 0 (help *standard-output*))))
2552 (error ()
2553 (help *error-output*)))
2554
2555 (unless config-file
2556 (help *error-output*))
2557
2558 (handler-case
af8238cc
MM
2559 (let ((*load-verbose* t))
2560 (load config-file))
4bcf8ca1
MM
2561 (error (e)
2562 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
2563 (ext:quit -1)))
2564 (httpd-init)
6f477d7a 2565 (standalone-main-loop)))
51017907 2566
c0aa17ee
MM
2567#+:mm-ecl-standalone
2568(standalone-main)