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