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