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