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