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