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