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