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