Support dynamic-only virtual hosts by supplying NIL for a VHOST's ROOT.
[mmondor.git] / mmsoftware / cl / server / httpd.lisp
CommitLineData
a8904179 1;;;; $Id: httpd.lisp,v 1.28 2012/09/19 19:29:15 mmondor Exp $
c0aa17ee
MM
2
3#|
4
5Copyright (c) 2012, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
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.
c0aa17ee
MM
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...
c0aa17ee
MM
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
a837d3f7 52;;;; - Possibly also generic authentication features (HTTP and form-based)
96d815ab 53;;;; with "captcha" support when a graphics library is supported
c0aa17ee
MM
54;;;; - Form generator with form-instance IDs for matching responses to
55;;;; queries
c0aa17ee
MM
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.
a837d3f7
MM
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.
d1669ed8
MM
70;;;; - Possibly make all use KEEPALIVE or KEEP-ALIVE, we currently use
71;;;; both, which is confusing.
0fd8b8a2
MM
72;;;; - Verify why file transfers are done in 1024 byte blocks rather than
73;;;; 65536 ones. Perhaps the underlaying stdio buffering, if any...
96d815ab 74;;;; If so, verify if we can use setvbuf(3) via Lisp or C.
6f477d7a
MM
75;;;; - Per-path options such as indexing rights, other than only per vhost
76;;;; - Logging format customization
96d815ab
MM
77;;;; - Support standalone option which will use an embedded-compiled
78;;;; configuration file and not allow the executable to load one
a8904179
MM
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.
c0aa17ee
MM
92
93
94(declaim (optimize (speed 3) (safety 1) (debug 3)))
95
4bcf8ca1
MM
96#+:mm-ecl-standalone
97(setf *load-verbose* nil)
98(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
c0aa17ee
MM
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
6f477d7a
MM
108 #:path-valid
109 #:path-valid-virtual
110 #:path-extension
c0aa17ee
MM
111 #:vhost
112 #:make-vhost
113 #:vhost-register
114 #:vhost-unregister
6f477d7a 115 #:vhost-query
c0aa17ee
MM
116 #:vhost-handler-register
117 #:vhost-handler-list
118 #:vhost-handler-unregister
6f477d7a 119 #:vhost-handler-query
c0aa17ee 120 #:mime-register
6f477d7a 121 #:mime-register-list
c0aa17ee
MM
122 #:mime-unregister
123 #:mime-query
124 #:mime-load
125 #:mime-reload
126 #:http-reply
127 #:make-http-reply
6f477d7a 128 #:http-reply-code-set
451d8738
MM
129 #:http-reply-header-set
130 #:http-reply-header-get
131 #:http-reply-header-unset
132 #:http-reply-header-set-nocache
6f477d7a 133 #:http-reply-headers-string
c0aa17ee 134 #:http-reply-content-add
6f477d7a 135 #:http-reply-content-clear
c0aa17ee
MM
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
22b9809f 144 #:with-http-let
451d8738 145 #:range-validate
6f477d7a 146 #:*debug*
c0aa17ee
MM
147 #:debug-feature))
148
149(in-package :httpd)
150
151(defparameter *rcsid*
a8904179 152 "$Id: httpd.lisp,v 1.28 2012/09/19 19:29:15 mmondor Exp $")
c0aa17ee
MM
153
154(defparameter *server-version*
155 (let ((parts (string-split *rcsid*
156 :separators '(#\Space #\,))))
157 (concatenate 'string
6f477d7a
MM
158 "Crow" "/0." (svref parts 3)))
159 "Version string presented in the Server HTTP response header.")
c0aa17ee
MM
160
161
162(defstruct (httpd-config (:conc-name config-))
6f477d7a 163 "Structure used to configure HTTPD."
c0aa17ee
MM
164 (server-config nil :type (or null
165 server:server-config))
166 ;; Supported DEBUG features:
167 ;; :log-requests :log-connections :log-errors :test :beep
6f477d7a 168 (debug '(:log-errors :test) :type list)
c0aa17ee 169
6f477d7a
MM
170 ;; For the standalone-mode swank server (:sleep :swank :repl)
171 (standalone-mode :sleep :type keyword)
51017907
MM
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
c0aa17ee
MM
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
6f477d7a
MM
182(defvar *config* (make-httpd-config :server-config (make-server-config))
183 "HTTP server configuration.")
c0aa17ee
MM
184
185
186;;; Paths
187
c0aa17ee 188(defun path-valid (path)
6f477d7a
MM
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 '/'."
ba6d650d
MM
193 (let ((path-max 255)
194 (out (make-array (1+ (length path))
c0aa17ee
MM
195 :element-type 'character
196 :fill-pointer 0)))
ba6d650d 197 (declare (type fixnum path-max))
7f0ff025
MM
198 (flet ((add-char (c)
199 (vector-push c out)))
200 (declare (inline add-char))
c0aa17ee
MM
201 (add-char #\/)
202 (if
203 (loop
c0aa17ee
MM
204 with last of-type character = #\/
205 for c of-type character across path
206 do
ba6d650d
MM
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))
c0aa17ee 219 finally (return out))
ba6d650d 220 (if (> (length out) path-max)
c0aa17ee
MM
221 nil
222 out)
223 nil))))
224
225(defstruct path
6f477d7a 226 "Path object returned from PATH-VALID-VIRTUAL."
c0aa17ee
MM
227 real virtual)
228
c0aa17ee 229(defun path-valid-virtual (root path)
6f477d7a
MM
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
a8904179
MM
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."
c0aa17ee 242 (let* ((virtual (path-valid (concatenate 'string "/" path)))
a8904179
MM
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)))
c0aa17ee
MM
250 (make-path :real real
251 :virtual virtual)
252 nil)))
253
254(defun path-extension (path)
6f477d7a 255 "Given PATH, returns the file extension in lowercase, if any, or NIL."
c0aa17ee
MM
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
6f477d7a
MM
266(defvar *vhost-default* nil
267 "The current default virtual host (a VHOST object).")
c0aa17ee
MM
268
269(defstruct vhost
6f477d7a 270 "Structure to configure/describe a virtual host."
c0aa17ee 271 (hostname "" :type string :read-only t)
a8904179
MM
272 ;; If ROOT is NIL this VHOST only supports dynamic handlers, no files.
273 (root nil :type (or null string))
c0aa17ee
MM
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))
6f477d7a
MM
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."
c0aa17ee
MM
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
a8904179
MM
294 (when root
295 (unless (path-valid root)
296 (error "Invalid root path \"~A\"" root)))
c0aa17ee
MM
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)))))
6f477d7a 308 (values))
c0aa17ee
MM
309
310(defun vhost-unregister (name)
6f477d7a
MM
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))
c0aa17ee
MM
325
326(defun vhost-query (name &key (default nil))
6f477d7a
MM
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."
c0aa17ee
MM
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
a8904179 342(declaim (inline vhost-path))
c0aa17ee 343(defun vhost-path (vhost path)
6f477d7a 344 "Validates user-supplied PATH for VHOST, and returns a PATH object if
a8904179 345valid, or NIL. See PATH-VALID-VIRTUAL for more details."
c0aa17ee
MM
346 (path-valid-virtual (vhost-root vhost) path))
347
348;;; VHost dynamic handlers
349(defun vhost-handler-register (vhost-name handlers)
6f477d7a
MM
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."
c0aa17ee
MM
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)))
6f477d7a 365 (values))
c0aa17ee
MM
366
367(defun vhost-handler-list (vhost-name)
6f477d7a
MM
368 "Finds the VHOST object matching VHOST-NAME, and returns a list of
369previously registered handlers for that virtual host."
c0aa17ee
MM
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)
6f477d7a
MM
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."
c0aa17ee
MM
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)))))
6f477d7a
MM
392 handlers))))
393 (values))
c0aa17ee 394
f6526a2e 395(declaim (inline vhost-handler-query))
c0aa17ee 396(defun vhost-handler-query (vhost vpath)
6f477d7a
MM
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."
c0aa17ee
MM
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)
6f477d7a
MM
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."
c0aa17ee
MM
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)
6f477d7a
MM
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."
c0aa17ee
MM
429 (mapc #'(lambda (type)
430 (destructuring-bind (mimetype extensions) type
431 (mime-register mimetype extensions)))
432 types)
6f477d7a 433 (values))
c0aa17ee
MM
434
435(defun mime-unregister (extension)
6f477d7a
MM
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))
c0aa17ee 451
f6526a2e 452(declaim (inline mime-query))
c0aa17ee 453(defun mime-query (extension &optional (default "application/octet-stream"))
6f477d7a
MM
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\"."
c0aa17ee
MM
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)
6f477d7a
MM
465 "Loads a mime-types database list from FILE. Remembers the location of
466FILE for MIME-RELOAD."
c0aa17ee
MM
467 (load file)
468 (setf *mime-type-file* file)
469 (mime-register-list *mime-types*))
470
471(defun mime-reload ()
6f477d7a
MM
472 "Reloads the mime-types database list from file, which was remembered
473from a previous call to MIME-LOAD."
c0aa17ee
MM
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
6f477d7a
MM
481(defvar *request* nil
482 "Dynamically bound to the current HTTP-REQUEST object.")
c0aa17ee
MM
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
451d8738 494(defstruct (http-reply (:constructor %make-http-reply))
6f477d7a
MM
495 "Object used to prepare an HTTP reply.
496MAKE-HTTP-REPLY uses *REQUEST*, if bound, to supply some default values."
451d8738
MM
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)
6f477d7a
MM
511 "HTTP-REPLY constructor. Uses *REQUEST*, if bound, to supply some default
512values."
451d8738
MM
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
f6526a2e
MM
530(declaim (inline http-reply-code-set))
531(defun http-reply-code-set (reply code description)
6f477d7a
MM
532 "Applies the supplied HTTP CODE (real) and related DESCRIPTION (string)
533to the specified HTTP-REPLY object REPLY."
f6526a2e
MM
534 (setf (http-reply-code reply) code
535 (http-reply-description reply) description)
536 (values))
537
451d8738 538(defun http-reply-header-set (reply &rest pairs)
6f477d7a
MM
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."
451d8738
MM
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)
6f477d7a
MM
558 "Returns the value associated with the HTTP header KEY string for REPLY,
559or NIL if it is unbound."
451d8738
MM
560 (assoc key (http-reply-headers reply) :test #'string-equal))
561
0fd8b8a2 562(defun http-reply-header-unset (reply &rest keys)
6f477d7a 563 "Unset/unbind each HTTP header of REPLY specified in KEYS strings."
451d8738 564 (with-accessors ((headers http-reply-headers)) reply
0fd8b8a2
MM
565 (loop
566 for key in keys
567 for match = (assoc key headers :test #'string-equal)
568 when match do (rplacd match nil)))
451d8738
MM
569 (values))
570
f6526a2e 571(declaim (inline http-reply-header-set-nocache))
451d8738 572(defun http-reply-header-set-nocache (reply)
6f477d7a
MM
573 "Adds the needed headers to REPLY to tell the client not to cache these
574results."
451d8738
MM
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)
6f477d7a 587 "Returns a formatted STRING for the existing HTTP headers of REPLY."
451d8738
MM
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))))
c0aa17ee 599
f6526a2e 600(declaim (inline http-reply-content-add))
c0aa17ee 601(defun http-reply-content-add (reply content)
6f477d7a 602 "Appends CONTENT string to REPLY, to be flushed with HTTP-REPLY-FLUSH."
c0aa17ee
MM
603 (push content (http-reply-content reply)))
604
6f477d7a
MM
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
f6526a2e 610(declaim (inline http-reply-log-time))
c0aa17ee 611(defun http-reply-log-time (&optional (ut (server-time)))
6f477d7a
MM
612 "Returns an HTTP-log friendly timestamp for UT (a universal-time which
613defaults to the current time)."
c0aa17ee
MM
614 (let ((months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
615 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
7f0ff025 616 (declare (type (simple-array string (12)) months))
c0aa17ee
MM
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
c0aa17ee 624(defun http-reply-flush (reply stream &optional (size nil))
6f477d7a
MM
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."
c0aa17ee
MM
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
451d8738 654 finally (return len)))))
c0aa17ee
MM
655
656 (when request
657 (let ((connection *connection*))
658 (when (http-reply-no-keepalive reply)
d1669ed8 659 (http-request-disable-keepalive request))
c0aa17ee
MM
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)))))
451d8738
MM
665 (when (and (config-request-log config)
666 (http-reply-flush-log reply))
c0aa17ee
MM
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
451d8738
MM
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)))))
c0aa17ee
MM
690 (if (and request
691 (http-request-keep-alive request))
692 (when (= 1.0 (http-request-protocol request))
451d8738
MM
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)))
c0aa17ee
MM
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))
451d8738
MM
713 (when (and (http-reply-flush-signal reply)
714 (or (null size) (zerop size)))
a837d3f7
MM
715 (error (if (http-reply-no-keepalive reply)
716 'http-reply-signal-no-keepalive
717 'http-reply-signal)))
c0aa17ee
MM
718 t)
719
6f477d7a
MM
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."
72740378
MM
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))
c0aa17ee
MM
730
731(defun http-error (stream code message &optional fmt &rest fmt-args)
6f477d7a
MM
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."
c0aa17ee
MM
738 (let ((reply (make-http-reply :code code
739 :description message
740 :no-keepalive t))
741 (description (if fmt
451d8738
MM
742 (if fmt-args
743 (apply #'format nil fmt fmt-args)
744 nil)
c0aa17ee 745 nil)))
451d8738 746 (http-reply-header-set-nocache reply)
c0aa17ee
MM
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
6f477d7a 759;;; Special case of HTTP-ERROR which also sets the Allow header.
c0aa17ee
MM
760(defun http-error-unimplemented (stream)
761 (let ((reply (make-http-reply :code 501
762 :description "Method Not Implemented"
763 :no-keepalive t)))
451d8738
MM
764 (http-reply-header-set-nocache reply)
765 (http-reply-header-set reply '("Allow" "GET, HEAD, POST"))
c0aa17ee
MM
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)
6f477d7a
MM
777 "Utility function to redirect the client to another resource, VPATH.
778The reply will be made to STREAM for the HTTP-REQUEST object REQ."
c0aa17ee
MM
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"
a837d3f7 790 "You do not have the permission to access this resource."))
451d8738
MM
791 (http-reply-header-set-nocache reply)
792 (http-reply-header-set reply (list "Location" "~A" movedto))
c0aa17ee
MM
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
6f477d7a 806
f6526a2e 807(declaim (inline http-index-time))
c0aa17ee
MM
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")))
6f477d7a 811 (declare (type (simple-array string (12)) months))
c0aa17ee
MM
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
f6526a2e 819(declaim (inline http-index-size))
c0aa17ee
MM
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)))
a837d3f7
MM
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)
c0aa17ee
MM
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
c0aa17ee 902(defun url-decode (string)
6f477d7a
MM
903 "Decodes the client-supplied URL supplied in STRING to another string,
904returning it. Attempts to be resilient to bad input."
7f0ff025 905 (declare (optimize (speed 3) (safety 0) (debug 0)))
c0aa17ee
MM
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)
ba6d650d
MM
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))))
c0aa17ee
MM
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)
7f0ff025
MM
924 with byte-string = (make-string 2)
925
c0aa17ee 926 for o of-type (unsigned-byte 8) = (get-octet)
7f0ff025
MM
927
928 ;; Below, (map 'string #'identity `(,c1 ,c2)) is slower
c0aa17ee
MM
929 when (= 37 o) do (let ((c1 (code-char (get-octet)))
930 (c2 (code-char (get-octet))))
ba6d650d
MM
931 ;; Below is faster than DIGIT-CHAR-P
932 (when (and (hex-digit-p c1)
933 (hex-digit-p c2))
7f0ff025
MM
934 (setf (char byte-string 0) c1
935 (char byte-string 1) c2)
936 (put-octet (parse-integer byte-string
937 :radix 16))))
c0aa17ee
MM
938 else when (= 43 o) do (put-octet 32)
939 else do (put-octet o)
7f0ff025 940
c0aa17ee
MM
941 finally (return (utf-8-string-decode output)))))
942
ba6d650d 943;;; Written in a way to be very efficient for ECL.
7f0ff025 944(defun url-encode (string)
6f477d7a
MM
945 "Encodes the supplied URL in STRING to a proper URL, returning that new
946string."
7f0ff025
MM
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.
ba6d650d
MM
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))
7f0ff025
MM
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
c0aa17ee
MM
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.
7f0ff025
MM
983;;; XXX It appears that using a [] suffix is a PHP convention, and that we
984;;; could use another indicator, such as a # prefix.
c0aa17ee 985(defun property-set (ht str)
ba6d650d 986 (declare (optimize (speed 3) (safety 0) (debug 0)))
c0aa17ee
MM
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)
ba6d650d
MM
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)))
c0aa17ee
MM
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)
ba6d650d
MM
1012 (char= #\] (char var (- len 1)))
1013 (char= #\[ (char var (- len 2))))
c0aa17ee
MM
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
ba6d650d 1030
f6526a2e 1031(declaim (inline http-get-parse))
c0aa17ee
MM
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.
451d8738 1091;;; Extracts query from the first request line and coalesces continuing
c0aa17ee
MM
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
6f477d7a 1121 "Control data for a received and parsed client/user HTTP request."
c0aa17ee
MM
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
f6526a2e 1142(declaim (inline http-request-disable-keepalive))
c0aa17ee
MM
1143(defun http-request-disable-keepalive (request)
1144 (setf (http-request-keep-alive request) nil))
1145
451d8738
MM
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
c0aa17ee
MM
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.
f6526a2e 1263;;; XXX Try to convert in a way not to need a funcall per header
c0aa17ee
MM
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)
451d8738 1303 (setf (http-request-range o) (range-parse v))))
c0aa17ee
MM
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
451d8738 1316
c0aa17ee
MM
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.
f6526a2e 1374(declaim (inline method-keyword))
c0aa17ee
MM
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
f6526a2e 1386(declaim (inline parse-float))
c0aa17ee
MM
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.
f6526a2e 1407(declaim (inline version-parse))
c0aa17ee
MM
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)
451d8738
MM
1461 when fun do (ignore-errors ; Extra parsing carefulness
1462 (funcall fun req val))))
c0aa17ee
MM
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
38e2dc27
MM
1482;;; HTTP variable access for user code
1483
c0aa17ee
MM
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."
38e2dc27 1489 (let ((ht (cond ((eq :get type) ; CASE might not use EQ
c0aa17ee
MM
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
6f477d7a
MM
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.")
c0aa17ee 1538
f6526a2e 1539(declaim (inline debug-feature))
c0aa17ee 1540(defun debug-feature (keyword)
6f477d7a 1541 "Returs T if debug feature KEYWORD is enabled, or NIL."
c0aa17ee
MM
1542 (let ((debug *debug*))
1543 (and debug (position keyword debug :test #'eq))))
1544
1545(defun beep ()
451d8738
MM
1546 (ignore-errors
1547 (with-open-file (s "/dev/speaker" :direction :output)
1548 (write-string "O1L15D" s))))
c0aa17ee
MM
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
9fd068a8
MM
1561 (:html (:head (:title "Interactively developed test server")
1562 (:/link :rel "stylesheet"
1563 :href "/css/test.css"
1564 :type "text/css"))
c0aa17ee
MM
1565 (:body
1566 (:h1 "Interactively developed test server")
1567 (:p "This page, forms and server code may change anytime "
38e2dc27
MM
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 "
451d8738 1573 "modified code blocks reapplied in the live image. "
9fd068a8 1574 "These code blocks may be reapplied as compiled bytecode "
38e2dc27 1575 "for interpretation (or in this case, using ECL, be "
451d8738
MM
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).")
c0aa17ee
MM
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
c0aa17ee
MM
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)
38e2dc27
MM
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."))
c0aa17ee
MM
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
38e2dc27 1651 "File description")))
c0aa17ee
MM
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"
38e2dc27
MM
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")
c0aa17ee
MM
1667 (:pre
1668 (do-html-loop (for line in (http-request-raw req))
1669 (html-escape (format nil "~A~%" line))))
38e2dc27
MM
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)))))
c0aa17ee 1677 (do-html-when (http-request-query req)
38e2dc27 1678 (:h3 "GET variables")
c0aa17ee
MM
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)
38e2dc27 1685 (:h3 "POST variables")
c0aa17ee
MM
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)
38e2dc27 1694 (:h3 "COOKIE variables")
c0aa17ee
MM
1695 (:pre
1696 (html-escape (dump-vars
1697 (http-request-vars-cookie req)))))
38e2dc27 1698
c0aa17ee
MM
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
ba6d650d 1722;;; XXX See about replacing the MEMBER function to expand inline
c0aa17ee
MM
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
a837d3f7
MM
1752 (handler-case
1753 (funcall fun req connection)
86e09a66 1754 ((not (or http-reply-signal http-reply-signal-no-keepalive)) (c)
e45c0358 1755 (log-error c)
a837d3f7
MM
1756 (http-error (connection-stream connection) 500 "Internal Error"
1757 "A temporary internal error has occurred.")))
c0aa17ee
MM
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
a837d3f7
MM
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))))
c0aa17ee
MM
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))
f6526a2e 1839 (http-reply-code-set reply 304 "Not Modified")
c0aa17ee
MM
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))
f6526a2e 1844 (http-reply-code-set reply 412 "Precondition Failed")
c0aa17ee
MM
1845 (http-reply-flush reply stream 0)))
1846
c0aa17ee 1847 ;; Finally send file (except for HEAD)
451d8738
MM
1848 (http-reply-header-set reply (list "Last-Modified" "~A" lastmod))
1849
a837d3f7
MM
1850 (handler-case
1851 (progn
ecdf3a46
MM
1852 (with-open-file (file-stream truepath
1853 :direction :input
1854 :element-type '(unsigned-byte 8))
1855 (let* ((size (file-length file-stream))
451d8738
MM
1856 (ranges (range-validate req size)))
1857 (when (eq :not-satisfiable ranges)
1858 (http-error stream 416
1859 "Requested Range Not Satisfiable"))
ecdf3a46 1860 (if ranges
1f844812
MM
1861 (file-send-ranges req reply stream file-stream size
1862 ranges)
1863 (file-send-full req reply stream file-stream size)))))
a837d3f7
MM
1864 (file-error ()
1865 (http-error stream 403 "Forbidden"
451d8738
MM
1866 "You do not have the permission to access \"~A\"."
1867 (path-virtual path)))))))
1868 (values))
1869
f6526a2e 1870(declaim (inline file-send-full))
1f844812 1871(defun file-send-full (req reply stream file-stream size)
ecdf3a46
MM
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
1f844812 1883(defun file-send-ranges (req reply stream file-stream size ranges)
ecdf3a46 1884 (let ((multiple-ranges-p (> (length ranges) 1))
11057264
MM
1885 (boundary-string nil)
1886 (parts '()))
ecdf3a46
MM
1887 (cond (multiple-ranges-p
1888
11057264
MM
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
ef3ef099
MM
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"
11057264 1911 from to orig-size))
ef3ef099
MM
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))
11057264
MM
1921
1922 ;; Setup initial REPLY object and flush its headers
1923 (setf (http-reply-flush-signal reply) nil
f6526a2e
MM
1924 (http-reply-flush-len reply) nil)
1925 (http-reply-code-set reply 206 "Partial Content")
11057264 1926 (http-reply-header-set reply
ef3ef099
MM
1927 (list "Content-Type" "multipart/byteranges; boundary=~A"
1928 boundary-string)
1929 (list "Content-Length" "~D" mr-content-length))
11057264 1930 (http-reply-flush reply stream)))
ecdf3a46
MM
1931
1932 (t
11057264 1933
ef3ef099 1934 ;; Single range.
11057264 1935 ;; Fill PARTS and adapt and flush existing REPLY headers
f6526a2e 1936 (http-reply-code-set reply 206 "Partial Content")
ecdf3a46
MM
1937 (destructuring-bind (from to) (first ranges)
1938 (http-reply-header-set reply
ef3ef099 1939 (list "Content-Range" "bytes ~D-~D/~D" from to size))
11057264
MM
1940 (http-reply-flush reply stream (- (1+ to) from))
1941 (setf parts (list (list from to (- (1+ to) from) nil))))))
1942
ecdf3a46
MM
1943 (unless (eq :head (http-request-method req))
1944 (loop
ef3ef099 1945 with offset = 0
ecdf3a46 1946 with crlf = *crlf*
11057264
MM
1947 for part in parts
1948 for (from to size headers) = part
ecdf3a46
MM
1949 when (/= offset from) do (progn
1950 (file-position file-stream from)
1951 (setf offset from))
1952 do
1953 (when multiple-ranges-p
11057264 1954 (write-string headers stream))
ecdf3a46
MM
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))
c0aa17ee
MM
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)
51017907
MM
1999 (log-line "~X ~A No request"
2000 session
2001 (connection-address-string connection))))
c0aa17ee
MM
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))
51017907
MM
2014 (log-line "~X ~A ~S"
2015 session
2016 (connection-address-string connection)
2017 req)))
c0aa17ee
MM
2018
2019 (cond ((eq :success status))
2020 ((eq :request-size-exceeded status)
2021 (when (debug-feature :log-errors)
51017907
MM
2022 (log-line "~X ~A Query length exceeds ~A bytes"
2023 session
2024 (connection-address-string connection)
2025 max-size))
c0aa17ee
MM
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)
51017907
MM
2032 (log-line "~X ~A Request Timeout"
2033 session
2034 (connection-address-string
2035 connection)))
c0aa17ee
MM
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)
51017907
MM
2047 (log-line "~X ~A Unsupported protocol version ~A"
2048 session
2049 (connection-address-string connection)
2050 protocol))
c0aa17ee
MM
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)
a8904179
MM
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)))))))
c0aa17ee
MM
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)
51017907
MM
2073 (log-line "~X ~A End of file"
2074 (connection-session connection)
2075 (connection-address-string connection))))
c0aa17ee
MM
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
4bcf8ca1
MM
2104 (handler-case
2105 (load "httpd-config.lisp")
2106 (error (e)
2107 (format *error-output* "~%Error loading configuration file~%~A~%"
2108 e))))
c0aa17ee
MM
2109
2110(defun httpd-init ()
2111 (check-type *config* httpd-config)
f1f7c601
MM
2112 (let* ((config *config*)
2113 (server-config (config-server-config config)))
c0aa17ee
MM
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))
7f0ff025
MM
2121 (with-accessors ((ident server::config-log-syslog-ident)) server-config
2122 (when (string= "ecl-mp-server" ident)
2123 (setf ident "crow-httpd")))
c0aa17ee
MM
2124 (server-init server-config)
2125 (setf *config* config
2126 *initialized* t))
2127 t)
2128
c0aa17ee
MM
2129(defun httpd-cleanup ()
2130 (if *initialized*
2131 (progn
2132 (server-cleanup)
2133 (setf *initialized* nil)
2134 t)
2135 nil))
2136
51017907
MM
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
c0aa17ee 2146#+:mm-ecl-standalone
6f477d7a 2147(defun standalone-main-loop ()
51017907
MM
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
6f477d7a
MM
2154 (cond ((eq :swank (config-standalone-mode *config*))
2155 ;; Launch Swank
51017907
MM
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)))
6f477d7a
MM
2173 ((eq :repl (config-standalone-mode *config*))
2174 ;; Use ECL's native REPL loop
2175 (si:top-level))
51017907 2176 (t
6f477d7a 2177 ;; Just sleep XXX Ideally detach/fork and bind std FDs to null...
51017907
MM
2178 (with-log-errors
2179 (loop
2180 do
2181 (sleep 60)))
2182 (ext:exit))))
2183
c0aa17ee
MM
2184#+:mm-ecl-standalone
2185(defparameter config-file nil)
51017907 2186
c0aa17ee
MM
2187#+:mm-ecl-standalone
2188(defun standalone-main ()
2189 (let ((ext:*lisp-init-file-list* nil))
2190 (defun help (stream)
6f477d7a
MM
2191 (format stream "~%Usage:~%~A -config <file>~%"
2192 (first ext:*command-args*))
c0aa17ee
MM
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
af8238cc
MM
2206 (let ((*load-verbose* t))
2207 (load config-file))
4bcf8ca1
MM
2208 (error (e)
2209 (format *error-output* "~%Error loading configuration file~%~A~%" e)
c0aa17ee
MM
2210 (ext:quit -1)))
2211 (httpd-init)
6f477d7a 2212 (standalone-main-loop)))
51017907 2213
c0aa17ee
MM
2214#+:mm-ecl-standalone
2215(standalone-main)