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