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