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