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