├── .gitignore ├── LICENSE ├── README ├── api.lisp ├── api.txt ├── conditions.lisp ├── cookie.lisp ├── docs.txt ├── documentation.lisp ├── http.lisp ├── log.lisp ├── mime-types.lisp ├── notes.txt ├── packages.lisp ├── rfc2388.lisp ├── set-timeouts.lisp ├── specials.lisp ├── taskmaster.lisp ├── tests.lisp ├── toot.asd ├── util.lisp └── www ├── favicon.ico ├── img └── made-with-lisp-logo.jpg ├── index.html └── testforms.html /.gitignore: -------------------------------------------------------------------------------- 1 | *.*f*sl 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Redistribution and use in source and binary forms, with or without 2 | modification, are permitted provided that the following conditions are 3 | met: 4 | 5 | * Redistributions of source code must retain the above copyright 6 | notice, this list of conditions and the following disclaimer. 7 | 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in 10 | the documentation and/or other materials provided with the 11 | distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED OR 14 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, 17 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 20 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 21 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 22 | IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Toot is a stripped down and, hopefully, simplified version of Edi 2 | Weitz's Hunchentoot. It does not aim to be backwards compatible with 3 | anything and large swaths of Hunchentoot functionality have been cut 4 | out. Some of them may be put back someday. Use at your own risk. If it 5 | breaks you get to keep both pieces, etc. etc. -------------------------------------------------------------------------------- /api.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; Start and stop the server 32 | 33 | (defun start-server (&rest args &key (handler (error "Must specify handler.")) port &allow-other-keys) 34 | "Instantiate an acceptor and start it listening." 35 | (start-acceptor 36 | (apply #'make-instance 'acceptor 37 | :handler handler 38 | :port port 39 | (sans args :handler :port)))) 40 | 41 | (defun start-acceptor (acceptor) 42 | "Start an existing acceptor listening for connections." 43 | (when (listen-socket acceptor) 44 | (internal-error "acceptor ~A is already listening" acceptor)) 45 | 46 | (setf (shutdown-p acceptor) nil) 47 | (setf (listen-socket acceptor) 48 | (usocket:socket-listen 49 | (or (address acceptor) usocket:*wildcard-host*) (port acceptor) 50 | :reuseaddress t 51 | :backlog (listen-backlog acceptor) 52 | :element-type '(unsigned-byte 8))) 53 | ;; Reset the port in case we passed 0 to get a random port. 54 | (setf (slot-value acceptor 'port) (usocket:get-local-port (listen-socket acceptor))) 55 | (execute-acceptor (taskmaster acceptor) acceptor) 56 | acceptor) 57 | 58 | (defun stop-acceptor (acceptor &key soft) 59 | "Stop an acceptor from listening for connections. It can be 60 | restarted with START-ACCEPTOR." 61 | (setf (shutdown-p acceptor) t) 62 | (shutdown (taskmaster acceptor)) 63 | (when soft 64 | (with-lock-held ((shutdown-lock acceptor)) 65 | ;; FIXME: seems like this should perhaps be a while loop not a 66 | ;; WHEN? The thread which called STOP is waiting here while all 67 | ;; the threads processing requests will signal on the 68 | ;; shutdown-queue 69 | (when (plusp (requests-in-progress acceptor)) 70 | (condition-wait (shutdown-queue acceptor) (shutdown-lock acceptor))))) 71 | (usocket:socket-close (listen-socket acceptor)) 72 | (setf (listen-socket acceptor) nil) 73 | acceptor) 74 | 75 | (defun request-scheme (request) 76 | "Get the scheme part of the request's URI." 77 | (uri-scheme (request-uri request))) 78 | 79 | (defun request-host (request) 80 | "Get the host part of the request's URI." 81 | (uri-host (request-uri request))) 82 | 83 | (defun request-port (request) 84 | "Get the port part of the request's URI." 85 | (uri-port (request-uri request))) 86 | 87 | (defun request-path (request) 88 | "Get the path part of the request's URI." 89 | (uri-path (request-uri request))) 90 | 91 | (defun request-query (request) 92 | "Get the query part of the request's URI." 93 | (uri-query (request-uri request))) 94 | 95 | (defun request-authority (request) 96 | "Get the authority part of the request's URI." 97 | (uri-authority (request-uri request))) 98 | 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | ;;; Public API 101 | 102 | (defmacro with-response-body ((stream request &rest headers &key &allow-other-keys) &body body) 103 | "Send the response headers (any already set plus any more set via 104 | keyword arguments to this macro) and bind the stream to which the 105 | response body can be written to STREAM." 106 | (once-only (request) 107 | `(progn 108 | ;; When headers is NIL SBCL whines about unreachable code if we 109 | ;; generate the LOOP 110 | ,@(when headers 111 | `((loop for (name value) on (list ,@headers) by #'cddr do 112 | (setf (response-header name ,request) value)))) 113 | (let ((,stream (send-headers ,request))) ,@body) 114 | t))) 115 | 116 | (defun response-header (name request) 117 | "Returns the current value of the outgoing http header named NAME. 118 | NAME should be a keyword or a string." 119 | (cdr (assoc name (response-headers request)))) 120 | 121 | (defun (setf response-header) (new-value name request) 122 | "Changes the current value of the outgoing http header named NAME (a 123 | keyword or a string). If a header with this name doesn't exist, it is 124 | created." 125 | (when (headers-sent-p request) 126 | (error "Can't set reply headers after headers have been sent.")) 127 | 128 | (when (stringp name) 129 | (setf name (as-keyword name :destructivep nil))) 130 | 131 | (let ((entry (assoc name (response-headers request)))) 132 | (if entry 133 | (setf (cdr entry) new-value) 134 | (push (cons name new-value) (response-headers request))) 135 | 136 | ;; Special case these two. This is kind of hinky, but we need to 137 | ;; set the slots if these headers are set since the slot values 138 | ;; will be used in finalize-response-headers to set the actual 139 | ;; header. Note that this relation is not directly symmetical. 140 | ;; Setting the slot in the object does not immediately set the 141 | ;; value in the headers alist. But it will eventually affect it in 142 | ;; finalize-response-headers. 143 | (case name 144 | (:content-length 145 | (check-type new-value integer) 146 | (setf (content-length request) new-value)) 147 | (:content-type 148 | (check-type new-value (or null string)) 149 | (setf (content-type request) new-value))) 150 | 151 | new-value)) 152 | 153 | (defun response-sent-p (request) 154 | "Has a response been sent." 155 | (headers-sent-p request)) 156 | 157 | (defun send-headers (request &key 158 | (content-type *default-content-type*) 159 | (charset *default-charset*) 160 | (status-code +http-ok+)) 161 | "Send the headers and return a stream to which the body of the reply 162 | can be written. If the content-type is text/* type, the stream 163 | returned will be a character stream that will encode the response 164 | properly for the charset specified. If the request was a HEAD request 165 | we dynamically abort rather than returning a stream." 166 | (setf (status-code request) status-code) 167 | (let ((stream (send-response-headers request nil content-type charset))) 168 | (if (text-type-p content-type) 169 | (make-flexi-stream stream :external-format (make-external-format charset)) 170 | stream))) 171 | 172 | (defun abort-request-handler (response-status-code &optional body) 173 | "Abort the handling of a request, sending instead a response with 174 | the given response-status-code and either the given body or a default 175 | body based on the error code. A request can only be aborted if 176 | SEND-HEADERS has not been called. (SEND-HEADERS is called by 177 | WITH-RESPONSE-BODY). If a handler neither generates a response nor 178 | aborts, then a 404: Not Found response will be sent." 179 | (error 'request-aborted :response-status-code response-status-code :body body)) 180 | 181 | (defun request-header (name request) 182 | "Returns the incoming header with name NAME. NAME can be a 183 | keyword (recommended) or a string." 184 | (cdr (assoc name (request-headers request) :test #'equalp))) 185 | 186 | (defun authorization (request) 187 | "Returns as two values the user and password (if any) as encoded in 188 | the 'AUTHORIZATION' header. Returns NIL if there is no such header." 189 | (let* ((authorization (request-header :authorization request)) 190 | (start (and authorization 191 | (> (length authorization) 5) 192 | (string-equal "Basic" authorization :end2 5) 193 | (scan "\\S" authorization :start 5)))) 194 | (when start 195 | (destructuring-bind (&optional user password) 196 | (split ":" (base64:base64-string-to-string (subseq authorization start))) 197 | (values user password))))) 198 | 199 | (defun get-parameter (name request) 200 | "Returns the GET parameter with name NAME (a string) - or NIL if 201 | there is none. Search is case-sensitive." 202 | (cdr (assoc name (get-parameters request) :test #'string=))) 203 | 204 | (defun post-parameter (name request) 205 | "Returns the POST parameter with name NAME (a string) - or NIL if 206 | there is none. Search is case-sensitive." 207 | (cdr (assoc name (post-parameters request) :test #'string=))) 208 | 209 | (defun parameter (name request) 210 | "Returns the GET or the POST parameter with name NAME (a string) - 211 | or NIL if there is none. If both a GET and a POST parameter with the 212 | same name exist the GET parameter is returned. Search is 213 | case-sensitive." 214 | (or (get-parameter name request) (post-parameter name request))) 215 | 216 | (defun real-remote-addr (request) 217 | "Returns the 'X-Forwarded-For' incoming http header as the 218 | second value in the form of a list of IP addresses and the first 219 | element of this list as the first value if this header exists. 220 | Otherwise returns the value of REMOTE-ADDR as the only value." 221 | (let ((x-forwarded-for (request-header :x-forwarded-for request))) 222 | (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for))) 223 | (values (first addresses) addresses))) 224 | (t (remote-addr request))))) 225 | 226 | (defun serve-file (request pathname &optional content-type (charset *default-charset*)) 227 | "Serve the file denoted by PATHNAME. Sends a content type header 228 | corresponding to CONTENT-TYPE or (if that is NIL) tries to determine 229 | the content type via the file's suffix. Aborts the request with 404: 230 | Not found if the file does not exist. Also handles if-modified-since 231 | and range requests appropriately." 232 | (when (or (not pathname) 233 | (wild-pathname-p pathname) 234 | (not (fad:file-exists-p pathname)) 235 | (fad:directory-exists-p pathname)) 236 | (abort-request-handler +http-not-found+)) 237 | 238 | (let ((time (or (file-write-date pathname) (get-universal-time)))) 239 | (setf (response-header :accept-ranges request) "bytes") 240 | (handle-if-modified-since time request) 241 | 242 | (with-open-file (file pathname :direction :input :element-type 'octet :if-does-not-exist nil) 243 | (multiple-value-bind (start bytes-to-send) (handle-range request (file-length file)) 244 | (when (plusp start) (file-position file start)) 245 | (setf (status-code request) +http-ok+) 246 | (let* ((type (or content-type (guess-mime-type (pathname-type pathname)))) 247 | (out (send-response-headers request bytes-to-send type charset)) 248 | (buf (make-array +buffer-length+ :element-type 'octet))) 249 | ;; FIXME: is this necessary? We shouldn't have a 250 | ;; flexi-stream at this point. In fact, this should probably 251 | ;; blow up because of that. 252 | #+:clisp 253 | (setf (flexi-stream-element-type (content-stream (acceptor request))) 'octet) 254 | (loop until (zerop bytes-to-send) do 255 | (let ((chunk-size (min +buffer-length+ bytes-to-send))) 256 | (unless (eql chunk-size (read-sequence buf file :end chunk-size)) 257 | (error "can't read from input file")) 258 | (write-sequence buf out :end chunk-size) 259 | (decf bytes-to-send chunk-size))) 260 | (finish-output out)))))) 261 | 262 | (defun no-cache (request) 263 | "Adds appropriate response headers to completely prevent caching on 264 | most browsers." 265 | ;; WTF is this date?! (Some cargo cult thing from PHP or maybe MSDN, it seems.) 266 | (setf (response-header :expires request) "Mon, 26 Jul 1997 05:00:00 GMT") 267 | (setf (response-header :cache-control request) "no-store, no-cache, must-revalidate, post-check=0, pre-check=0") 268 | (setf (response-header :pragma request) "no-cache") 269 | (setf (response-header :last-modified request) (rfc-1123-date))) 270 | 271 | (defun redirect (request target &key 272 | (code +http-moved-temporarily+) 273 | protocol 274 | host 275 | port) 276 | "Redirects the browser to TARGET with status code CODE. Target must 277 | be a string and CODE should be one of the 3xx status codes. If TARGET 278 | is a full URL starting with a scheme, HOST, PORT and PROTOCOL are 279 | ignored. Otherwise, TARGET should denote the path part of a URL and 280 | the protocol, host, and port can be specified via keyword args. Any 281 | values not specified will be taken from the current request. (Note, 282 | however, that if no port was specified in the Host: header of the 283 | request, the redirect will likewise have no explicit port; if the 284 | protocol was changed this will result in a redirect to the default 285 | port for the new protocol. CODE must be a 3xx redirection code and 286 | will be sent as status code." 287 | (check-type code (integer 300 399)) 288 | (flet ((just-host (host-and-port) 289 | (subseq host-and-port 0 (position #\: host-and-port))) 290 | (just-port (host-and-port) 291 | (let ((colon (position #\: host-and-port))) 292 | (and colon (subseq host-and-port (1+ colon)))))) 293 | (let ((url 294 | (if (uri-scheme (parse-uri target)) 295 | target 296 | (let* ((requested-host (request-header :host request)) 297 | (current-protocol (if (ssl-certificate-file (acceptor request)) :https :http))) 298 | (format nil "~(~a~)://~a~@[:~a~]~a" 299 | (or protocol current-protocol) 300 | (or host (just-host requested-host)) 301 | (or port (just-port requested-host)) 302 | target))))) 303 | (setf (response-header :location request) url) 304 | (abort-request-handler code)))) 305 | 306 | (defun require-authorization (request &optional (realm "Toot")) 307 | "Sends 401: Authorization required reply to require basic HTTP 308 | authentication (see RFC 2617) for the realm REALM." 309 | (setf (response-header :www-authenticate request) 310 | (format nil "Basic realm=\"~A\"" (quote-string realm))) 311 | (abort-request-handler +http-authorization-required+)) 312 | 313 | (defun handle-if-modified-since (time request) 314 | "Handles the If-Modified-Since header of REQUEST, sending an '304: 315 | Not modified' response if the time represented by the UTC TIME is the 316 | same as the value in the If-Modified-Since header. Also sets the Last 317 | Modified header in the response to TIME." 318 | (setf (response-header :last-modified request) (rfc-1123-date time)) 319 | (let ((if-modified-since (request-header :if-modified-since request)) 320 | (time-string (rfc-1123-date time))) 321 | ;; simple string comparison is sufficient; see RFC 2616 14.25 322 | (when (and if-modified-since (equal if-modified-since time-string)) 323 | (abort-request-handler +http-not-modified+)))) 324 | 325 | (defun handle-range (request bytes-available) 326 | "If the request contains a Range header returns the starting 327 | position and the number of bytes to transfer. Otherwise returns 0 and 328 | bytes-available. An invalid specified range is reported to the client 329 | immediately with a '416: Requested range not satisfiable' response." 330 | (or 331 | (register-groups-bind (start end) 332 | ("^bytes (\\d+)-(\\d+)$" (request-header :range request) :sharedp t) 333 | ;; body won't be executed if regular expression does not match 334 | (setf start (parse-integer start)) 335 | (setf end (parse-integer end)) 336 | (when (or (< start 0) (>= end bytes-available)) 337 | (setf (response-header :content-range request) (format nil "bytes 0-~D/*" (1- bytes-available))) 338 | (abort-request-handler 339 | +http-requested-range-not-satisfiable+ 340 | (format nil "invalid request range (requested ~D-~D, accepted 0-~D)" 341 | start end (1- bytes-available)))) 342 | (setf (status-code request) +http-partial-content+) 343 | (setf (response-header :content-range request) (format nil "bytes ~D-~D/*" start end)) 344 | (values start (1+ (- end start)))) 345 | (values 0 bytes-available))) 346 | 347 | (defun cookie-value (name request) 348 | "Get the value of the cookie with the given name sent by the client 349 | or NIL if no such cookie was sent." 350 | (when-let (cookie (cdr (assoc name (cookies-in request) :test #'string=))) 351 | cookie)) 352 | 353 | (defun set-cookie (name request &key (value "") expires path domain secure http-only) 354 | "Set a cookie to be sent with the reply." 355 | (let ((place (assoc name (cookies-out request) :test #'string=)) 356 | (cookie (make-instance 'cookie 357 | :name name 358 | :value value 359 | :expires expires 360 | :path path 361 | :domain domain 362 | :secure secure 363 | :http-only http-only))) 364 | (cond 365 | (place (setf (cdr place) cookie)) 366 | (t (push (cons name cookie) (cookies-out request)))) 367 | cookie)) 368 | 369 | (defun cookie-out (name request) 370 | "Returns the current value of the outgoing cookie named 371 | NAME. Search is case-sensitive." 372 | (cdr (assoc name (cookies-out request) :test #'string=))) 373 | 374 | 375 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 376 | ;;; Trivial static file handler 377 | 378 | (defclass static-file-handler () 379 | ((root :initarg :root :accessor root) 380 | (path-checker :initarg :path-checker :initform #'safe-pathname-p :accessor path-checker)) 381 | 382 | (:documentation "A handler that serves files found under a given 383 | root directory. Checks the path before serving the file with 384 | specified path-checker which should be a function that takes the 385 | path and returns true if it is safe. If the path checker returns 386 | false, the request is aborted with 403: Forbidden.")) 387 | 388 | (defmethod initialize-instance :after ((h static-file-handler) &key &allow-other-keys) 389 | (with-slots (root) h 390 | (setf root (truename (merge-pathnames root))))) 391 | 392 | (defmethod handle-request ((handler static-file-handler) request) 393 | (with-slots (root path-checker) handler 394 | (let ((*default-pathname-defaults* root) 395 | (path (request-path request))) 396 | (unless (funcall path-checker path) 397 | (abort-request-handler +http-forbidden+)) 398 | (serve-file request (merge-pathnames (subseq (add-index path) 1)))))) 399 | 400 | (defun safe-pathname-p (path) 401 | "Verify that a path, translated to a file doesn't contain any tricky 402 | bits such as '..'" 403 | (let ((directory (pathname-directory (subseq path 1)))) 404 | (or (stringp directory) 405 | (null directory) 406 | (and (consp directory) 407 | (eql (first directory) :relative) 408 | (every #'stringp (rest directory)))))) 409 | 410 | (defun add-index (filename &key (name "index") (extension "html")) 411 | "Add an index file name to a directory filename. Defaults to index.html" 412 | (format nil "~a~:[~;~a~@[.~a~]~]" filename (ends-with #\/ filename) name extension)) 413 | -------------------------------------------------------------------------------- /api.txt: -------------------------------------------------------------------------------- 1 | -*- mode: markup; -*- 2 | 3 | * Handlers 4 | 5 | Toot’s main job, as a web server, is to accept a connection from an 6 | HTTP client, read and parse the request, and return a reply generated 7 | by some user-provided code, a \i{handler}. 8 | 9 | Before it hands off to the handler, Toot has to deal with a bunch of 10 | gorp involving persistent connections, parsing the request, chunking 11 | output, etc. But that should all be of little to no concern of the 12 | user who just provides a handler that knows what to do with the 13 | requests when they’re available. 14 | 15 | A \i{handler} is any object that can be passed as the first argument 16 | to the generic function \code{handle-request}: 17 | 18 | (defgeneric handle-request (handler request)) 19 | 20 | Out of the box, Toot, defines methods specializing the \code{handler} 21 | parameter on \code{function} and \code{symbol}, which just turn around 22 | and funcall the handler one argument, the \code{request}. 23 | 24 | A handler has four choices of how it can handle a request. 25 | 26 | - It can return a string which will be properly encoded (based on 27 | the values of content-type and charset set on the request object) 28 | and sent as the body of the reply. 29 | 30 | - It can call \code{send-headers} on the request which will return a 31 | stream to which it can then write the body of the reply. In this 32 | case any outgoing headers such as content-type and outgoing 33 | cookies need to be set before calling send-headers. 34 | 35 | - It can call \code{abort-request-handler} with an HTTP status code, 36 | usually >= 300 which will cause the server to send an appropriate 37 | reply to the client. (This is used for both errors, e.g. 404: Not 38 | found, and also thing like redirects, e.g. 301: Moved permanently.) 39 | 40 | - It can return the symbol \code{not-handled}. If the handler called 41 | directly by Toot returns \code{not-handled}, the server will send 42 | a \code{404: Not found} reply. But a composite handler could use 43 | that return value as an indication to try another handler. 44 | 45 | * Functions useful in handlers 46 | 47 | ** Request data 48 | 49 | request-uri 50 | 51 | request-method 52 | 53 | get-parameter 54 | 55 | post-parameter 56 | 57 | parameter 58 | 59 | header-in 60 | 61 | cookie-in 62 | 63 | remote-addr 64 | 65 | remote-port 66 | 67 | authorization — gets the username and password provided via basic HTTP auth. 68 | 69 | host 70 | 71 | user-agent 72 | 73 | referer 74 | 75 | ** For controlling reply — low level 76 | 77 | send-headers — causes the HTTP headers to be sent and returns a stream 78 | to which the body of the reply can be written. 79 | 80 | set-cookie 81 | 82 | (setf return-code) 83 | 84 | (setf content-length) 85 | 86 | (setf content-type) 87 | 88 | (setf charset) 89 | 90 | (setf response-header) 91 | 92 | ** For controlling reply — high-level 93 | 94 | serve-file — serve up a specific file. Handles If-Modified-Since and 95 | Range requests. Guesses at Content-Type based on extension if not 96 | supplied. Sends “404: Not Found” reply if file does not exist. 97 | 98 | no-cache — add headers to the reply which should prevent caching by 99 | the browser. 100 | 101 | redirect — send a redirect rather than generating a reply. 102 | 103 | require-authorization — sends “401: Authorization Required” headers requiring basic HTTP 104 | authentication. 105 | 106 | handle-if-modified-since — sends a “304: Not Modified” reply if the time 107 | provided is the same as the time provided in the request. 108 | 109 | handle-range — compute the starting position and number of bytes to 110 | send. Send a “416: Requested range not satisfiable” if the range is 111 | invalid. 112 | 113 | ** Misc 114 | 115 | log-message — log a message to Toot’s message log. 116 | 117 | maybe-handle — macro for writing composable handlers. 118 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (define-condition toot-condition (condition) 31 | () 32 | (:documentation "Superclass for all conditions related to Toot.")) 33 | 34 | (define-condition toot-error (toot-condition error) 35 | () 36 | (:documentation "Superclass for all errors related to Toot.")) 37 | 38 | (define-condition toot-simple-error (toot-error simple-condition) 39 | () 40 | (:documentation "Like TOOT-ERROR but with formatting capabilities.")) 41 | 42 | (defun internal-error (format-control &rest format-arguments) 43 | "Signals an error of type TOOT-SIMPLE-ERROR with the provided 44 | format control and arguments." 45 | (error 'toot-simple-error 46 | :format-control format-control 47 | :format-arguments format-arguments)) 48 | 49 | (define-condition toot-warning (toot-condition warning) 50 | () 51 | (:documentation "Superclass for all warnings related to Toot.")) 52 | 53 | (define-condition toot-simple-warning (toot-warning simple-condition) 54 | () 55 | (:documentation "Like TOOT-WARNING but with formatting capabilities.")) 56 | 57 | (defun toot-warn (format-control &rest format-arguments) 58 | "Signals a warning of type TOOT-SIMPLE-WARNING with the 59 | provided format control and arguments." 60 | (warn 'toot-simple-warning 61 | :format-control format-control 62 | :format-arguments format-arguments)) 63 | 64 | (define-condition parameter-error (toot-simple-error) 65 | () 66 | (:documentation "Signalled if a function was called with incosistent or illegal parameters.")) 67 | 68 | (defun parameter-error (format-control &rest format-arguments) 69 | "Signals an error of type PARAMETER-ERROR with the provided 70 | format control and arguments." 71 | (error 'parameter-error 72 | :format-control format-control 73 | :format-arguments format-arguments)) 74 | 75 | (define-condition operation-not-implemented (toot-error) 76 | ((operation :initarg :operation 77 | :reader operation 78 | :documentation "The name of the unimplemented operation.")) 79 | (:report (lambda (condition stream) 80 | (format stream "The operation ~A is not yet implemented for the implementation ~A. 81 | Consider sending a patch..." 82 | (operation condition) 83 | (lisp-implementation-type)))) 84 | (:documentation "This warning is signalled when an operation \(like 85 | SETUID for example) is not implemented for a specific Lisp.")) 86 | 87 | (define-condition request-aborted (toot-condition) 88 | ((response-status-code :initarg :response-status-code :reader response-status-code) 89 | (body :initarg :body :initform nil :reader body)) 90 | (:documentation "Signaled internally to cause handling of a request to be aborted and a response sent by Toot itself.")) 91 | 92 | (defun not-implemented (name) 93 | "Used to signal an error if an operation named NAME is not implemented." 94 | (error 'operation-not-implemented :operation name)) 95 | 96 | (defgeneric maybe-invoke-debugger (condition) 97 | (:documentation "This generic function is called whenever a 98 | condition CONDITION is signaled in Toot. You might want to specialize 99 | it on specific condition classes for debugging purposes. The default 100 | method invokes the debugger with CONDITION if *CATCH-ERRORS-P* is 101 | NIL.") 102 | (:method (condition) 103 | (when *debug-errors-p* (invoke-debugger condition)))) 104 | 105 | (defmacro with-debugger (&body body) 106 | "Executes BODY and invokes the debugger if an error is signaled and 107 | *CATCH-ERRORS-P* is NIL." 108 | `(handler-bind ((error #'maybe-invoke-debugger)) 109 | ,@body)) 110 | 111 | (defmacro ignore-errors* (&body body) 112 | "Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*." 113 | `(ignore-errors (with-debugger ,@body))) 114 | 115 | (defmacro handler-case* (expression &rest clauses) 116 | "Like HANDLER-CASE, but observes *CATCH-ERRORS-P*." 117 | `(handler-case (with-debugger ,expression) 118 | ,@clauses)) 119 | 120 | (defun get-backtrace () 121 | "Returns a string with a backtrace of what the Lisp system thinks is 122 | the \"current\" error." 123 | (handler-case 124 | (with-output-to-string (s) 125 | (trivial-backtrace:print-backtrace-to-stream s)) 126 | (error (condition) 127 | (format nil "Could not generate backtrace: ~A." condition)))) 128 | -------------------------------------------------------------------------------- /cookie.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (defclass cookie () 31 | ((name :initarg :name :reader name :type string) 32 | (value :initarg :value :initform "" :accessor value) 33 | (expires :initarg :expires :initform nil :accessor expires) 34 | (path :initarg :path :initform nil :accessor path) 35 | (domain :initarg :domain :initform nil :accessor domain) 36 | (secure :initarg :secure :initform nil :accessor secure) 37 | (http-only :initarg :http-only :initform nil :accessor http-only))) 38 | 39 | (defmethod initialize-instance :around ((cookie cookie) &key name &allow-other-keys) 40 | "Ensure COOKIE has a correct slot-value for NAME." 41 | (unless (http-token-p name) 42 | (parameter-error "~S is not a legal name for a cookie." name)) 43 | (call-next-method)) 44 | 45 | (defun stringify-cookie (cookie) 46 | (with-slots (name value expires path domain secure http-only) cookie 47 | (format 48 | nil 49 | "~a=~a~@[; expires=~a~]~@[; path=~a~]~@[; domain=~a~]~@[~*; secure~]~@[~*; HttpOnly~]" 50 | name 51 | (url-encode (princ-to-string value) +utf-8+) 52 | (and expires (rfc-1123-date expires)) 53 | path 54 | domain 55 | secure 56 | http-only))) 57 | 58 | (defun http-token-p (token) 59 | "Tests whether TOKEN is a string which is a valid 'token' 60 | according to HTTP/1.1 \(RFC 2068)." 61 | (and (stringp token) 62 | (plusp (length token)) 63 | (every (lambda (char) 64 | (and ;; CHAR is US-ASCII but not control character or ESC 65 | (< 31 (char-code char) 127) 66 | ;; CHAR is not 'tspecial' 67 | (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=)))) 68 | token))) -------------------------------------------------------------------------------- /docs.txt: -------------------------------------------------------------------------------- 1 | -*- mode: markup; -*- 2 | 3 | * Toot 4 | 5 | Toot is intended to be a minimal web server on top of which more 6 | fully-functional and user-friendly web servers can be used. Toot is 7 | responsible for accepting network connections, reading and parsing 8 | HTTP requests, and passing them off to a handler which can then 9 | generate an HTTP response by writing content to a stream. Handlers can 10 | also affect the response by setting HTTP response headers on the 11 | request object they are handed. 12 | 13 | ** Generating responses 14 | 15 | The simplest case: 16 | 17 | (start-server :port 8080 :handler (lambda (r) 'not-handled)) 18 | 19 | This creates a server that listens on port 8080 and replies to every 20 | request with a bare-bones \code{404: Not Found} error page. 21 | 22 | The \code{:handler} argument can be any object which can be passed as 23 | the handler argument to the generic function: 24 | 25 | (defgeneric handle-request (handler request)) 26 | 27 | Out of the box Toot provides methods on \code{handle-request} that 28 | specialize the first argument on \code{function} and \code{symbol} and 29 | simply \code{funcall} the handler with the request as a single 30 | argument. The \code{handle-request} method can either return a string 31 | which is returned as the body of the response or can obtain a stream 32 | by calling \code{send-headers} on the request object and write the 33 | body of the response 34 | 35 | ** Customizing error pages 36 | 37 | 38 | ** Customizing logging 39 | 40 | 41 | ** Threading models 42 | 43 | 44 | 45 | 46 | 47 | 48 | The only required argument to \code{start-server} is the 49 | \code{:handler}—if \code{:port} is not specified the server will 50 | default to 80 unless SSL configuration has been provided in which case 51 | it will default to 443. However, normal user processes are typically 52 | prevented from binding ports under 1024. On recent versions of Linux 53 | you should be able to use \code{setcap 'cap_net_bind_service=+ep' 54 | /path/to/program} to allow a given executable to bind low parts. To 55 | use that technique, it’s probably best to build an executable of your 56 | server with something like [Buildapp] and then \code{setcap} that 57 | executable rather than setting it on your Lisp. 58 | 59 | 60 | 61 | * Internals 62 | 63 | ** Acceptors 64 | 65 | Manage a server socket and accept connections from clients. Each 66 | acceptor has a \code{taskmaster} which is responsible for calling 67 | \code{accept-connections} and \code{process-connection} for each 68 | connection. Acceptors can optionally be configured with an SSL 69 | certificate in which case they will provide an HTTPS, rather than 70 | HTTP, listener. 71 | 72 | ** Requests 73 | 74 | When it processes a connection, the acceptor reads a series of HTTP 75 | requests for the client and turns them into \code{request} objects. 76 | The \code{request} object holds all the information about the request 77 | including the request-uri, method, http-version, all the headers (as 78 | an alist with the header names as keywords), incoming cookies, and get 79 | and post parameters. It also is used to hold information about the 80 | response generated when the request is handled. 81 | 82 | ** Handlers 83 | 84 | Handlers are responsible for taking a request and generating a 85 | response. Toot invokes handlers via the generic function 86 | \code{handle-request} which has two argument, the handler and the 87 | request. Out of the box, Toot provides methods specializing the 88 | handler argument on \code{function} and \code{symbol}, that funcall 89 | the handler, which should denote a function of a single argument, with 90 | the request object. 91 | 92 | ** Error page generators 93 | 94 | When Toot needs to send an error page it uses the generic function 95 | \code{generate-error-page} called on an error page generator, the 96 | request, and with keyword arguments specifying the error and backtrace 97 | if applicable. 98 | 99 | ** Taskmasters 100 | 101 | Actually run the acceptors, either everything in one thread (a 102 | single-threaded-taskmaster) or in a dedicated thread for 103 | accept-connection and a new thread for each process-connection. 104 | 105 | [Buildapp] 106 | -------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; See LICENSE for details. 5 | 6 | (in-package :toot) 7 | 8 | (setf (documentation #'acceptor t) "acceptor that accepted this request.") 9 | (setf (documentation #'access-logger t) "logger object that can log HTTP accesses.") 10 | (setf (documentation #'address t) "IP address to which the acceptor binds.") 11 | (setf (documentation #'body-octets t) "body of the request as octets.") 12 | (setf (documentation #'body-stream t) "body of the request as a stream.") 13 | (setf (documentation #'content-length t) "length of the response about to be written.") 14 | (setf (documentation #'content-type t) "the MIME type of the response about to be written.") 15 | (setf (documentation #'error-generator t) "object responsible for generating error pages.") 16 | (setf (documentation #'handler t) "object responsible for generating a response to each request.") 17 | (setf (documentation #'message-logger t) "object that logs miscelaneous messages to the Toot message log.") 18 | (setf (documentation #'name t) "name of the server, used in to set the Server response header.") 19 | (setf (documentation #'persistent-connections-p t) "flag controlling whether acceptor will allow persistent connections.") 20 | (setf (documentation #'port t) "port the acceptor will listen on.") 21 | (setf (documentation #'read-timeout t) "timeout for reading from the client.") 22 | (setf (documentation #'remote-addr t) "IP address of the client side of the socket making the request.") 23 | (setf (documentation #'remote-port t) "port of the client side of the socket making the request.") 24 | (setf (documentation #'request-method t) "HTTP method (e.g. GET, POST, HEAD) of the request.") 25 | (setf (documentation #'request-uri t) "URI of the request as a puri:uri object.") 26 | (setf (documentation #'server-protocol t) "server protocol of the request as a keyword.") 27 | (setf (documentation #'status-code t) "HTTP status code of the response being generated.") 28 | (setf (documentation #'taskmaster t) "object responsible for running the acceptor.") 29 | (setf (documentation #'write-timeout t) "timeout for writing to the client.") 30 | (setf (documentation #'cookies-in t) "cookies sent by the client as an alist.") 31 | (setf (documentation #'get-parameters t) "parameters sent in the query string.") 32 | (setf (documentation #'request-headers t) "complete set of headers sent in the request as an alist.") -------------------------------------------------------------------------------- /http.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | ;;; 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | ;;; 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | ;;; 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; Request handlers. New handlers can be defined by providing methods 32 | ;;; on this generic function. 33 | 34 | (defgeneric handle-request (handler request) 35 | (:documentation "Used by the acceptor to handle a request. Returns 36 | true if the handler actually sends a response. (This is arranged by 37 | a default :around method. If for some reason a more-specific :around 38 | method is defined, it must return the same value.")) 39 | 40 | (defmethod handle-request :around (handler request) 41 | (call-next-method) 42 | (response-sent-p request)) 43 | 44 | (defmethod handle-request ((handler function) request) 45 | (funcall handler request)) 46 | 47 | (defmethod handle-request ((handler symbol) request) 48 | (funcall handler request)) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;;; Error page generation. 52 | 53 | (defgeneric generate-error-page (generator request &key error backtrace) 54 | (:documentation "Used by acceptor to generate an error page for a 55 | request based on the http status code.")) 56 | 57 | (defmethod generate-error-page ((generator function) request &key error backtrace) 58 | (funcall generator request error backtrace)) 59 | 60 | (defmethod generate-error-page ((generator symbol) request &key error backtrace) 61 | (funcall generator request error backtrace)) 62 | 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | ;;; Classes 65 | 66 | (defclass acceptor () 67 | ( 68 | ;; Configuration 69 | (port :initarg :port :reader port) 70 | (address :initarg :address :reader address) 71 | (name :initarg :name :reader name) 72 | (persistent-connections-p :initarg :persistent-connections-p :accessor persistent-connections-p) 73 | (read-timeout :initarg :read-timeout :reader read-timeout) 74 | (write-timeout :initarg :write-timeout :reader write-timeout) 75 | (listen-backlog :initarg :listen-backlog :reader listen-backlog) 76 | (ssl-certificate-file :initarg :ssl-certificate-file :initform nil :reader ssl-certificate-file) 77 | (ssl-private-key-file :initarg :ssl-private-key-file :initform nil :reader ssl-private-key-file) 78 | (ssl-private-key-password :initarg :ssl-private-key-password :initform nil :reader ssl-private-key-password) 79 | 80 | ;; Plugins 81 | (handler :initarg :handler :accessor handler) 82 | (error-generator :initarg :error-generator :accessor error-generator) 83 | (taskmaster :initarg :taskmaster :reader taskmaster) 84 | (access-loggger 85 | :initarg :access-logger 86 | :initform (make-instance 'stream-logger :destination *error-output*) 87 | :accessor access-logger) 88 | (message-logger 89 | :initarg :message-logger 90 | :initform (make-instance 'stream-logger :destination *error-output*) 91 | :accessor message-logger) 92 | 93 | ;; State 94 | (listen-socket :initform nil :accessor listen-socket) 95 | (shutdown-p :initform t :accessor shutdown-p) 96 | (requests-in-progress :initform 0 :accessor requests-in-progress) 97 | (shutdown-queue :initform (make-condition-variable) :accessor shutdown-queue) 98 | (shutdown-lock :initform (make-lock "toot-shutdown") :accessor shutdown-lock)) 99 | 100 | (:documentation "The object that listens on a socket for connections.") 101 | 102 | (:default-initargs 103 | :address nil 104 | :port nil 105 | :name (format nil "Toot ~a" *toot-version*) 106 | :listen-backlog 50 107 | :taskmaster (make-instance (if *supports-threads-p* 'thread-per-connection-taskmaster 'single-threaded-taskmaster)) 108 | :persistent-connections-p t 109 | :read-timeout *default-connection-timeout* 110 | :write-timeout *default-connection-timeout* 111 | :error-generator 'default-error-message-generator)) 112 | 113 | (defmethod initialize-instance :after ((acceptor acceptor) &key &allow-other-keys) 114 | (with-slots (port ssl-certificate-file ssl-private-key-file) acceptor 115 | (unless port (setf port (if ssl-certificate-file 443 80))) 116 | ;; OpenSSL doesn't know much about Lisp pathnames... 117 | (when ssl-certificate-file 118 | (setf ssl-certificate-file (namestring (truename ssl-certificate-file))) 119 | (setf ssl-private-key-file (namestring (truename ssl-private-key-file)))))) 120 | 121 | (defmethod print-object ((acceptor acceptor) stream) 122 | (print-unreadable-object (acceptor stream :type t) 123 | (format stream "\(host ~A, port ~A)" (or (address acceptor) "*") (port acceptor)))) 124 | 125 | (defclass request () 126 | (;; Information about the request itself 127 | (remote-addr :initarg :remote-addr :reader remote-addr) ; cgi REMOTE_ADDR 128 | (remote-port :initarg :remote-port :reader remote-port) ; cgi - weirdly missing 129 | (request-method :initarg :request-method :reader request-method) ; cgi REQUEST_METHOD 130 | (server-protocol :initarg :server-protocol :reader server-protocol) ; cgi SERVER_PROTOCOL 131 | (request-uri :initarg :request-uri :reader request-uri) 132 | (get-parameters :initform nil :reader get-parameters) 133 | (post-parameters :initform nil :reader post-parameters) 134 | (body-stream :initform nil :reader body-stream) 135 | (body-octets :initform nil :reader body-octets) 136 | (request-headers :initarg :request-headers :reader request-headers) 137 | (cookies-in :initform nil :reader cookies-in) 138 | 139 | ;; Information used in generating the reply 140 | (status-code :initform +http-ok+ :accessor status-code) 141 | (content-length :initform nil :accessor content-length) 142 | (content-type :initform *default-content-type* :accessor content-type) 143 | (response-charset :initform *default-charset* :accessor response-charset) 144 | (response-headers :initform nil :accessor response-headers) 145 | (cookies-out :initform nil :accessor cookies-out) 146 | 147 | ;; Lifecycle control 148 | (headers-sent-p :initform nil :accessor headers-sent-p) 149 | (close-stream-p :initform t :accessor close-stream-p) 150 | 151 | ;; Internal foo 152 | (acceptor :initarg :acceptor :reader acceptor) 153 | (content-stream :initarg :content-stream :accessor content-stream) 154 | (tmp-files :initform () :accessor tmp-files))) 155 | 156 | (defmethod initialize-instance :after ((request request) &key &allow-other-keys) 157 | 158 | (with-slots (get-parameters request-uri request-headers cookies-in) request 159 | (handler-case* 160 | (setf 161 | get-parameters (parse-query-string request-uri) 162 | cookies-in (parse-cookies request-headers)) 163 | (error (condition) 164 | (log-message request :error "Error when creating REQUEST object: ~A" condition) 165 | ;; we assume it's not our fault... 166 | (setf (status-code request) +http-bad-request+))))) 167 | 168 | (defun parse-query-string (request-uri) 169 | ;; FIXME: This *substitution-char* thing seems hinky to me. Is this 170 | ;; really the best we can do.? 171 | (let ((*substitution-char* #\?)) 172 | (form-url-encoded-list-to-alist 173 | (split "&" (uri-query request-uri))))) 174 | 175 | (defun parse-cookies (request-headers) 176 | ;; The utf-8 decoding here is because we always encode the values in 177 | ;; outgoing cookies that way, i.e. by url-encoding the values using 178 | ;; the utf-8 encoding of characters that need escaping. The comma is 179 | ;; because that's how multiple Cookie headers will be joined and the 180 | ;; semicolon is because that's how a single Cookie headers delimits 181 | ;; the separate cookies. 182 | (form-url-encoded-list-to-alist 183 | (split "\\s*[,;]\\s*" (cdr (assoc :cookie request-headers))) 184 | +utf-8+)) 185 | 186 | ;;; Convenience methods to pass along log-message calls until we hit the actual logger. 187 | 188 | (defmethod log-message ((acceptor acceptor) log-level format-string &rest format-arguments) 189 | (apply #'log-message (message-logger acceptor) log-level format-string format-arguments)) 190 | 191 | (defmethod log-message ((request request) log-level format-string &rest format-arguments) 192 | (apply #'log-message (acceptor request) log-level format-string format-arguments)) 193 | 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | ;;; Server -- these functions interact with a taskmaster to implement 197 | ;;; the basic read a request and reply functionality. 198 | 199 | (defun accept-connections (acceptor) 200 | "Accept connections on our listen socket and hand them back to the 201 | taskmaster via handle-incoming-connection. Called by taskmaster's 202 | execute-acceptor." 203 | (with-slots (listen-socket shutdown-p read-timeout write-timeout taskmaster) acceptor 204 | (usocket:with-server-socket (listener listen-socket) 205 | (loop until shutdown-p do 206 | (when (usocket:wait-for-input listener :ready-only t :timeout +new-connection-wait-time+) 207 | (when-let (connection 208 | (handler-case (usocket:socket-accept listener) 209 | ;; ignore condition 210 | (usocket:connection-aborted-error ()))) 211 | (set-timeouts connection read-timeout write-timeout) 212 | (handle-incoming-connection taskmaster acceptor connection))))))) 213 | 214 | (defun process-connection (acceptor socket) 215 | "Actually process the connection accepted via accept connection. 216 | Called by taskmaster's handle-incoming-connection, possibly in a 217 | different thread than accept-connection is running in." 218 | (handler-bind ((error 219 | ;; abort if there's an error which isn't caught inside 220 | (lambda (cond) 221 | (maybe-invoke-debugger cond) 222 | (log-message 223 | acceptor 224 | *lisp-errors-log-level* 225 | "Error while processing connection: ~A" cond) 226 | (return-from process-connection))) 227 | (warning 228 | ;; log all warnings which aren't caught inside 229 | (lambda (cond) 230 | (log-message 231 | acceptor 232 | *lisp-warnings-log-level* 233 | "Warning while processing connection: ~A" cond)))) 234 | (usocket:with-mapped-conditions () 235 | (let ((content-stream (make-socket-stream socket acceptor))) 236 | (unwind-protect 237 | ;; process requests until either the acceptor is shut 238 | ;; down, close-stream-p on the most recent request is T, 239 | ;; or the peer fails to send a request 240 | (loop until (shutdown-p acceptor) do 241 | (multiple-value-bind (request-headers request-method url-string protocol) 242 | (read-request content-stream) 243 | ;; check if there was a request at all 244 | (unless request-method (return)) 245 | 246 | (let ((transfer-encodings (cdr (assoc :transfer-encoding request-headers)))) 247 | 248 | (when transfer-encodings 249 | (setf transfer-encodings (split "\\s*,\\s*" transfer-encodings)) 250 | 251 | (when (member "chunked" transfer-encodings :test #'equalp) 252 | ;; turn chunking on before we read the request body 253 | (setf content-stream (make-chunked-stream content-stream)) 254 | (setf (chunked-stream-input-chunking-p content-stream) t))) 255 | 256 | (multiple-value-bind (remote-addr remote-port) 257 | (get-peer-address-and-port socket) 258 | 259 | (let ((lock (shutdown-lock acceptor)) 260 | (request (make-instance 'request 261 | :acceptor acceptor 262 | :remote-addr remote-addr 263 | :remote-port remote-port 264 | :request-headers request-headers 265 | :content-stream content-stream 266 | :request-method request-method 267 | :request-uri (parse-uri url-string) 268 | :server-protocol protocol))) 269 | (with-lock-held (lock) (incf (requests-in-progress acceptor))) 270 | (unwind-protect 271 | (progn 272 | (process-request request) 273 | (log-access (access-logger acceptor) request)) 274 | (with-lock-held (lock) 275 | (decf (requests-in-progress acceptor)) 276 | (when (shutdown-p acceptor) 277 | (condition-notify (shutdown-queue acceptor))))) 278 | (finish-response-body request) 279 | (when (close-stream-p request) (return))))))) 280 | 281 | (when content-stream 282 | ;; As we are at the end of the requests here, we ignore 283 | ;; all errors that may occur while flushing and/or closing 284 | ;; the stream. 285 | (ignore-errors (force-output content-stream)) 286 | (ignore-errors (close content-stream :abort t)))))))) 287 | 288 | (defun process-request (request) 289 | "Process a single request. Called repeatedly by process-connection." 290 | ;; SEND-RESPONSE-HEADERS will throw HEAD-REQUEST after the headers 291 | ;; are written if the request was a HEAD request. 292 | 293 | ;; FIXME: should the CATCH be inside the UNWIND-PROTECT? Hmmm. 294 | 295 | ;; FIXME: Also, after the call to handle-request we should perhaps 296 | ;; check here that if the content-length was set that the requisite 297 | ;; number of bytes were sent. If not we should probabaly set 298 | ;; close-stream-p to t since things are going to be all messed up. 299 | (catch 'head-request 300 | (unwind-protect 301 | (block handle-request 302 | (handler-bind 303 | ((warning (lambda (w) 304 | (maybe-log-warning request w))) 305 | (error (lambda (e) 306 | ;; If the headers were already sent, then 307 | ;; the error happened within the body and 308 | ;; who knows what state things are in. So 309 | ;; close the stream. 310 | (when (headers-sent-p request) 311 | (setf (close-stream-p request) t)) 312 | (let ((backtrace (get-backtrace))) 313 | (maybe-log-error request e backtrace) 314 | (report-error-to-client request e backtrace) 315 | (return-from handle-request))))) 316 | (with-debugger 317 | (handler-case 318 | (unless (handle-request (handler (acceptor request)) request) 319 | (abort-request-handler +http-not-found+)) 320 | (request-aborted (a) 321 | (setf (status-code request) (response-status-code a)) 322 | (send-response request (or (body a) (error-body request)))))))) 323 | 324 | (finish-output (content-stream request)) 325 | (drain-body-stream request) 326 | (delete-tmp-files request)))) 327 | 328 | (defun make-socket-stream (socket acceptor) 329 | (let ((base-stream (usocket:socket-stream socket))) 330 | (if (ssl-certificate-file acceptor) 331 | (setup-ssl-stream acceptor base-stream) 332 | base-stream))) 333 | 334 | (defun setup-ssl-stream (acceptor stream) 335 | ;; attach SSL to the stream if necessary 336 | (with-slots (ssl-certificate-file ssl-private-key-file ssl-private-key-password) acceptor 337 | (cl+ssl:make-ssl-server-stream 338 | stream 339 | :certificate ssl-certificate-file 340 | :key ssl-private-key-file 341 | :password ssl-private-key-password))) 342 | 343 | (defun finish-response-body (request) 344 | (with-slots (content-stream) request 345 | (force-output content-stream) 346 | (when (typep content-stream 'chunked-stream) 347 | ;; Setting these flushes the output stream and checks if there's 348 | ;; unread input which would be an error. 349 | (setf (chunked-stream-output-chunking-p content-stream) nil) 350 | (setf (chunked-stream-input-chunking-p content-stream) nil)))) 351 | 352 | (defun maybe-log-warning (request warning) 353 | (when *log-lisp-warnings-p* 354 | (log-message request *lisp-warnings-log-level* "~a" warning))) 355 | 356 | (defun maybe-log-error (request error backtrace) 357 | (when *log-lisp-errors-p* 358 | (log-message request *lisp-errors-log-level* "~a~@[~%~a~]" error 359 | (and *log-lisp-backtraces-p* backtrace)))) 360 | 361 | (defun report-error-to-client (request error &optional backtrace) 362 | (setf (status-code request) +http-internal-server-error+) 363 | (send-response 364 | request 365 | (error-body request :error error :backtrace backtrace) 366 | :content-type "text/html" 367 | :charset :utf-8)) 368 | 369 | (defun error-body (request &key error backtrace) 370 | (let ((generator (error-generator (acceptor request)))) 371 | (generate-error-page generator request :error error :backtrace backtrace))) 372 | 373 | (defun drain-body-stream (request) 374 | (when-let (stream (slot-value request 'body-stream)) 375 | (loop for char = (read-byte stream nil nil) while char))) 376 | 377 | (defun delete-tmp-files (request) 378 | (dolist (path (tmp-files request)) 379 | (when (and (pathnamep path) (probe-file path)) 380 | ;; the handler may have chosen to (re)move the uploaded 381 | ;; file, so ignore errors that happen during deletion 382 | (ignore-errors* (delete-file path))))) 383 | 384 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 385 | ;;; Request -- reading the HTTP request from the client 386 | 387 | (defun read-request (stream) 388 | "Reads incoming headers from the client via STREAM. Returns as 389 | multiple values the headers as an alist, the request-method, the URI, 390 | and the protocol of the request. The reading of the headers is handled 391 | by Chunga's read-http-headers method." 392 | (with-character-stream-semantics 393 | (let ((first-line (read-initial-request-line stream))) 394 | (when first-line 395 | (unless (every #'printable-ascii-char-p first-line) 396 | (send-bad-request-response stream "Non-ASCII character in request line") 397 | (return-from read-request nil)) 398 | (destructuring-bind (&optional request-method url-string protocol) 399 | (split "\\s+" first-line :limit 3) 400 | (unless url-string 401 | (send-bad-request-response stream) 402 | (return-from read-request nil)) 403 | (when *header-stream* 404 | (format *header-stream* "~A~%" first-line)) 405 | (let ((headers (and protocol (read-http-headers stream *header-stream*)))) 406 | (unless protocol (setf protocol "HTTP/0.9")) 407 | ;; maybe handle 'Expect: 100-continue' header 408 | (when-let (expectations (cdr (assoc :expect headers))) 409 | (when (member "100-continue" (split "\\s*,\\s*" expectations) :test #'equalp) 410 | ;; according to 14.20 in the RFC - we should actually 411 | ;; check if we have to respond with 417 here 412 | (let ((s (make-header-stream stream))) 413 | (write-status-line s +http-continue+) 414 | (write-line-crlf s "")))) 415 | (values headers 416 | (as-keyword request-method) 417 | url-string 418 | (as-keyword (trim-whitespace protocol))))))))) 419 | 420 | (defun read-initial-request-line (stream) 421 | (handler-case 422 | (let ((*current-error-message* "While reading initial request line:")) 423 | (usocket:with-mapped-conditions () 424 | (read-line* stream))) 425 | ((or end-of-file usocket:timeout-error) ()))) 426 | 427 | (defun printable-ascii-char-p (char) 428 | (<= 32 (char-code char) 126)) 429 | 430 | (defun get-peer-address-and-port (socket) 431 | "Returns the peer address and port of the socket SOCKET as two 432 | values. The address is returned as a string in dotted IP address 433 | notation." 434 | (values (usocket:vector-quad-to-dotted-quad (usocket:get-peer-address socket)) 435 | (usocket:get-peer-port socket))) 436 | 437 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 438 | ;;; Post parameters API. Three choices. 1. Get the post parameters 439 | ;;; parsed into an alist. 2. Get a stream from which the request body 440 | ;;; can be read. 3. Get the post body as a vector of octets. 441 | 442 | ;; Technically, we could allow somone to call request-body-octets and 443 | ;; later call post-parameters since we could parse the octets that 444 | ;; we've saved. But if they get the stream, all bets are off so for 445 | ;; consistency we'll just say you have to pick which form you want to 446 | ;; use. 447 | 448 | (defmethod post-parameters :before ((request request)) 449 | "Lazily fill in the post-parameters slot with data from the request body." 450 | (with-slots (post-parameters body-stream body-octets) request 451 | (unless post-parameters 452 | (when body-stream (error "Request body already retrieved as a stream.")) 453 | (when body-octets (error "Request body already retrieved as octets.")) 454 | (setf post-parameters (read-post-parameters request))))) 455 | 456 | (defmethod body-stream :before ((request request)) 457 | (with-slots (post-parameters body-stream body-octets) request 458 | (unless body-stream 459 | (when post-parameters (error "Request body already retrieved as parsed post parameters.")) 460 | (when body-octets (error "Request body already retrieved as octets.")) 461 | (setf body-stream (request-body-stream request))))) 462 | 463 | (defmethod body-octets :before ((request request)) 464 | (with-slots (post-parameters body-stream body-octets) request 465 | (unless body-octets 466 | (when post-parameters (error "Request body already retrieved as parsed post parameters.")) 467 | (when body-stream (error "Request body already retrieved as a stream.")) 468 | (setf body-octets (read-body-octets request))))) 469 | 470 | (defun read-post-parameters (request) 471 | "Read the post parameters from the body of the request and return them as an alist." 472 | 473 | (unless (or (request-header :content-length request) (chunking-input-p request)) 474 | (log-message request :warning "Can't read request body because there's ~ 475 | no Content-Length header and input chunking is off.") 476 | (return-from read-post-parameters nil)) 477 | 478 | (handler-case* 479 | (multiple-value-bind (type subtype charset) 480 | (parse-content-type-header (request-header :content-type request)) 481 | 482 | (let ((external-format (charset-to-external-format charset))) 483 | 484 | (cond 485 | ((and (string-equal type "application") (string-equal subtype "x-www-form-urlencoded")) 486 | (parse-application/x-www-form-urlencoded request external-format)) 487 | 488 | ((and (string-equal type "multipart") (string-equal subtype "form-data")) 489 | (parse-multipart/form-data request external-format))))) 490 | 491 | (error (condition) 492 | (log-message request :error "Error when reading POST parameters from body: ~A" condition) 493 | ;; this is not the right thing to do because it could happen 494 | ;; that we aren't finished reading from the request stream and 495 | ;; can't send a reply - to be revisited 496 | (setf (close-stream-p request) t) 497 | (abort-request-handler +http-bad-request+)))) 498 | 499 | (defun request-body-stream (request) 500 | "Return a stream from which the body of the request can be read. If 501 | the request specified a content-length, this stream will not read 502 | beyond it. And if the request is using chunked transfer encoding, the 503 | stream will be a chunked stream that will return :eof when it gets to 504 | the end of the input. After the request has been handled, any input 505 | remaining on the stream will be drained." 506 | ;; FIXME: this should really be an octet stream, it seems. Thus the 507 | ;; +latin-1+ external format. But we want a flexi-stream because we 508 | ;; want to be able to set the stream-bound. Perhaps could look into 509 | ;; using trivial-gray-stream-mixin ourself to define such a stream. 510 | ;; (We need to return such a limited stream to make sure user code 511 | ;; doesn't read the beginning of the next request on a persistent 512 | ;; connection.) 513 | 514 | ;; Or maybe this function should take a charset argument which 515 | ;; defaults to whatever was specified in the request headers if the 516 | ;; content is text. 517 | (let ((content-length (parse-integer (request-header :content-length request) :junk-allowed t)) 518 | (content-stream (content-stream request))) 519 | (cond 520 | (content-length 521 | (when (chunking-input-p request) 522 | ;; see RFC 2616, section 4.4 523 | (log-message request :warning "Got Content-Length header although input chunking is on.")) 524 | (let ((stream (make-flexi-stream (content-stream request) :external-format +latin-1+))) 525 | (setf (flexi-stream-bound stream) content-length) 526 | stream)) 527 | ((chunking-input-p request) content-stream)))) 528 | 529 | (defun read-body-octets (request) 530 | "Read the post data and return it as a vector of octets." 531 | (let ((content-length (parse-integer (request-header :content-length request) :junk-allowed t)) 532 | (content-stream (content-stream request))) 533 | (cond 534 | (content-length 535 | (when (chunking-input-p request) 536 | ;; see RFC 2616, section 4.4 537 | (log-message request :warning "Got Content-Length header although input chunking is on.")) 538 | (let ((content (make-array content-length :element-type 'octet))) 539 | (read-sequence content content-stream) 540 | content)) 541 | 542 | ((chunking-input-p request) 543 | (loop with buffer = (make-array +buffer-length+ :element-type 'octet) 544 | with content = (make-array 0 :element-type 'octet :adjustable t) 545 | for index = 0 then (+ index pos) 546 | for pos = (read-sequence buffer content-stream) 547 | do 548 | (adjust-array content (+ index pos)) 549 | (replace content buffer :start1 index :end2 pos) 550 | while (= pos +buffer-length+) 551 | finally (return content)))))) 552 | 553 | (defun charset-to-external-format (charset) 554 | (or 555 | (when charset 556 | (handler-case 557 | (make-external-format charset :eol-style :lf) 558 | (error () 559 | (toot-warn "Ignoring unknown character set ~A in request content type." charset)))) 560 | *default-external-format*)) 561 | 562 | (defun parse-application/x-www-form-urlencoded (request external-format) 563 | ;; FIXME: I'm not sure what this +latin-1+ bit is about. I think it 564 | ;; may just be so we can use cl-ppcre:split. In that case, maybe 565 | ;; better to use split-sequence:split-sequence directly on the 566 | ;; octets. However that seems hinky. Shouldn't we decode the the 567 | ;; string once and then split on #\& once it's a string? 568 | (form-url-encoded-list-to-alist 569 | (split "&" (octets-to-string (read-body-octets request) :external-format +latin-1+)) 570 | external-format)) 571 | 572 | (defun parse-multipart/form-data (request external-format) 573 | "Parse the REQUEST body as multipart/form-data, assuming that its 574 | content type has already been verified. Returns the form data as 575 | alist or NIL if there was no data or the data could not be parsed." 576 | (handler-case* 577 | (let ((content-stream (make-flexi-stream (content-stream request) :external-format +latin-1+))) 578 | (parse-rfc2388-form-data 579 | content-stream 580 | (request-header :content-type request) 581 | external-format 582 | (lambda () (first (push (tmp-filename) (tmp-files request)))))) 583 | (error (condition) 584 | (log-message request :error "While parsing multipart/form-data parameters: ~A" condition) 585 | nil))) 586 | 587 | (defun parse-rfc2388-form-data (stream content-type-header external-format tmp-filename-generator) 588 | "Creates an alist of POST parameters from the stream STREAM which is 589 | supposed to be of content type 'multipart/form-data'." 590 | (let* ((parsed-content-type-header (parse-header content-type-header :value)) 591 | (boundary (or (cdr (find-parameter 592 | "BOUNDARY" 593 | (header-parameters parsed-content-type-header))) 594 | (return-from parse-rfc2388-form-data)))) 595 | (loop for part in (parse-mime stream boundary tmp-filename-generator) 596 | for headers = (mime-part-headers part) 597 | for content-disposition-header = (find-content-disposition-header headers) 598 | for name = (cdr (find-parameter 599 | "NAME" 600 | (header-parameters content-disposition-header))) 601 | when name 602 | collect (cons name 603 | (let ((contents (mime-part-contents part))) 604 | (if (pathnamep contents) 605 | (list contents 606 | (get-file-name headers) 607 | (mime-content-type part :as-string t)) 608 | (convert-hack contents external-format))))))) 609 | 610 | (defun convert-hack (string external-format) 611 | "The rfc2388 code is buggy in that it operates on a character stream 612 | and thus only accepts encodings which are 8 bit transparent. In order 613 | to support different encodings for parameter values submitted, we post 614 | process whatever string values the rfc2388 package has returned." 615 | (flex:octets-to-string (map '(vector (unsigned-byte 8) *) 'char-code string) 616 | :external-format external-format)) 617 | 618 | (defun chunking-input-p (request) 619 | "Whether input chunking is currently switched on for the acceptor's 620 | content stream." 621 | (chunked-stream-input-chunking-p (content-stream request))) 622 | 623 | (defun external-format-from-content-type (content-type) 624 | "Creates and returns an external format corresponding to the value 625 | of the content type header provided in CONTENT-TYPE. If the content 626 | type was not set or if the character set specified was invalid, NIL is 627 | returned." 628 | (when content-type 629 | (when-let (charset (nth-value 2 (parse-content-type-header content-type))) 630 | (handler-case 631 | (make-external-format (as-keyword charset) :eol-style :lf) 632 | (error () 633 | (toot-warn "Invalid character set ~S in request has been ignored." charset)))))) 634 | 635 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 636 | ;;; Response -- sending back the HTTP response. 637 | 638 | ;; FIXME: probably should send HTTP/1.0 if the request was. 639 | (defun send-bad-request-response (stream &optional additional-info) 640 | (write-simple-response 641 | stream 642 | +http-bad-request+ 643 | '((:connection . "close")) 644 | (format nil "Your request could not be interpreted by this HTTP server~C~C~@[~A~C~C~]" 645 | #\Return #\Linefeed 646 | additional-info 647 | #\Return #\Linefeed))) 648 | 649 | ;;; FIXME: possibly the call site of handler-incoming-connection 650 | ;;; should be set up to allow the taskmaster to simply signal a 651 | ;;; condition or throw something 652 | (defun send-service-unavailable-response (acceptor socket) 653 | "Send a response to the client before we've created a request 654 | object. This can be used by taskmasters when they cannot accept a 655 | connection." 656 | (write-simple-response 657 | (make-socket-stream socket acceptor) 658 | +http-service-unavailable+ 659 | ;; FIXME: hmmm. this was :content rather than :content-length but 660 | ;; I'm thinking that was a translation error. check. And maybe 661 | ;; more to the point, it should be :connection . "close" like in 662 | ;; send-bad-request-response. 663 | '((:content-length . 0)))) 664 | 665 | (defun write-simple-response (stream status-code &optional headers content) 666 | (with-open-stream (s (make-header-stream stream)) 667 | (write-status-line s status-code) 668 | (write-headers s headers) 669 | (write-line-crlf s "") 670 | (when content (write-line-crlf stream content)))) 671 | 672 | ;; FIXME: technically a HEAD request SHOULD still have a 673 | ;; Content-Length header specifying "the size of the entity-body that 674 | ;; would have been sent had the request been a GET". Though that's 675 | ;; hard to do in the case where the handler writes to a stream. But 676 | ;; it's not MUST so maybe don't worry about it. 677 | 678 | (defun send-response (request content &key content-type (charset *default-charset*)) 679 | "Send a full response with the given content as the body." 680 | (let ((stream (content-stream request)) 681 | (encoded (string-to-octets content :external-format charset))) 682 | (send-response-headers request (length encoded) content-type charset) 683 | (write-sequence encoded stream))) 684 | 685 | (defun send-response-headers (request content-length content-type charset) 686 | "Send the response headers and return the stream to which the body 687 | of the response can be written. The stream is a binary stream. The 688 | public API function, SEND-HEADERS will wrap that stream in a 689 | flexi-stream based on the content-type and charset, if needed. Thus 690 | function is for functions that are going to take care of encoding the 691 | response themselves, such as SERVE-FILE, which just dumps an already 692 | encoded to the steam as octets. If the request was a HEAD request we 693 | dynamically abort rather than returning a stream." 694 | ;; Set content-length, content-type and external format if they're 695 | ;; supplied by caller. They could also have been set directly before 696 | ;; this function was called. 697 | (when content-length (setf (content-length request) content-length)) 698 | (when content-type (setf (content-type request) content-type)) 699 | (when charset (setf (response-charset request) charset)) 700 | 701 | (finalize-response-headers request) 702 | 703 | (with-slots (content-stream) request 704 | (let ((header-stream (make-header-stream content-stream))) 705 | (write-status-line header-stream (status-code request)) 706 | (write-headers header-stream (response-headers request)) 707 | (write-cookies header-stream (cookies-out request)) 708 | (write-line-crlf header-stream "")) 709 | (setf (headers-sent-p request) t) 710 | 711 | (when (eql (request-method request) :head) 712 | (throw 'head-request nil)) 713 | 714 | (when (string= (response-header :transfer-encoding request) "chunked") 715 | (unless (typep content-stream 'chunked-stream) 716 | (setf content-stream (make-chunked-stream content-stream))) 717 | (setf (chunked-stream-output-chunking-p content-stream) t)) 718 | 719 | content-stream)) 720 | 721 | (defun finalize-response-headers (request) 722 | "Set certain headers automatically based on values in the request object." 723 | (flet ((set-header (name value) (setf (response-header name request) value))) 724 | 725 | (set-header :date (rfc-1123-date)) 726 | (set-header :content-type (full-content-type request)) 727 | (set-header :server (name (acceptor request))) 728 | (when (content-length request) (set-header :content-length (content-length request))) 729 | 730 | ;; Chunked encoding only available in http/1.1 and only needed if 731 | ;; we don't know the length of the content we're sending. 732 | (let* ((http/1.1-p (eql (server-protocol request) :http/1.1)) 733 | (chunkedp (and http/1.1-p (not (content-length request))))) 734 | 735 | (when chunkedp (set-header :transfer-encoding "chunked")) 736 | 737 | (multiple-value-bind (keep-alive-p keep-alive-requested-p) (keep-alive-p request) 738 | (cond 739 | ((and keep-alive-p (or chunkedp (length-known-p request))) 740 | (setf (close-stream-p request) nil) 741 | (let ((read-timeout (read-timeout (acceptor request)))) 742 | (when (and read-timeout keep-alive-requested-p) 743 | ;; In HTTP/1.0 keep-alive-p and keep-alive-requested-p 744 | ;; will always be the same. In HTTP/1.1 persistent 745 | ;; connections are assumed, but we'll return a 746 | ;; 'Keep-Alive' header if the client has explicitly 747 | ;; asked for one. 748 | (set-header :connection "Keep-Alive") 749 | ;; FIXME: perhaps we should set the Connection header 750 | ;; regardless of the read-timeout and only set this 751 | ;; header if there's a timeout. 752 | (set-header :keep-alive (format nil "timeout=~D" read-timeout))))) 753 | (t 754 | ;; If we aren't doing keep-alive then we need to tell the 755 | ;; client we're going to close the connection after sending 756 | ;; the reply. 757 | (setf (close-stream-p request) t) 758 | (set-header :connection "close"))))))) 759 | 760 | (defun length-known-p (request) 761 | (let ((head-request-p (eql (request-method request) :head)) 762 | (not-modified-response-p (eql (status-code request) +http-not-modified+))) 763 | (or head-request-p not-modified-response-p (content-length request)))) 764 | 765 | (defun keep-alive-p (request) 766 | "Should the current connection be kept alive? Secondary value 767 | indicates whether the client explicitly requested keep-alive. (Always 768 | the same as the primary value for HTTP/1.0 but potentially different 769 | in HTTP/1.1.)" 770 | (let ((connection-values (connection-values request))) 771 | (flet ((connection-value-p (value) 772 | (member value connection-values :test #'string-equal))) 773 | 774 | (let ((keep-alive-requested-p (connection-value-p "keep-alive"))) 775 | (values (and (persistent-connections-p (acceptor request)) 776 | (case (server-protocol request) 777 | (:http/1.1 (not (connection-value-p "close"))) 778 | (:http/1.0 keep-alive-requested-p))) 779 | keep-alive-requested-p))))) 780 | 781 | (defun connection-values (request) 782 | ;; the header might consist of different values separated by commas 783 | (when-let (connection-header (request-header :connection request)) 784 | (split "\\s*,\\s*" connection-header))) 785 | 786 | (defun make-header-stream (stream) 787 | "Make a stream just for writing the HTTP headers." 788 | (let ((header-stream (make-flexi-stream stream :external-format :iso-8859-1))) 789 | (if *header-stream* (make-broadcast-stream *header-stream* header-stream) header-stream))) 790 | 791 | (defun text-type-p (content-type) 792 | (cl-ppcre:scan "(?i)^text" content-type)) 793 | 794 | (defun full-content-type (request) 795 | "Return the value for the Content-Type header, including a charset if it's a text/* type." 796 | (with-slots (content-type response-charset) request 797 | (if (text-type-p content-type) 798 | (format nil "~a; charset=~(~a~)" content-type response-charset) 799 | content-type))) 800 | 801 | (defun write-line-crlf (stream fmt &rest args) 802 | (apply #'format stream fmt args) 803 | (write-char #\Return stream) 804 | (write-char #\Linefeed stream)) 805 | 806 | (defun write-status-line (stream status-code) 807 | (write-line-crlf stream "HTTP/1.1 ~D ~A" status-code (reason-phrase status-code))) 808 | 809 | (defun write-headers (stream headers) 810 | (loop for (key . value) in headers 811 | when value do (write-header-line (as-capitalized-string key) value stream))) 812 | 813 | (defun write-cookies (stream cookies) 814 | (loop for (nil . cookie) in cookies 815 | do (write-header-line "Set-Cookie" (stringify-cookie cookie) stream))) 816 | 817 | (defun write-header-line (key value stream) 818 | (let ((string (princ-to-string value))) 819 | (write-string key stream) 820 | (write-char #\: stream) 821 | (write-char #\Space stream) 822 | (let ((start 0)) 823 | (loop 824 | (let ((end (or (position #\Newline string :start start) (length string)))) 825 | ;; skip empty lines, as they confuse certain HTTP clients 826 | (unless (eql start end) 827 | (unless (zerop start) (write-char #\Tab stream)) 828 | (write-string string stream :start start :end end) 829 | (write-line-crlf stream "")) 830 | (setf start (1+ end)) 831 | (when (<= (length string) start) (return))))))) 832 | 833 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 834 | ;;; A bare-bones error page generator 835 | 836 | (defparameter *error-css* " 837 | body { 838 | font-family: \"Gill Sans\", sans-serif; 839 | width: 600px; 840 | margin: 1in auto; 841 | 842 | } 843 | 844 | h1 { font-size: 64px; } 845 | 846 | div { 847 | text-align: center; 848 | background: #ddddff; 849 | padding: 10px; 850 | border: thin solid black; 851 | height: 300px; 852 | } 853 | ") 854 | 855 | (defun default-error-message-generator (request error backtrace) 856 | "A function that generates a bare-bones error page to be used as an error page generator." 857 | (let ((status-code (status-code request))) 858 | (with-output-to-string (s) 859 | (format s "~&~d: ~a

~2:*~d: ~a

" 860 | *error-css* 861 | status-code (reason-phrase status-code)) 862 | (when (and error *show-lisp-errors-p*) 863 | (format s "
~a~@[~%~%Backtrace:~%~%~a~]
" 864 | (escape-for-html (princ-to-string error)) 865 | (when (and backtrace *show-lisp-backtraces-p*) 866 | (escape-for-html (princ-to-string backtrace))))) 867 | 868 | (flet ((escaped (arg) (and arg (escape-for-html arg)))) 869 | (let ((host (request-header :host request))) 870 | (format s "
Toot ~a running on (~A ~A)~@[ at ~A~:[ (port ~D)~;~]~]
" 871 | +toot-project-url+ 872 | *toot-version* 873 | +implementation-link+ 874 | (escaped (lisp-implementation-type)) 875 | (escaped (lisp-implementation-version)) 876 | (escaped (or host (address (acceptor request)))) 877 | (scan ":\\d+$" (or host "")) 878 | (port (acceptor request))))) 879 | 880 | 881 | (format s "~&
")))) 882 | 883 | (defun reason-phrase (status-code) 884 | "Returns a reason phrase for the HTTP return code STATUS-CODE (which 885 | should be an integer) or NIL for return codes Toot doesn't know." 886 | (gethash status-code *http-reason-phrase-map* "No reason phrase known")) 887 | -------------------------------------------------------------------------------- /log.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;;; Logging API -- the server logs HTTP requests and miscelaneous 32 | ;;; messages using these two generic functions, called on logger 33 | ;;; objects held by the server. 34 | 35 | (defgeneric log-access (logger request) 36 | (:documentation "Write a log entry for the request to the access log.")) 37 | 38 | (defgeneric log-message (logger log-level format-string &rest format-arguments) 39 | (:documentation "Write a log entry to the message log.")) 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;;; Null logger 43 | 44 | (defmethod log-access ((logger null) request) 45 | (declare (ignore request))) 46 | 47 | (defmethod log-message ((logger null) log-level format-string &rest format-arguments) 48 | (declare (ignore log-level format-string format-arguments))) 49 | 50 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | ;;; Simple logger for logging to an open character stream. 52 | 53 | (defclass stream-logger () 54 | ((destination :initarg :destination :reader destination) 55 | (lock :initform (make-lock "log-lock") :reader lock)) 56 | (:documentation "A logger that writes to a given stream.")) 57 | 58 | (defvar *default-logger* (make-instance 'stream-logger :destination *error-output*)) 59 | 60 | (defmethod log-access ((logger stream-logger) request) 61 | (let ((out (destination logger))) 62 | (with-lock-held ((lock logger)) 63 | (format out "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A ~ 64 | ~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%" 65 | (remote-addr request) 66 | (request-header :x-forwarded-for request) 67 | (authorization request) 68 | (iso-time) 69 | (request-method request) 70 | (request-uri request) 71 | (server-protocol request) 72 | (status-code request) 73 | (content-length request) 74 | (request-header :referer request) 75 | (request-header :user-agent request)) 76 | (finish-output out)))) 77 | 78 | (defmethod log-message ((logger stream-logger) log-level format-string &rest format-arguments) 79 | (let ((out (destination logger))) 80 | (with-lock-held ((lock logger)) 81 | (format out "[~A~@[ [~A]~]] ~?~%" (iso-time) log-level format-string format-arguments) 82 | (finish-output out)))) 83 | -------------------------------------------------------------------------------- /mime-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (defparameter *mime-type-list* 31 | '(("application/andrew-inset" "ez") 32 | ("application/cu-seeme" "cu") 33 | ("application/dsptype" "tsp") 34 | ("application/futuresplash" "spl") 35 | ("application/hta" "hta") 36 | ("application/java-archive" "jar") 37 | ("application/java-serialized-object" "ser") 38 | ("application/java-vm" "class") 39 | ("application/mac-binhex40" "hqx") 40 | ("application/mac-compactpro" "cpt") 41 | ("application/mathematica" "nb") 42 | ("application/msaccess" "mdb") 43 | ("application/msword" "doc" "dot") 44 | ("application/octet-stream" "bin") 45 | ("application/oda" "oda") 46 | ("application/ogg" "ogg") 47 | ("application/pdf" "pdf") 48 | ("application/pgp-keys" "key") 49 | ("application/pgp-signature" "pgp") 50 | ("application/pics-rules" "prf") 51 | ("application/postscript" "ps" "ai" "eps") 52 | ("application/rar" "rar") 53 | ("application/rdf+xml" "rdf") 54 | ("application/rss+xml" "rss") 55 | ("application/smil" "smi" "smil") 56 | ("application/wordperfect" "wpd") 57 | ("application/wordperfect5.1" "wp5") 58 | ("application/xhtml+xml" "xhtml" "xht") 59 | ("application/xml" "fo" "xml" "xsl") 60 | ("application/zip" "zip") 61 | ("application/vnd.cinderella" "cdy") 62 | ("application/vnd.mozilla.xul+xml" "xul") 63 | ("application/vnd.ms-excel" "xls" "xlb" "xlt") 64 | ("application/vnd.ms-pki.seccat" "cat") 65 | ("application/vnd.ms-pki.stl" "stl") 66 | ("application/vnd.ms-powerpoint" "ppt" "pps") 67 | ("application/vnd.oasis.opendocument.chart" "odc") 68 | ("application/vnd.oasis.opendocument.database" "odb") 69 | ("application/vnd.oasis.opendocument.formula" "odf") 70 | ("application/vnd.oasis.opendocument.graphics" "odg") 71 | ("application/vnd.oasis.opendocument.graphics-template" "otg") 72 | ("application/vnd.oasis.opendocument.image" "odi") 73 | ("application/vnd.oasis.opendocument.presentation" "odp") 74 | ("application/vnd.oasis.opendocument.presentation-template" "otp") 75 | ("application/vnd.oasis.opendocument.spreadsheet" "ods") 76 | ("application/vnd.oasis.opendocument.spreadsheet-template" "ots") 77 | ("application/vnd.oasis.opendocument.text" "odt") 78 | ("application/vnd.oasis.opendocument.text-master" "odm") 79 | ("application/vnd.oasis.opendocument.text-template" "ott") 80 | ("application/vnd.oasis.opendocument.text-web" "oth") 81 | ("application/vnd.rim.cod" "cod") 82 | ("application/vnd.smaf" "mmf") 83 | ("application/vnd.stardivision.calc" "sdc") 84 | ("application/vnd.stardivision.draw" "sda") 85 | ("application/vnd.stardivision.impress" "sdd" "sdp") 86 | ("application/vnd.stardivision.math" "smf") 87 | ("application/vnd.stardivision.writer" "sdw" "vor") 88 | ("application/vnd.stardivision.writer-global" "sgl") 89 | ("application/vnd.sun.xml.calc" "sxc") 90 | ("application/vnd.sun.xml.calc.template" "stc") 91 | ("application/vnd.sun.xml.draw" "sxd") 92 | ("application/vnd.sun.xml.draw.template" "std") 93 | ("application/vnd.sun.xml.impress" "sxi") 94 | ("application/vnd.sun.xml.impress.template" "sti") 95 | ("application/vnd.sun.xml.math" "sxm") 96 | ("application/vnd.sun.xml.writer" "sxw") 97 | ("application/vnd.sun.xml.writer.global" "sxg") 98 | ("application/vnd.sun.xml.writer.template" "stw") 99 | ("application/vnd.symbian.install" "sis") 100 | ("application/vnd.visio" "vsd") 101 | ("application/vnd.wap.wbxml" "wbxml") 102 | ("application/vnd.wap.wmlc" "wmlc") 103 | ("application/vnd.wap.wmlscriptc" "wmlsc") 104 | ("application/x-123" "wk") 105 | ("application/x-abiword" "abw") 106 | ("application/x-apple-diskimage" "dmg") 107 | ("application/x-bcpio" "bcpio") 108 | ("application/x-bittorrent" "torrent") 109 | ("application/x-cdf" "cdf") 110 | ("application/x-cdlink" "vcd") 111 | ("application/x-chess-pgn" "pgn") 112 | ("application/x-cpio" "cpio") 113 | ("application/x-csh" "csh") 114 | ("application/x-debian-package" "deb" "udeb") 115 | ("application/x-director" "dcr" "dir" "dxr") 116 | ("application/x-dms" "dms") 117 | ("application/x-doom" "wad") 118 | ("application/x-dvi" "dvi") 119 | ("application/x-flac" "flac") 120 | ("application/x-font" "pfa" "pfb" "gsf" "pcf") 121 | ("application/x-freemind" "mm") 122 | ("application/x-futuresplash" "spl") 123 | ("application/x-gnumeric" "gnumeric") 124 | ("application/x-go-sgf" "sgf") 125 | ("application/x-graphing-calculator" "gcf") 126 | ("application/x-gtar" "gtar" "tgz" "taz") 127 | ("application/x-hdf" "hdf") 128 | ("application/x-httpd-php" "phtml" "pht" "php") 129 | ("application/x-httpd-php-source" "phps") 130 | ("application/x-httpd-php3" "php3") 131 | ("application/x-httpd-php3-preprocessed" "php3p") 132 | ("application/x-httpd-php4" "php4") 133 | ("application/x-ica" "ica") 134 | ("application/x-internet-signup" "ins" "isp") 135 | ("application/x-iphone" "iii") 136 | ("application/x-iso9660-image" "iso") 137 | ("application/x-java-jnlp-file" "jnlp") 138 | ("application/x-javascript" "js") 139 | ("application/json" "json") 140 | ("application/x-jmol" "jmz") 141 | ("application/x-kchart" "chrt") 142 | ("application/x-killustrator" "kil") 143 | ("application/x-koan" "skp" "skd" "skt" "skm") 144 | ("application/x-kpresenter" "kpr" "kpt") 145 | ("application/x-kspread" "ksp") 146 | ("application/x-kword" "kwd" "kwt") 147 | ("application/x-latex" "latex") 148 | ("application/x-lha" "lha") 149 | ("application/x-lzh" "lzh") 150 | ("application/x-lzx" "lzx") 151 | ("application/x-maker" "frm" "maker" "frame" "fm" "fb" "book" "fbdoc") 152 | ("application/x-mif" "mif") 153 | ("application/x-ms-wmd" "wmd") 154 | ("application/x-ms-wmz" "wmz") 155 | ("application/x-msdos-program" "com" "exe" "bat" "dll") 156 | ("application/x-msi" "msi") 157 | ("application/x-netcdf" "nc") 158 | ("application/x-ns-proxy-autoconfig" "pac") 159 | ("application/x-nwc" "nwc") 160 | ("application/x-object" "o") 161 | ("application/x-oz-application" "oza") 162 | ("application/x-pkcs7-certreqresp" "p7r") 163 | ("application/x-pkcs7-crl" "crl") 164 | ("application/x-python-code" "pyc" "pyo") 165 | ("application/x-quicktimeplayer" "qtl") 166 | ("application/x-redhat-package-manager" "rpm") 167 | ("application/x-sh" "sh") 168 | ("application/x-shar" "shar") 169 | ("application/x-shockwave-flash" "swf" "swfl") 170 | ("application/x-stuffit" "sit") 171 | ("application/x-sv4cpio" "sv4cpio") 172 | ("application/x-sv4crc" "sv4crc") 173 | ("application/x-tar" "tar") 174 | ("application/x-tcl" "tcl") 175 | ("application/x-tex-gf" "gf") 176 | ("application/x-tex-pk" "pk") 177 | ("application/x-texinfo" "texinfo" "texi") 178 | ("application/x-trash" "~%" "" "bak" "old" "sik") 179 | ("application/x-troff" "tt" "r" "roff") 180 | ("application/x-troff-man" "man") 181 | ("application/x-troff-me" "me") 182 | ("application/x-troff-ms" "ms") 183 | ("application/x-ustar" "ustar") 184 | ("application/x-wais-source" "src") 185 | ("application/x-wingz" "wz") 186 | ("application/x-x509-ca-cert" "crt") 187 | ("application/x-xcf" "xcf") 188 | ("application/x-xfig" "fig") 189 | ("application/x-xpinstall" "xpi") 190 | ("audio/basic" "au" "snd") 191 | ("audio/midi" "mid" "midi" "kar") 192 | ("audio/mpeg" "mpga" "mpega" "mp2" "mp3" "m4a") 193 | ("audio/mpegurl" "m3u") 194 | ("audio/prs.sid" "sid") 195 | ("audio/x-aiff" "aif" "aiff" "aifc") 196 | ("audio/x-gsm" "gsm") 197 | ("audio/x-mpegurl" "m3u") 198 | ("audio/x-ms-wma" "wma") 199 | ("audio/x-ms-wax" "wax") 200 | ("audio/x-pn-realaudio" "ra" "rm" "ram") 201 | ("audio/x-realaudio" "ra") 202 | ("audio/x-scpls" "pls") 203 | ("audio/x-sd2" "sd2") 204 | ("audio/x-wav" "wav") 205 | ("chemical/x-alchemy" "alc") 206 | ("chemical/x-cache" "cac" "cache") 207 | ("chemical/x-cache-csf" "csf") 208 | ("chemical/x-cactvs-binary" "cbin" "cascii" "ctab") 209 | ("chemical/x-cdx" "cdx") 210 | ("chemical/x-cerius" "cer") 211 | ("chemical/x-chem3d" "c3d") 212 | ("chemical/x-chemdraw" "chm") 213 | ("chemical/x-cif" "cif") 214 | ("chemical/x-cmdf" "cmdf") 215 | ("chemical/x-cml" "cml") 216 | ("chemical/x-compass" "cpa") 217 | ("chemical/x-crossfire" "bsd") 218 | ("chemical/x-csml" "csml" "csm") 219 | ("chemical/x-ctx" "ctx") 220 | ("chemical/x-cxf" "cxf" "cef") 221 | ("chemical/x-embl-dl-nucleotide" "emb" "embl") 222 | ("chemical/x-galactic-spc" "spc") 223 | ("chemical/x-gamess-input" "inp" "gam" "gamin") 224 | ("chemical/x-gaussian-checkpoint" "fch" "fchk") 225 | ("chemical/x-gaussian-cube" "cub") 226 | ("chemical/x-gaussian-input" "gau" "gjc" "gjf") 227 | ("chemical/x-gaussian-log" "gal") 228 | ("chemical/x-gcg8-sequence" "gcg") 229 | ("chemical/x-genbank" "gen") 230 | ("chemical/x-hin" "hin") 231 | ("chemical/x-isostar" "istr" "ist") 232 | ("chemical/x-jcamp-dx" "jdx" "dx") 233 | ("chemical/x-kinemage" "kin") 234 | ("chemical/x-macmolecule" "mcm") 235 | ("chemical/x-macromodel-input" "mmd" "mmod") 236 | ("chemical/x-mdl-molfile" "mol") 237 | ("chemical/x-mdl-rdfile" "rd") 238 | ("chemical/x-mdl-rxnfile" "rxn") 239 | ("chemical/x-mdl-sdfile" "sd" "sdf") 240 | ("chemical/x-mdl-tgf" "tgf") 241 | ("chemical/x-mmcif" "mcif") 242 | ("chemical/x-mol2" "mol2") 243 | ("chemical/x-molconn-Z" "b") 244 | ("chemical/x-mopac-graph" "gpt") 245 | ("chemical/x-mopac-input" "mop" "mopcrt" "mpc" "dat" "zmt") 246 | ("chemical/x-mopac-out" "moo") 247 | ("chemical/x-mopac-vib" "mvb") 248 | ("chemical/x-ncbi-asn1" "asn") 249 | ("chemical/x-ncbi-asn1-ascii" "prt" "ent") 250 | ("chemical/x-ncbi-asn1-binary" "val" "aso") 251 | ("chemical/x-ncbi-asn1-spec" "asn") 252 | ("chemical/x-pdb" "pdb" "ent") 253 | ("chemical/x-rosdal" "ros") 254 | ("chemical/x-swissprot" "sw") 255 | ("chemical/x-vamas-iso14976" "vms") 256 | ("chemical/x-vmd" "vmd") 257 | ("chemical/x-xtel" "xtel") 258 | ("chemical/x-xyz" "xyz") 259 | ("image/gif" "gif") 260 | ("image/ief" "ief") 261 | ("image/jpeg" "jpeg" "jpg" "jpe") 262 | ("image/pcx" "pcx") 263 | ("image/png" "png") 264 | ("image/svg+xml" "svg" "svgz") 265 | ("image/tiff" "tiff" "tif") 266 | ("image/vnd.djvu" "djvu" "djv") 267 | ("image/vnd.wap.wbmp" "wbmp") 268 | ("image/x-cmu-raster" "ras") 269 | ("image/x-coreldraw" "cdr") 270 | ("image/x-coreldrawpattern" "pat") 271 | ("image/x-coreldrawtemplate" "cdt") 272 | ("image/x-corelphotopaint" "cpt") 273 | ("image/x-icon" "ico") 274 | ("image/x-jg" "art") 275 | ("image/x-jng" "jng") 276 | ("image/x-ms-bmp" "bmp") 277 | ("image/x-photoshop" "psd") 278 | ("image/x-portable-anymap" "pnm") 279 | ("image/x-portable-bitmap" "pbm") 280 | ("image/x-portable-graymap" "pgm") 281 | ("image/x-portable-pixmap" "ppm") 282 | ("image/x-rgb" "rgb") 283 | ("image/x-xbitmap" "xbm") 284 | ("image/x-xpixmap" "xpm") 285 | ("image/x-xwindowdump" "xwd") 286 | ("model/iges" "igs" "iges") 287 | ("model/mesh" "msh" "mesh" "silo") 288 | ("model/vrml" "wrl" "vrml") 289 | ("text/calendar" "ics" "icz") 290 | ("text/comma-separated-values" "csv") 291 | ("text/css" "css") 292 | ("text/h323" "323") 293 | ("text/html" "html" "htm" "shtml") 294 | ("text/iuls" "uls") 295 | ("text/mathml" "mml") 296 | ("text/plain" "asc" "txt" "text" "diff" "pot") 297 | ("text/richtext" "rtx") 298 | ("text/rtf" "rtf") 299 | ("text/scriptlet" "sct" "wsc") 300 | ("text/texmacs" "tm" "ts") 301 | ("text/tab-separated-values" "tsv") 302 | ("text/vnd.sun.j2me.app-descriptor" "jad") 303 | ("text/vnd.wap.wml" "wml") 304 | ("text/vnd.wap.wmlscript" "wmls") 305 | ("text/x-bibtex" "bib") 306 | ("text/x-boo" "boo") 307 | ("text/x-c++hdr" "h++" "hpp" "hxx" "hh") 308 | ("text/x-c++src" "c++" "cpp" "cxx" "cc") 309 | ("text/x-chdr" "h") 310 | ("text/x-component" "htc") 311 | ("text/x-csh" "csh") 312 | ("text/x-csrc" "c") 313 | ("text/x-dsrc" "d") 314 | ("text/x-haskell" "hs") 315 | ("text/x-java" "java") 316 | ("text/javascript" "js") 317 | ("text/x-literate-haskell" "lhs") 318 | ("text/x-moc" "moc") 319 | ("text/x-pascal" "pp" "as") 320 | ("text/x-pcs-gcd" "gcd") 321 | ("text/x-perl" "pl" "pm") 322 | ("text/x-python" "py") 323 | ("text/x-setext" "etx") 324 | ("text/x-sh" "sh") 325 | ("text/x-tcl" "tcl" "tk") 326 | ("text/x-tex" "tex" "ltx" "sty" "cls") 327 | ("text/x-vcalendar" "vcs") 328 | ("text/x-vcard" "vcf") 329 | ("video/dl" "dl") 330 | ("video/dv" "dif" "dv") 331 | ("video/fli" "fli") 332 | ("video/gl" "gl") 333 | ("video/mpeg" "mpeg" "mpg" "mpe") 334 | ("video/mp4" "mp4") 335 | ("video/quicktime" "qt" "mov") 336 | ("video/vnd.mpegurl" "mxu") 337 | ("video/x-la-asf" "lsf" "lsx") 338 | ("video/x-mng" "mng") 339 | ("video/x-ms-asf" "asf" "asx") 340 | ("video/x-ms-wm" "wm") 341 | ("video/x-ms-wmv" "wmv") 342 | ("video/x-ms-wmx" "wmx") 343 | ("video/x-ms-wvx" "wvx") 344 | ("video/x-msvideo" "avi") 345 | ("video/x-sgi-movie" "movie") 346 | ("x-conference/x-cooltalk" "ice") 347 | ("x-world/x-vrml" "vrm" "vrml" "wrl")) 348 | "An alist where the cars are MIME types and the cdrs are lists 349 | of file suffixes for the corresponding type.") 350 | 351 | (defparameter *mime-type-hash* 352 | (let ((hash (make-hash-table :test #'equalp))) 353 | (loop for (type . suffixes) in *mime-type-list* do 354 | (loop for suffix in suffixes do 355 | (setf (gethash suffix hash) type))) 356 | hash) 357 | "A hash table which maps file suffixes to MIME types.") 358 | 359 | (defun guess-mime-type (extension) 360 | (or (gethash extension *mime-type-hash*) "application/octet-stream")) -------------------------------------------------------------------------------- /notes.txt: -------------------------------------------------------------------------------- 1 | -*- mode: markup; -*- 2 | 3 | * What I did 4 | 5 | ** Gross stripping 6 | 7 | Senselessly removing all :documentation just to have less to look at. 8 | 9 | De-genericizing. 10 | 11 | * Reorganization ideas 12 | 13 | Acceptor should not know about SSL—or maybe it should and we should 14 | get rid of SSL acceptor; the acceptor can be parameterized with 15 | something that changes the default port and which replaces the stream. 16 | 17 | My send-headers-and-wrap stream should be built in—there should be an 18 | easy way for a response generator to specify that it wants a bivalent 19 | stream. Or maybe setting an external format on the reply should cause 20 | it to happen. (Hmmm, perhaps the right place is for SEND-HEADERS to 21 | take an argument saying what kind of stream it wants. The default 22 | could be a bivalent stream and you could specify :binary t to save the 23 | cost of creating the flexistream.) 24 | 25 | Mime-type data should be moved out of code. 26 | 27 | Perhaps the reply and request objects should be passed in to handler 28 | functions rather than as special variables. 29 | 30 | * To do 31 | 32 | Get rid of foo* functions. (Will presumably happen if *reply* and *request* are passed explicitly. 33 | 34 | Where is the proper place for session handling? Get rid of sessions 35 | machinery? 36 | 37 | Break out logging into a separate object. 38 | 39 | Possibly combine request and reply objects into a single object. 40 | 41 | * Threading 42 | 43 | create-request-handler-thread assumes that we will create 44 | 45 | * Bugs? 46 | 47 | If you connect to an SSL acceptor with HTTP it hangs. Seems like something else should happen. 48 | 49 | * Things a user may want to configure or customize. 50 | 51 | ** Dispatching 52 | 53 | Acceptor reads an HTTP request and populates the request/reply object. 54 | Then what code runs is up to a higher level dispatcher. We may want to 55 | provide some simple ones. 56 | 57 | ** Error pages 58 | 59 | When a request is handled, it may abort the handling of the request 60 | with an HTTP status code indicating an error. The handlers should not 61 | have to worry about generating an appropriate error page. There should 62 | be a default error handler that generates Toot-branded error pages and 63 | there should be an easy way to provide your own code to generate error 64 | pages. 65 | 66 | Logging (where to and what format) 67 | 68 | 69 | * Flow 70 | 71 | [acceptor] start -> 72 | [taskmaster] execute-acceptor -> 73 | [acceptor] accept-connections (in new thread) -> 74 | [taskmaster] handle-incoming-connection -> 75 | [acceptor] process-connection (in new thread for each connection)-> 76 | [request] process-request (in loop) -> 77 | dispatch to user code. 78 | 79 | * Response generation 80 | 81 | process-request calls start-output to send an http-internal-server-error 82 | 83 | send-headers calls start-output with no content 84 | 85 | start-output calls send-response 86 | 87 | * Random ideas 88 | 89 | Instead of a handler just being able to return a string, perhaps it 90 | can return any object for which there are methods defined that can 91 | figure out how to render it and what the size of the rendering will 92 | be. 93 | 94 | (defgeneric render-body (object stream)) 95 | 96 | (defmethod render-body ((object string) stream) 97 | (write-string object stream)) 98 | 99 | * Renaming 100 | 101 | headers-in -> request-headers 102 | header-in -> request-header 103 | headers-out -> reply-headers 104 | header-out -> reply-header 105 | return-code -> http-status-code or status-code 106 | 107 | * For docs 108 | 109 | Note that server-protocol is taken from the request line so is 110 | something like :http/1.1 or :http/1.0. It will be one of thes even if 111 | the request was made over HTTPS. 112 | 113 | 114 | * Reading post data 115 | 116 | post-parameters -> maybe-read-post-parameters -> raw-post-data -> read-request-body 117 | 118 | maybe-read-post-parameters -> parse-multipart-form-data -> parse-rfc2388-form-data 119 | 120 | 121 | 1. Request comes in. 122 | 123 | 2. Read headers. Stream is sitting at body. Handler is invoked. 124 | 125 | 3. Handler code may: 126 | 127 | 1. Ask for post parameters. Toot reads and parses them. Stores alist 128 | in request object for later retrieving individual parameters. If the 129 | request is multipart/form the post-parameters values will contain 130 | lists including the name of the tmp file where the file upload 131 | elements were saved. 132 | 133 | 2. Ask for the stream. Give it to them. They can do whatever they 134 | want. 135 | 136 | 3. Ignore the post data. Do nothing. 137 | 138 | 4. Request has been handled. Drain stream and discard. 139 | 140 | 141 | * To do: 142 | 143 | charset, external-format, encoding audit 144 | 145 | * Logging 146 | 147 | See this for Apache compatibility http://httpd.apache.org/docs/1.3/mod/mod_log_config.html#formats 148 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :cl-user) 29 | 30 | (defpackage :toot 31 | (:documentation "A very simple web server.") 32 | (:use :cl 33 | :alexandria 34 | :bordeaux-threads 35 | :chunga 36 | :cl-ppcre 37 | :flexi-streams 38 | :puri) 39 | (:shadow :defconstant) 40 | ;; see asdf system definition 41 | (:import-from :toot-asd :*toot-version*) 42 | (:export 43 | 44 | :*toot-version* 45 | 46 | :acceptor 47 | :stream-logger 48 | :static-file-handler 49 | :safe-pathname-p 50 | :add-index 51 | 52 | ;; Generic functions 53 | :handle-request 54 | :generate-error-page 55 | 56 | ;; Starting and stopping acceptor 57 | :start-server 58 | :start-acceptor 59 | :stop-acceptor 60 | 61 | ;; Configurable parts of acceptor 62 | :port 63 | :address 64 | :name 65 | :persistent-connections-p 66 | :read-timeout 67 | :write-timeout 68 | 69 | ;; Pluggable parts of acceptor 70 | :handler 71 | :error-generator 72 | :access-logger 73 | :message-logger 74 | :taskmaster 75 | 76 | ;; To use in handlers 77 | :serve-file 78 | :abort-request-handler 79 | :no-cache 80 | :redirect 81 | :handle-if-modified-since 82 | :handle-range 83 | :require-authorization 84 | :with-response-body 85 | ;;:headers-sent-p 86 | :response-sent-p 87 | ;; Query the request 88 | :request-method 89 | :request-uri 90 | :server-protocol 91 | :request-header 92 | :request-headers 93 | :remote-addr 94 | :remote-port 95 | :real-remote-addr 96 | :authorization 97 | :get-parameters 98 | 99 | ;; Three ways to get at the body of the request 100 | :post-parameters 101 | :body-octets 102 | :body-stream 103 | 104 | ;; Slightly higher level access to parameters 105 | :get-parameter 106 | :post-parameter 107 | :parameter 108 | 109 | ;; Incoming cookies 110 | :cookie-value 111 | :cookies-in 112 | 113 | ;; Control the response 114 | :send-headers 115 | :content-length 116 | :content-type 117 | :response-header 118 | :set-cookie 119 | :status-code 120 | 121 | ;; Utilities 122 | :escape-for-html 123 | :url-decode 124 | :url-encode 125 | :reason-phrase 126 | 127 | ;; Conditions -- I'm not sure these need to be exported. Does 128 | ;; anyone ever need to handle them specifically? If so, I need to 129 | ;; understand under what circumstances and document them. 130 | 131 | ;;:toot-condition 132 | ;;:toot-error 133 | ;;:toot-warning 134 | ;;:parameter-error 135 | 136 | ;; Taskmaster API 137 | ;;:execute-acceptor 138 | ;;:handle-incoming-connection 139 | ;;:shutdown 140 | 141 | ;; Special vars 142 | :*debug-errors-p* 143 | :*default-connection-timeout* 144 | :*default-content-type* 145 | :*default-external-format* 146 | :*header-stream* 147 | :*lisp-errors-log-level* 148 | :*lisp-warnings-log-level* 149 | :*log-lisp-backtraces-p* 150 | :*log-lisp-errors-p* 151 | :*log-lisp-warnings-p* 152 | :*show-lisp-backtraces-p* 153 | :*show-lisp-errors-p* 154 | :*tmp-directory* 155 | 156 | ;; These are thin wrappers around the corresponding PURI functions. 157 | :request-scheme 158 | :request-host 159 | :request-port 160 | :request-path 161 | :request-query 162 | :request-authority 163 | 164 | ;; HTTP status codes 165 | :+http-accepted+ 166 | :+http-authorization-required+ 167 | :+http-bad-gateway+ 168 | :+http-bad-request+ 169 | :+http-conflict+ 170 | :+http-continue+ 171 | :+http-created+ 172 | :+http-expectation-failed+ 173 | :+http-failed-dependency+ 174 | :+http-forbidden+ 175 | :+http-gateway-time-out+ 176 | :+http-gone+ 177 | :+http-internal-server-error+ 178 | :+http-length-required+ 179 | :+http-method-not-allowed+ 180 | :+http-moved-permanently+ 181 | :+http-moved-temporarily+ 182 | :+http-multi-status+ 183 | :+http-multiple-choices+ 184 | :+http-no-content+ 185 | :+http-non-authoritative-information+ 186 | :+http-not-acceptable+ 187 | :+http-not-found+ 188 | :+http-not-implemented+ 189 | :+http-not-modified+ 190 | :+http-ok+ 191 | :+http-partial-content+ 192 | :+http-payment-required+ 193 | :+http-precondition-failed+ 194 | :+http-proxy-authentication-required+ 195 | :+http-request-entity-too-large+ 196 | :+http-request-time-out+ 197 | :+http-request-uri-too-large+ 198 | :+http-requested-range-not-satisfiable+ 199 | :+http-reset-content+ 200 | :+http-see-other+ 201 | :+http-service-unavailable+ 202 | :+http-switching-protocols+ 203 | :+http-temporary-redirect+ 204 | :+http-unsupported-media-type+ 205 | :+http-use-proxy+ 206 | :+http-version-not-supported+)) 207 | 208 | (defpackage :toot-tests 209 | (:documentation "Sanity tests for Toot.") 210 | (:use :cl :toot)) 211 | -------------------------------------------------------------------------------- /rfc2388.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2003 Janis Dzerins 2 | ;;;; Modifications for TBNL Copyright (c) 2004 Michael Weber and Dr. Edmund Weitz 3 | ;;;; Further modifications for Toot Copyright (c) 2011, Peter Seibel. All rights reserved. 4 | 5 | ;;;; 6 | ;;;; Redistribution and use in source and binary forms, with or 7 | ;;;; without modification, are permitted provided that the following 8 | ;;;; conditions are met: 9 | ;;;; 10 | ;;;; 1. Redistributions of source code must retain the above copyright 11 | ;;;; notice, this list of conditions and the following disclaimer. 12 | ;;;; 13 | ;;;; 2. Redistributions in binary form must reproduce the above 14 | ;;;; copyright notice, this list of conditions and the following 15 | ;;;; disclaimer in the documentation and/or other materials 16 | ;;;; provided with the distribution. 17 | ;;;; 18 | ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS 19 | ;;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 21 | ;;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE 22 | ;;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 23 | ;;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 24 | ;;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 25 | ;;;; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 28 | ;;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 29 | ;;;; DAMAGE. 30 | 31 | (in-package :toot) 32 | 33 | ;;; Utility functions 34 | 35 | (defun lwsp-char-p (char) 36 | "Returns true if CHAR is a linear-whitespace-char (LWSP-char). Either 37 | space or tab, in short." 38 | (or (char= char #\space) 39 | (char= char #\tab))) 40 | 41 | 42 | ;;; *** This actually belongs to RFC2046 43 | ;;; 44 | (defun read-until-next-boundary (stream boundary &optional discard out-stream) 45 | "Reads from STREAM up to the next boundary. Returns two values: read 46 | data (nil if DISCARD is true), and true if the boundary is not last 47 | (i.e., there's more data)." 48 | ;; Read until [CRLF]--boundary[--][transport-padding]CRLF 49 | ;; States: 1 2 345 67 8 9 10 50 | ;; 51 | ;; *** This will WARN like crazy on some bad input -- should only do each 52 | ;; warning once. 53 | 54 | (let ((length (length boundary))) 55 | (unless (<= 1 length 70) 56 | (warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length)) 57 | (when (lwsp-char-p (schar boundary (1- length))) 58 | (warn "Boundary has trailing whitespace: ~S" boundary))) 59 | 60 | (flet ((run (result) 61 | "This one writes everything up to a boundary to RESULT stream, 62 | and returns false if the closing delimiter has been read, and 63 | true otherwise." 64 | (let ((state 1) 65 | (boundary-index 0) 66 | (boundary-length (length boundary)) 67 | (closed nil) 68 | (queued-chars (make-string 4)) 69 | (queue-index 0) 70 | char 71 | (leave-char nil)) 72 | 73 | (flet ((write-queued-chars () 74 | (dotimes (i queue-index) 75 | (write-char (schar queued-chars i) result)) 76 | (setf queue-index 0)) 77 | 78 | (enqueue-char () 79 | (setf (schar queued-chars queue-index) char) 80 | (incf queue-index))) 81 | 82 | (loop 83 | 84 | (if leave-char 85 | (setq leave-char nil) 86 | (setq char (read-char stream nil nil))) 87 | 88 | (unless char 89 | (setq closed t) 90 | (return)) 91 | 92 | #-(and) 93 | (format t "~&S:~D QI:~D BI:~2,'0D CH:~:[~;*~]~S~%" 94 | state queue-index boundary-index leave-char char) 95 | 96 | (case state 97 | (1 ;; optional starting CR 98 | (cond ((char= char #\return) 99 | (enqueue-char) 100 | (setq state 2)) 101 | ((char= char #\-) 102 | (setq leave-char t 103 | state 3)) 104 | (t 105 | (write-char char result)))) 106 | 107 | (2 ;; optional starting LF 108 | (cond ((char= char #\linefeed) 109 | (enqueue-char) 110 | (setq state 3)) 111 | (t 112 | (write-queued-chars) 113 | (setq leave-char t 114 | state 1)))) 115 | 116 | (3 ;; first dash in dash-boundary 117 | (cond ((char= char #\-) 118 | (enqueue-char) 119 | (setq state 4)) 120 | (t 121 | (write-queued-chars) 122 | (setq leave-char t 123 | state 1)))) 124 | 125 | (4 ;; second dash in dash-boundary 126 | (cond ((char= char #\-) 127 | (enqueue-char) 128 | (setq state 5)) 129 | (t 130 | (write-queued-chars) 131 | (setq leave-char t 132 | state 1)))) 133 | 134 | (5 ;; boundary 135 | (cond ((char= char (schar boundary boundary-index)) 136 | (incf boundary-index) 137 | (when (= boundary-index boundary-length) 138 | (setq state 6))) 139 | (t 140 | (write-queued-chars) 141 | (write-sequence boundary result :end boundary-index) 142 | (setq boundary-index 0 143 | leave-char t 144 | state 1)))) 145 | 146 | (6 ;; first dash in close-delimiter 147 | (cond ((char= char #\-) 148 | (setq state 7)) 149 | (t 150 | (setq leave-char t) 151 | (setq state 8)))) 152 | 153 | (7 ;; second dash in close-delimiter 154 | (cond ((char= char #\-) 155 | (setq closed t 156 | state 8)) 157 | (t 158 | ;; this is a strange situation -- only two dashes, linear 159 | ;; whitespace or CR is allowed after boundary, but there was 160 | ;; a single dash... One thing is clear -- this is not a 161 | ;; close-delimiter. Hence this is garbage what we're looking 162 | ;; at! 163 | (warn "Garbage where expecting close-delimiter!") 164 | (setq leave-char t) 165 | (setq state 8)))) 166 | 167 | (8 ;; transport-padding (LWSP* == [#\space #\tab]*) 168 | (cond ((lwsp-char-p char) 169 | ;; ignore these 170 | ) 171 | (t 172 | (setq leave-char t) 173 | (setq state 9)))) 174 | 175 | (9 ;; CR 176 | (cond ((char= char #\return) 177 | (setq state 10)) 178 | (t 179 | (warn "Garbage where expecting CR!")))) 180 | 181 | (10 ;; LF 182 | (cond ((char= char #\linefeed) 183 | ;; the end 184 | (return)) 185 | (t 186 | (warn "Garbage where expecting LF!"))))))) 187 | (not closed)))) 188 | 189 | (if discard 190 | (let ((stream (make-broadcast-stream))) 191 | (values nil (run stream))) 192 | (let* ((stream (or out-stream (make-string-output-stream))) 193 | (closed (run stream))) 194 | (values (or out-stream (get-output-stream-string stream)) 195 | closed))))) 196 | ;;; Header parsing 197 | 198 | (defstruct (header (:type list) 199 | (:constructor make-header (name value parameters))) 200 | name 201 | value 202 | parameters) 203 | 204 | (defun skip-linear-whitespace (string &key (start 0) end) 205 | "Returns the position of first non-linear-whitespace character in STRING 206 | bound by START and END." 207 | (position-if-not #'lwsp-char-p string :start start :end end)) 208 | 209 | (defgeneric parse-header (source &optional start-state) 210 | (:documentation "Parses SOURCE and returs a single MIME header. 211 | 212 | Header is a list of the form (NAME VALUE PARAMETERS), PARAMETERS 213 | is a list of (NAME . VALUE)")) 214 | 215 | 216 | (defmethod parse-header ((source string) &optional (start-state :name)) 217 | (with-input-from-string (in source) 218 | (parse-header in start-state))) 219 | 220 | 221 | ;;; *** I don't like this parser -- it will have to be rewritten when I 222 | ;;; make my state-machine parser-generator macro! 223 | ;;; 224 | (defmethod parse-header ((stream stream) &optional (start-state :name)) 225 | "Returns a MIME part header, or NIL, if there is no header. Header is 226 | terminated by CRLF." 227 | (let ((state (ecase start-state 228 | (:name 1) 229 | (:value 2) 230 | (:parameters 3))) 231 | (result (make-string-output-stream)) 232 | char 233 | (leave-char nil) 234 | name 235 | value 236 | parameter-name 237 | parameters) 238 | 239 | (labels ((skip-lwsp (next-state) 240 | (loop 241 | do (setq char (read-char stream nil nil)) 242 | while (and char (lwsp-char-p char))) 243 | (setq leave-char t 244 | state next-state)) 245 | 246 | (collect-parameter () 247 | (push (cons parameter-name 248 | (get-output-stream-string result)) 249 | parameters) 250 | (setq parameter-name nil) 251 | (skip-lwsp 3)) 252 | 253 | (token-end-char-p (char) 254 | (or (char= char #\;) 255 | (lwsp-char-p char)))) 256 | 257 | (loop 258 | 259 | (if leave-char 260 | (setq leave-char nil) 261 | (setq char (read-char stream nil nil))) 262 | 263 | ;; end of stream 264 | (unless char 265 | (return)) 266 | 267 | (when (char= #\return char) 268 | (setq char (read-char stream nil nil)) 269 | (cond ((or (null char) 270 | (char= #\linefeed char)) 271 | ;; CRLF ends the input 272 | (return)) 273 | (t 274 | (warn "LINEFEED without RETURN in header.") 275 | (write-char #\return result) 276 | (setq leave-char t)))) 277 | 278 | #-(and) 279 | (format t "~&S:~,'0D CH:~:[~;*~]~S~%" 280 | state leave-char char) 281 | 282 | (ecase state 283 | (1 ;; NAME 284 | (cond ((char= char #\:) 285 | ;; end of name 286 | (setq name (get-output-stream-string result)) 287 | (skip-lwsp 2)) 288 | (t 289 | (write-char char result)))) 290 | 291 | (2 ;; VALUE 292 | (cond ((token-end-char-p char) 293 | (setq value (get-output-stream-string result)) 294 | (skip-lwsp 3)) 295 | (t 296 | (write-char char result)))) 297 | 298 | (3 ;; PARAMETER name 299 | (cond ((char= #\= char) 300 | (setq parameter-name (get-output-stream-string result) 301 | state 4)) 302 | (t 303 | (write-char char result)))) 304 | 305 | (4 ;; PARAMETER value start 306 | (cond ((char= #\" char) 307 | (setq state 5)) 308 | (t 309 | (setq leave-char t 310 | state 7)))) 311 | 312 | (5 ;; Quoted PARAMETER value 313 | (cond ((char= #\" char) 314 | (setq state 6)) 315 | (t 316 | (write-char char result)))) 317 | 318 | (6 ;; End of quoted PARAMETER value 319 | (cond ((token-end-char-p char) 320 | (collect-parameter)) 321 | (t 322 | ;; no space or semicolon after quoted parameter value 323 | (setq leave-char t 324 | state 3)))) 325 | 326 | (7 ;; Unquoted PARAMETER value 327 | (cond ((token-end-char-p char) 328 | (collect-parameter)) 329 | (t 330 | (write-char char result)))))) 331 | 332 | (case state 333 | (1 334 | (setq name (get-output-stream-string result))) 335 | (2 336 | (setq value (get-output-stream-string result))) 337 | ((3 4) 338 | (let ((name (get-output-stream-string result))) 339 | (unless (zerop (length name)) 340 | (warn "Parameter without value in header.") 341 | (push (cons name nil) parameters)))) 342 | ((5 6 7) 343 | (push (cons parameter-name (get-output-stream-string result)) parameters)))) 344 | 345 | (if (and (or (null name) 346 | (zerop (length name))) 347 | (null value) 348 | (null parameters)) 349 | nil 350 | (make-header name value parameters)))) 351 | 352 | ;;; _The_ MIME parsing 353 | 354 | (defgeneric parse-mime (source boundary tmp-filename-generator) 355 | (:documentation 356 | "Parses MIME entities, returning them as a list. Each element in the 357 | list is of form: (body headers), where BODY is the contents of MIME 358 | part, and HEADERS are all headers for that part. BOUNDARY is a string 359 | used to separate MIME entities.")) 360 | 361 | 362 | (defstruct (content-type (:type list) 363 | (:constructor make-content-type (super sub))) 364 | super 365 | sub) 366 | 367 | (defun parse-content-type (string) 368 | "Returns content-type which is parsed from STRING." 369 | (let ((sep-offset (position #\/ string)) 370 | (type (array-element-type string))) 371 | (if (numberp sep-offset) 372 | (make-content-type (make-array sep-offset 373 | :element-type type 374 | :displaced-to string) 375 | (make-array (- (length string) (incf sep-offset)) 376 | :element-type type 377 | :displaced-to string 378 | :displaced-index-offset sep-offset)) 379 | (make-content-type string nil)))) 380 | 381 | 382 | (defun unparse-content-type (ct) 383 | "Returns content-type CT in string representation." 384 | (let ((super (content-type-super ct)) 385 | (sub (content-type-sub ct))) 386 | (cond ((and super sub) 387 | (concatenate 'string super "/" sub)) 388 | (t (or super ""))))) 389 | 390 | (defstruct (mime-part (:type list) 391 | (:constructor make-mime-part (contents headers))) 392 | contents 393 | headers) 394 | 395 | 396 | (defmethod parse-mime ((input string) separator tmp-filename-generator) 397 | (with-input-from-string (stream input) 398 | (parse-mime stream separator tmp-filename-generator))) 399 | 400 | (defmethod parse-mime ((input stream) boundary tmp-filename-generator) 401 | ;; Find the first boundary. Return immediately if it is also the last 402 | ;; one. 403 | (unless (nth-value 1 (read-until-next-boundary input boundary t)) 404 | (return-from parse-mime nil)) 405 | 406 | (let ((result ())) 407 | (loop 408 | (let ((headers (loop 409 | for header = (parse-header input) 410 | while header 411 | when (string-equal "CONTENT-TYPE" (header-name header)) 412 | do (setf (header-value header) (parse-content-type (header-value header))) 413 | collect header))) 414 | (let ((file-name (get-file-name headers))) 415 | (cond ((and tmp-filename-generator file-name) 416 | (let ((temp-file (funcall tmp-filename-generator))) 417 | (multiple-value-bind (text more) 418 | (with-open-file (out-file (ensure-directories-exist temp-file) 419 | :direction :output 420 | ;; external format for faithful I/O 421 | ;; see 422 | #+(or :sbcl :lispworks :allegro :openmcl) 423 | :external-format 424 | #+sbcl :latin-1 425 | #+:lispworks '(:latin-1 :eol-style :lf) 426 | #+:allegro (excl:crlf-base-ef :latin1) 427 | #+:openmcl '(:character-encoding :iso-8859-1 428 | :line-termination :unix)) 429 | (read-until-next-boundary input boundary nil out-file)) 430 | (declare (ignore text)) 431 | (when (and (stringp file-name) (plusp (length file-name))) 432 | (push (make-mime-part temp-file headers) result)) 433 | (when (not more) 434 | (return))))) 435 | (t 436 | (multiple-value-bind (text more) 437 | (read-until-next-boundary input boundary) 438 | (push (make-mime-part text headers) result) 439 | (when (not more) 440 | (return)))))))) 441 | (nreverse result))) 442 | 443 | 444 | (defun find-header (label headers) 445 | "Find header by label from set of headers." 446 | (find label headers :key #'header-name :test #'string-equal)) 447 | 448 | 449 | (defun find-parameter (name params) 450 | "Find header parameter by name from set of parameters." 451 | (assoc name params :test #'string-equal)) 452 | 453 | 454 | (defun mime-content-type (part &key as-string) 455 | "Returns the Content-Type header of mime-part PART." 456 | (let ((header (find-header "CONTENT-TYPE" (mime-part-headers part)))) 457 | (if header 458 | (if as-string 459 | (or (unparse-content-type (header-value header)) "") 460 | (header-value header)) 461 | (when as-string "")))) 462 | 463 | 464 | (defun find-content-disposition-header (headers) 465 | (find-if (lambda (header) 466 | (and (string-equal "CONTENT-DISPOSITION" (header-name header)) 467 | (string-equal "FORM-DATA" (header-value header)))) 468 | headers)) 469 | 470 | 471 | (defun get-file-name (headers) 472 | (cdr (find-parameter "FILENAME" 473 | (header-parameters (find-content-disposition-header headers))))) -------------------------------------------------------------------------------- /set-timeouts.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (defun set-timeouts (usocket read-timeout write-timeout) 31 | "Sets up timeouts on the given USOCKET object. READ-TIMEOUT is the 32 | read timeout period, WRITE-TIMEOUT is the write timeout, specified in 33 | \(fractional) seconds. The timeouts can either be implemented using 34 | the low-level socket options SO_RCVTIMEO and SO_SNDTIMEO or some 35 | other, implementation specific mechanism. On platforms that do not 36 | support separate read and write timeouts, both must be equal or an 37 | error will be signaled. READ-TIMEOUT and WRITE-TIMEOUT may be NIL, 38 | which means that the corresponding socket timeout value will not be 39 | set." 40 | (declare (ignorable usocket read-timeout write-timeout)) 41 | ;; add other Lisps here if necessary 42 | #+(or :sbcl :cmu) 43 | (unless (eql read-timeout write-timeout) 44 | (parameter-error "Read and write timeouts for socket must be equal.")) 45 | #+:clisp 46 | (when read-timeout 47 | (socket:socket-options (usocket:socket usocket) :SO-RCVTIMEO read-timeout)) 48 | #+:clisp 49 | (when write-timeout 50 | (socket:socket-options (usocket:socket usocket) :SO-SNDTIMEO write-timeout)) 51 | #+:ecl 52 | (when write-timeout 53 | (setf (sb-bsd-sockets:sockopt-send-timeout (usocket:socket usocket)) write-timeout)) 54 | #+:ecl 55 | (when read-timeout 56 | (setf (sb-bsd-sockets:sockopt-receive-timeout (usocket:socket usocket)) read-timeout)) 57 | #+:openmcl 58 | (when read-timeout 59 | (setf (ccl:stream-input-timeout (usocket:socket usocket)) read-timeout)) 60 | #+:openmcl 61 | (when write-timeout 62 | (setf (ccl:stream-output-timeout (usocket:socket usocket)) write-timeout)) 63 | #+:sbcl 64 | (when read-timeout 65 | (setf (sb-impl::fd-stream-timeout (usocket:socket-stream usocket)) 66 | (coerce read-timeout 'single-float))) 67 | #+:cmu 68 | (setf (lisp::fd-stream-timeout (usocket:socket-stream usocket)) 69 | (coerce read-timeout 'integer)) 70 | #-(or :clisp :ecl :openmcl :sbcl :cmu) 71 | (not-implemented 'set-timeouts)) 72 | -------------------------------------------------------------------------------- /specials.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (defmacro defconstant (name value &optional doc) 31 | "Make sure VALUE is evaluated only once \(to appease SBCL)." 32 | `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) 33 | ,@(when doc (list doc)))) 34 | 35 | (eval-when (:compile-toplevel :execute :load-toplevel) 36 | (defvar *http-reason-phrase-map* (make-hash-table) 37 | "Used to map numerical return codes to reason phrases.") 38 | 39 | (defmacro def-http-status-code (name value reason-phrase) 40 | "Shortcut to define constants for return codes. NAME is a 41 | Lisp symbol, VALUE is the numerical value of the return code, and 42 | REASON-PHRASE is the phrase \(a string) to be shown in the 43 | server's status line." 44 | `(eval-when (:compile-toplevel :execute :load-toplevel) 45 | (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'." 46 | value reason-phrase)) 47 | (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase)))) 48 | 49 | (defconstant +crlf+ 50 | (make-array 2 :element-type '(unsigned-byte 8) 51 | :initial-contents (mapcar 'char-code '(#\Return #\Linefeed))) 52 | "A 2-element array consisting of the character codes for a CRLF 53 | sequence.") 54 | 55 | (def-http-status-code +http-continue+ 100 "Continue") 56 | (def-http-status-code +http-switching-protocols+ 101 "Switching Protocols") 57 | (def-http-status-code +http-ok+ 200 "OK") 58 | (def-http-status-code +http-created+ 201 "Created") 59 | (def-http-status-code +http-accepted+ 202 "Accepted") 60 | (def-http-status-code +http-non-authoritative-information+ 203 "Non-Authoritative Information") 61 | (def-http-status-code +http-no-content+ 204 "No Content") 62 | (def-http-status-code +http-reset-content+ 205 "Reset Content") 63 | (def-http-status-code +http-partial-content+ 206 "Partial Content") 64 | (def-http-status-code +http-multi-status+ 207 "Multi-Status") 65 | (def-http-status-code +http-multiple-choices+ 300 "Multiple Choices") 66 | (def-http-status-code +http-moved-permanently+ 301 "Moved Permanently") 67 | (def-http-status-code +http-moved-temporarily+ 302 "Moved Temporarily") 68 | (def-http-status-code +http-see-other+ 303 "See Other") 69 | (def-http-status-code +http-not-modified+ 304 "Not Modified") 70 | (def-http-status-code +http-use-proxy+ 305 "Use Proxy") 71 | (def-http-status-code +http-temporary-redirect+ 307 "Temporary Redirect") 72 | (def-http-status-code +http-bad-request+ 400 "Bad Request") 73 | (def-http-status-code +http-authorization-required+ 401 "Authorization Required") 74 | (def-http-status-code +http-payment-required+ 402 "Payment Required") 75 | (def-http-status-code +http-forbidden+ 403 "Forbidden") 76 | (def-http-status-code +http-not-found+ 404 "Not Found") 77 | (def-http-status-code +http-method-not-allowed+ 405 "Method Not Allowed") 78 | (def-http-status-code +http-not-acceptable+ 406 "Not Acceptable") 79 | (def-http-status-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required") 80 | (def-http-status-code +http-request-time-out+ 408 "Request Time-out") 81 | (def-http-status-code +http-conflict+ 409 "Conflict") 82 | (def-http-status-code +http-gone+ 410 "Gone") 83 | (def-http-status-code +http-length-required+ 411 "Length Required") 84 | (def-http-status-code +http-precondition-failed+ 412 "Precondition Failed") 85 | (def-http-status-code +http-request-entity-too-large+ 413 "Request Entity Too Large") 86 | (def-http-status-code +http-request-uri-too-large+ 414 "Request-URI Too Large") 87 | (def-http-status-code +http-unsupported-media-type+ 415 "Unsupported Media Type") 88 | (def-http-status-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable") 89 | (def-http-status-code +http-expectation-failed+ 417 "Expectation Failed") 90 | (def-http-status-code +http-failed-dependency+ 424 "Failed Dependency") 91 | (def-http-status-code +http-internal-server-error+ 500 "Internal Server Error") 92 | (def-http-status-code +http-not-implemented+ 501 "Not Implemented") 93 | (def-http-status-code +http-bad-gateway+ 502 "Bad Gateway") 94 | (def-http-status-code +http-service-unavailable+ 503 "Service Unavailable") 95 | (def-http-status-code +http-gateway-time-out+ 504 "Gateway Time-out") 96 | (def-http-status-code +http-version-not-supported+ 505 "Version not supported") 97 | 98 | (defconstant +day-names+ 99 | #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") 100 | "The three-character names of the seven days of the week - needed 101 | for cookie date format.") 102 | 103 | (defconstant +month-names+ 104 | #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") 105 | "The three-character names of the twelve months - needed for cookie 106 | date format.") 107 | 108 | (defvar *default-content-type* "text/html" 109 | "The default content-type header which is returned to the client. 110 | If this is text content type, the character set used for encoding the 111 | response will automatically be added to the content type in a 112 | ``charset'' attribute.") 113 | 114 | (defvar *default-charset* :utf-8 115 | "The default charset for text/* content-types.") 116 | 117 | (defvar *header-stream* nil 118 | "If this variable is not NIL, it should be bound to a stream to 119 | which incoming and outgoing headers will be written for debugging 120 | purposes.") 121 | 122 | (defvar *show-lisp-errors-p* nil 123 | "Whether Lisp errors in request handlers should be shown in HTML output.") 124 | 125 | (defvar *show-lisp-backtraces-p* t 126 | "Whether Lisp errors shown in HTML output should contain backtrace information.") 127 | 128 | (defvar *log-lisp-errors-p* t 129 | "Whether Lisp errors in request handlers should be logged.") 130 | 131 | (defvar *log-lisp-backtraces-p* t 132 | "Whether Lisp backtraces should be logged. Only has an effect if 133 | *LOG-LISP-ERRORS-P* is true as well.") 134 | 135 | (defvar *log-lisp-warnings-p* t 136 | "Whether Lisp warnings in request handlers should be logged.") 137 | 138 | (defvar *lisp-errors-log-level* :error 139 | "Log level for Lisp errors. Should be one of :ERROR \(the default), 140 | :WARNING, or :INFO.") 141 | 142 | (defvar *lisp-warnings-log-level* :warning 143 | "Log level for Lisp warnings. Should be one of :ERROR, :WARNING 144 | \(the default), or :INFO.") 145 | 146 | (defvar *debug-errors-p* t 147 | "When true, Toot drops into the debugger on unhandled errors. 148 | Otherwise unhandled errors signaled while processing requests are 149 | logged and a 500 error returned to the client.") 150 | 151 | (defconstant +toot-project-url+ "https://github.com/gigamonkey/toot") 152 | 153 | (defconstant +implementation-link+ 154 | #+:cmu "http://www.cons.org/cmucl/" 155 | #+:sbcl "http://www.sbcl.org/" 156 | #+:allegro "http://www.franz.com/products/allegrocl/" 157 | #+:lispworks "http://www.lispworks.com/" 158 | #+:openmcl "http://openmcl.clozure.com/" 159 | "A link to the website of the underlying Lisp implementation.") 160 | 161 | (defvar *tmp-directory* 162 | #+(or :win32 :mswindows) "c:\\toot-temp\\" 163 | #-(or :win32 :mswindows) "/tmp/toot/" 164 | "Directory for temporary files created by MAKE-TMP-FILE-NAME.") 165 | 166 | (defvar *tmp-counter-lock* (make-lock "tmp-counter-lock") 167 | "Lock to protect access to *tmp-counter*.") 168 | 169 | (defvar *tmp-counter* 0 170 | "Counter used in creating tmp filenames.") 171 | 172 | (defconstant +latin-1+ 173 | (make-external-format :latin1 :eol-style :lf) 174 | "A FLEXI-STREAMS external format used for `faithful' input and 175 | output of binary data.") 176 | 177 | (defconstant +utf-8+ 178 | (make-external-format :utf8 :eol-style :lf) 179 | "A FLEXI-STREAMS external format used internally for logging and to 180 | encode cookie values.") 181 | 182 | (defvar *default-external-format* +utf-8+ 183 | "The external format used to compute the REQUEST object.") 184 | 185 | (defconstant +buffer-length+ 8192 186 | "Length of buffers used for internal purposes.") 187 | 188 | (defvar *default-connection-timeout* 20 189 | "The default connection timeout used when an acceptor is reading 190 | from and writing to a socket stream.") 191 | 192 | (defconstant +new-connection-wait-time+ 2 193 | "Time in seconds to wait for a new connection to arrive before 194 | performing a cleanup run.") 195 | 196 | (pushnew :toot *features*) 197 | 198 | ;; stuff for Nikodemus Siivola's HYPERDOC 199 | ;; see 200 | ;; and 201 | 202 | (defvar *hyperdoc-base-uri* "http://www.gigamonkeys.com/toot/") 203 | 204 | (let ((exported-symbols-alist 205 | (loop for symbol being the external-symbols of :toot 206 | collect (cons symbol (concatenate 'string "#" (string-downcase symbol)))))) 207 | (defun hyperdoc-lookup (symbol type) 208 | (declare (ignore type)) 209 | (cdr (assoc symbol exported-symbols-alist)))) 210 | -------------------------------------------------------------------------------- /taskmaster.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | 31 | (defgeneric execute-acceptor (taskmaster acceptor) 32 | (:documentation "Called on a taskmaster which should call accept-connections on the acceptor.")) 33 | 34 | (defgeneric handle-incoming-connection (taskmaster acceptor socket) 35 | (:documentation "Called on a taskmaster to handle a new connection by calling process-connection on acceptor.")) 36 | 37 | (defgeneric shutdown (taskmaster) 38 | (:documentation "Shutdown the taskmaster, cleaning up any threads it created.")) 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; Simple minded, single-threaded taskmaster implemenetation 42 | 43 | (defclass single-threaded-taskmaster () ()) 44 | 45 | (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster) acceptor) 46 | (accept-connections acceptor)) 47 | 48 | (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) acceptor socket) 49 | (process-connection acceptor socket)) 50 | 51 | (defmethod shutdown ((taskmaster single-threaded-taskmaster))) 52 | 53 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;;; Thread-per-connection taskmaster implemenetation 55 | 56 | (defvar *default-max-thread-count* 100) 57 | (defvar *default-max-accept-count* (+ *default-max-thread-count* 20)) 58 | 59 | ;; You might think it would be nice to provide a taskmaster that takes 60 | ;; threads out of a thread pool. There are two things to consider: 61 | ;; - On a 2010-ish Linux box, thread creation takes less than 250 microseconds. 62 | ;; - Bordeaux Threads doesn't provide a way to "reset" and restart a thread, 63 | ;; and it's not clear how many Lisp implementations can do this. 64 | ;; So for now, we leave this out of the mix. 65 | (defclass thread-per-connection-taskmaster () 66 | ((acceptor-process :accessor acceptor-process) 67 | (max-thread-count 68 | :type (or integer null) 69 | :initarg :max-thread-count 70 | :initform nil 71 | :accessor taskmaster-max-thread-count) 72 | (max-accept-count 73 | :type (or integer null) 74 | :initarg :max-accept-count 75 | :initform nil 76 | :accessor taskmaster-max-accept-count) 77 | (request-count 78 | :type integer 79 | :initform 0 80 | :accessor taskmaster-request-count) 81 | (request-count-lock 82 | :initform (make-lock "taskmaster-request-count") 83 | :reader taskmaster-request-count-lock) 84 | (wait-queue 85 | :initform (make-condition-variable) 86 | :reader taskmaster-wait-queue) 87 | (wait-lock 88 | :initform (make-lock "taskmaster-thread-lock") 89 | :reader taskmaster-wait-lock) 90 | (worker-thread-name-format 91 | :type (or string null) 92 | :initarg :worker-thread-name-format 93 | :initform "toot-worker-~A" 94 | :accessor taskmaster-worker-thread-name-format)) 95 | (:default-initargs 96 | :max-thread-count *default-max-thread-count* 97 | :max-accept-count *default-max-accept-count*) 98 | (:documentation "A taskmaster that starts one thread for listening 99 | to incoming requests and one new thread for each incoming connection. 100 | 101 | If MAX-THREAD-COUNT is null, a new thread will always be created for 102 | each request. 103 | 104 | If MAX-THREAD-COUNT is supplied, the number of request threads is 105 | limited to that. Furthermore, if MAX-ACCEPT-COUNT is not supplied, an 106 | HTTP 503 will be sent if the thread limit is exceeded. Otherwise, if 107 | MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT; 108 | in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only 109 | then is HTTP 503 sent. 110 | 111 | In a load-balanced environment with multiple Toot servers, it's 112 | reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null. 113 | This will immediately result in HTTP 503 when one server is out of 114 | resources, so the load balancer can try to find another server. 115 | 116 | In an environment with a single Toot server, it's reasonable 117 | to provide both MAX-THREAD-COUNT and a somewhat larger value for 118 | MAX-ACCEPT-COUNT. This will cause a server that's almost out of 119 | resources to wait a bit; if the server is completely out of resources, 120 | then the reply will be HTTP 503. 121 | 122 | This is the default taskmaster implementation for multi-threaded Lisp 123 | implementations.")) 124 | 125 | (defmethod initialize-instance :after ((taskmaster thread-per-connection-taskmaster) &rest init-args) 126 | "Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT." 127 | (declare (ignore init-args)) 128 | (when (taskmaster-max-accept-count taskmaster) 129 | (unless (taskmaster-max-thread-count taskmaster) 130 | (parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied")) 131 | (unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster)) 132 | (parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT")))) 133 | 134 | ;; Taskmaster implementation 135 | 136 | (defmethod execute-acceptor ((taskmaster thread-per-connection-taskmaster) acceptor) 137 | (setf (acceptor-process taskmaster) 138 | (make-thread 139 | (lambda () (accept-connections acceptor)) 140 | :name (listen-thread-name acceptor)))) 141 | 142 | (defmethod handle-incoming-connection ((taskmaster thread-per-connection-taskmaster) acceptor socket) 143 | ;; Here's the idea, with the stipulations given in THREAD-PER-CONNECTION-TASKMASTER 144 | ;; - If MAX-THREAD-COUNT is null, just start a taskmaster 145 | ;; - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT 146 | ;; is null and the connection count will exceed MAX-THREAD-COUNT, 147 | ;; return an HTTP 503 error to the client 148 | ;; - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT, 149 | ;; wait until the connection count drops, then handle the request 150 | ;; - Otherwise, increment REQUEST-COUNT and start a taskmaster 151 | (cond 152 | ((null (taskmaster-max-thread-count taskmaster)) 153 | ;; No limit on number of requests, just start a thread to handle the connection 154 | (create-connection-handler-thread taskmaster acceptor socket)) 155 | ((if (taskmaster-max-accept-count taskmaster) 156 | (>= (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster)) 157 | (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) 158 | ;; Send HTTP 503 to indicate that we can't handle the request right now 159 | (log-message acceptor :warning "Can't handle a new request, too many request threads already") 160 | (send-service-unavailable-response acceptor socket)) 161 | 162 | ((and (taskmaster-max-accept-count taskmaster) 163 | (>= (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster))) 164 | ;; Wait for a request to finish, then carry on 165 | (wait-for-free-connection taskmaster) 166 | (create-connection-handler-thread taskmaster acceptor socket)) 167 | 168 | (t 169 | (create-connection-handler-thread taskmaster acceptor socket)))) 170 | 171 | (defmethod shutdown ((taskmaster thread-per-connection-taskmaster)) 172 | (loop while (thread-alive-p (acceptor-process taskmaster)) do (sleep 1))) 173 | 174 | (defun increment-taskmaster-request-count (taskmaster) 175 | (when (taskmaster-max-thread-count taskmaster) 176 | (with-lock-held ((taskmaster-request-count-lock taskmaster)) 177 | (incf (taskmaster-request-count taskmaster))))) 178 | 179 | (defun decrement-taskmaster-request-count (taskmaster) 180 | (when (taskmaster-max-thread-count taskmaster) 181 | (prog1 182 | (with-lock-held ((taskmaster-request-count-lock taskmaster)) 183 | (decf (taskmaster-request-count taskmaster))) 184 | (when (and (taskmaster-max-accept-count taskmaster) 185 | (< (taskmaster-request-count taskmaster) (taskmaster-max-accept-count taskmaster))) 186 | (notify-free-connection taskmaster))))) 187 | 188 | (defun notify-free-connection (taskmaster) 189 | (with-lock-held ((taskmaster-wait-lock taskmaster)) 190 | (condition-notify (taskmaster-wait-queue taskmaster)))) 191 | 192 | (defun wait-for-free-connection (taskmaster) 193 | (with-lock-held ((taskmaster-wait-lock taskmaster)) 194 | (loop until (< (taskmaster-request-count taskmaster) (taskmaster-max-thread-count taskmaster)) 195 | do (condition-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster))))) 196 | 197 | (defun create-connection-handler-thread (taskmaster acceptor socket) 198 | "Create a thread for handling a single request" 199 | ;; we are handling all conditions here as we want to make sure that 200 | ;; the acceptor process never crashes while trying to create a 201 | ;; worker thread; one such problem exists in 202 | ;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on 203 | ;; some platforms in certain situations. 204 | (handler-case* 205 | (make-thread 206 | (lambda () 207 | (increment-taskmaster-request-count taskmaster) 208 | (unwind-protect 209 | (process-connection acceptor socket) 210 | (decrement-taskmaster-request-count taskmaster))) 211 | :name (connection-handler-thread-name taskmaster socket)) 212 | (error (cond) 213 | ;; need to bind *ACCEPTOR* so that LOG-MESSAGE* can do its work. 214 | (log-message 215 | acceptor *lisp-errors-log-level* 216 | "Error while creating worker thread for new incoming connection: ~A" cond)))) 217 | 218 | (defun listen-thread-name (acceptor) 219 | (format nil "toot-listener-~A:~A" (or (address acceptor) "*") (port acceptor))) 220 | 221 | (defun connection-handler-thread-name (taskmaster socket) 222 | (let ((address (usocket:get-peer-address socket)) 223 | (port (usocket:get-peer-port socket))) 224 | (format nil (taskmaster-worker-thread-name-format taskmaster) 225 | (cond 226 | ((and address port) 227 | (format nil "~A:~A" (usocket:vector-quad-to-dotted-quad address) port)) 228 | (t "Unknown endpoint"))))) 229 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | ;;; 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | ;;; 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | ;;; 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot-tests) 29 | 30 | (defvar *test-acceptor* nil) 31 | 32 | (defun test-document-directory (&optional sub-directory) 33 | (asdf:system-relative-pathname :toot (format nil "www/~@[~A~]" sub-directory))) 34 | 35 | (defun start-test-server (port) 36 | (setf *test-acceptor* (start-server :port port :handler (test-handler)))) 37 | 38 | (defun start-trivial-server (&key (port 0)) 39 | (setf *test-acceptor* (start-server :port port :handler 'trivial-handler)) 40 | (format nil "http://localhost:~d/" (port *test-acceptor*))) 41 | 42 | (defun trivial-handler (request) 43 | (let ((s (send-headers request))) 44 | (format s "Hello, world!

Hello, world!

"))) 45 | 46 | (defun reset-test-handler () 47 | (setf (handler *test-acceptor*) (test-handler))) 48 | 49 | (defun enough-url (url url-prefix) 50 | "Returns the relative portion of URL relative to URL-PREFIX, similar 51 | to what ENOUGH-NAMESTRING does for pathnames." 52 | (let ((prefix-length (length url-prefix))) 53 | (if (string= url url-prefix :end1 prefix-length) 54 | (subseq url prefix-length) 55 | url))) 56 | 57 | (defun resolve-file (path document-root) 58 | (merge-pathnames (subseq (add-index path) 1) document-root)) 59 | 60 | ;;; Simple composite handler that searches a list of sub-handlers for 61 | ;;; one that can handle the request. 62 | 63 | (defclass search-handler () 64 | ((handlers :initarg :handlers :initform () :accessor handlers))) 65 | 66 | (defun make-search-handler (&rest sub-handlers) 67 | (make-instance 'search-handler :handlers sub-handlers)) 68 | 69 | (defun add-handler (search-handler sub-handler) 70 | (push sub-handler (handlers search-handler))) 71 | 72 | (defmethod handle-request ((handler search-handler) request) 73 | (loop for sub in (handlers handler) 74 | do (handle-request sub request) until (response-sent-p request))) 75 | 76 | (defun make-exact-path-handler (path sub-handler) 77 | "Make a handler that handles the request with SUB-HANDLER if the 78 | file name of the request is exactly the given PATH." 79 | (lambda (request) 80 | (when (string= path (request-path request)) 81 | (handle-request sub-handler request)))) 82 | 83 | (defun test-handler () 84 | (make-search-handler 85 | (make-exact-path-handler "/form-test-get-params" 'form-test-get-params) 86 | (make-exact-path-handler "/form-test-params" 'form-test-params) 87 | (make-exact-path-handler "/form-test-octets" 'form-test-octets) 88 | (make-exact-path-handler "/form-test-stream" 'form-test-stream) 89 | (make-instance 'static-file-handler :root (test-document-directory)))) 90 | 91 | (defun form-test-get-params (request) 92 | (with-response-body (s request) 93 | (format s "~&Form test params") 94 | (format s "~&

Form results via GET

") 95 | (loop for (k . v) in (request-headers request) do 96 | (format s "~&

~a: ~a

" k v)) 97 | (loop for (k . v) in (get-parameters request) 98 | do 99 | (cond 100 | ((listp v) 101 | (format s "~&

~a: ~a

" k v)
102 |             (with-open-file (in (first v))
103 |               (loop for char = (read-char in nil nil)
104 |                  while char do (write-string (escape-for-html (string char)) s)))
105 |             (format s "

")) 106 | (t (format s "~&

~a: ~a

" k v)))) 107 | (format s "~&"))) 108 | 109 | (defun form-test-params (request) 110 | (with-response-body (s request) 111 | (format s "~&Form test params") 112 | (format s "~&

Form results via post-parameters

") 113 | (loop for (k . v) in (request-headers request) do 114 | (format s "~&

~a: ~a

" k v)) 115 | (loop for (k . v) in (post-parameters request) 116 | do 117 | (cond 118 | ((listp v) 119 | (format s "~&

~a: ~a

" k v)
120 |             (with-open-file (in (first v))
121 |               (loop for char = (read-char in nil nil)
122 |                  while char do (write-string (escape-for-html (string char)) s)))
123 |             (format s "

")) 124 | (t (format s "~&

~a: ~a

" k v)))) 125 | (format s "~&"))) 126 | 127 | (defun form-test-octets (request) 128 | (with-response-body (s request) 129 | (format s "~&Form test octets") 130 | (format s "~&

Form results via body-octets

") 131 | (format s "~&

~a

" (escape-for-html (flexi-streams:octets-to-string (body-octets request)))) 132 | (format s "~&"))) 133 | 134 | (defun form-test-stream (request) 135 | (with-response-body (s request) 136 | (format s "~&Form test stream") 137 | (format s "~&

Form results via body-stream

") 138 | (format s "~&

")
139 |     (loop with in = (body-stream request)
140 |        for char = (read-char in nil nil)
141 |        while char do (write-string (escape-for-html (string char)) s))
142 |     (format s "

") 143 | (format s "~&"))) 144 | -------------------------------------------------------------------------------- /toot.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | 27 | (in-package :cl-user) 28 | 29 | (defpackage :toot-asd (:use :cl :asdf)) 30 | 31 | (in-package :toot-asd) 32 | 33 | (defvar *toot-version* "0.0.1" 34 | "A string denoting the current version of Toot. Used for diagnostic 35 | output.") 36 | 37 | ;(export '*toot-version*) 38 | 39 | (defsystem :toot 40 | :description "A minimal web server originally built by stripping down Edi Weitz's Hunchentoot" 41 | :serial t 42 | :version #.*toot-version* 43 | :depends-on (:alexandria 44 | :chunga 45 | :cl-base64 46 | :cl-fad 47 | :cl-ppcre 48 | :flexi-streams 49 | :cl+ssl 50 | :md5 51 | :trivial-backtrace 52 | :usocket 53 | :bordeaux-threads 54 | :puri 55 | #+ecl :sb-bsd-sockets 56 | ) 57 | :components ((:file "packages") 58 | (:file "rfc2388") 59 | (:file "specials") 60 | (:file "conditions") 61 | (:file "mime-types") 62 | (:file "util") 63 | (:file "cookie") 64 | (:file "set-timeouts") 65 | (:file "taskmaster") 66 | (:file "log") 67 | (:file "http") 68 | (:file "api") 69 | (:file "tests") 70 | (:file "documentation"))) 71 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 2 | ;;; Copyright (c) 2011, Peter Seibel. All rights reserved. 3 | 4 | ;;; Redistribution and use in source and binary forms, with or without 5 | ;;; modification, are permitted provided that the following conditions 6 | ;;; are met: 7 | 8 | ;;; * Redistributions of source code must retain the above copyright 9 | ;;; notice, this list of conditions and the following disclaimer. 10 | 11 | ;;; * Redistributions in binary form must reproduce the above 12 | ;;; copyright notice, this list of conditions and the following 13 | ;;; disclaimer in the documentation and/or other materials 14 | ;;; provided with the distribution. 15 | 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | (in-package :toot) 29 | 30 | (defun escape-for-html (string) 31 | "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output." 32 | (with-output-to-string (out) 33 | (with-input-from-string (in string) 34 | (loop for char = (read-char in nil nil) 35 | while char 36 | do (case char 37 | ((#\<) (write-string "<" out)) 38 | ((#\>) (write-string ">" out)) 39 | ((#\") (write-string """ out)) 40 | ((#\') (write-string "'" out)) 41 | ((#\&) (write-string "&" out)) 42 | (otherwise (write-char char out))))))) 43 | 44 | (defun rfc-1123-date (&optional (time (get-universal-time))) 45 | "Generates a time string according to RFC 1123. Default is current time." 46 | (multiple-value-bind 47 | (second minute hour date month year day-of-week) 48 | (decode-universal-time time 0) 49 | (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT" 50 | (svref +day-names+ day-of-week) 51 | date 52 | (svref +month-names+ (1- month)) 53 | year 54 | hour 55 | minute 56 | second))) 57 | 58 | ;; FIXME: this is lacking time zone. Should probably log on zulu time. 59 | (defun iso-time (&optional (time (get-universal-time))) 60 | "Returns the universal time TIME as a string in full ISO format." 61 | (multiple-value-bind (second minute hour date month year) 62 | (decode-universal-time time) 63 | (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d" 64 | year month date hour minute second))) 65 | 66 | (defun tmp-filename () 67 | (loop for pathname = (possible-tmp-filename) 68 | when (not (probe-file pathname)) return pathname)) 69 | 70 | (defun possible-tmp-filename () 71 | (let ((n (with-lock-held (*tmp-counter-lock*) (incf *tmp-counter*)))) 72 | (make-pathname :name (format nil "toottmp-~d" n) :type nil :defaults *tmp-directory*))) 73 | 74 | (defun quote-string (string) 75 | "Quotes string according to RFC 2616's definition of `quoted-string'." 76 | (with-output-to-string (out) 77 | (with-input-from-string (in string) 78 | (loop for char = (read-char in nil nil) 79 | while char 80 | unless (or (char< char #\Space) 81 | (char= char #\Rubout)) 82 | do (case char 83 | ((#\\) (write-string "\\\\" out)) 84 | ((#\") (write-string "\\\"" out)) 85 | (otherwise (write-char char out))))))) 86 | 87 | (defmacro upgrade-vector (vector new-type &key converter) 88 | "Returns a vector with the same length and the same elements as 89 | VECTOR \(a variable holding a vector) but having element type 90 | NEW-TYPE. If CONVERTER is not NIL, it should designate a function 91 | which will be applied to each element of VECTOR before the result is 92 | stored in the new vector. The resulting vector will have a fill 93 | pointer set to its end. 94 | 95 | The macro also uses SETF to store the new vector in VECTOR." 96 | `(setf ,vector 97 | (loop with length = (length ,vector) 98 | with new-vector = (make-array length 99 | :element-type ,new-type 100 | :fill-pointer length) 101 | for i below length 102 | do (setf (aref new-vector i) ,(if converter 103 | `(funcall ,converter (aref ,vector i)) 104 | `(aref ,vector i))) 105 | finally (return new-vector)))) 106 | 107 | (defun url-decode (string &optional (external-format *default-external-format*)) 108 | "Decodes a URL-encoded STRING which is assumed to be encoded using 109 | the external format EXTERNAL-FORMAT." 110 | (when (zerop (length string)) 111 | (return-from url-decode "")) 112 | (let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0)) 113 | (i 0) 114 | unicodep) 115 | (loop 116 | (unless (< i (length string)) 117 | (return)) 118 | (let ((char (aref string i))) 119 | (labels ((decode-hex (length) 120 | (prog1 121 | (parse-integer string :start i :end (+ i length) :radix 16) 122 | (incf i length))) 123 | (push-integer (integer) 124 | (vector-push integer vector)) 125 | (peek () 126 | (aref string i)) 127 | (advance () 128 | (setf char (peek)) 129 | (incf i))) 130 | (cond 131 | ((char= #\% char) 132 | (advance) 133 | (cond 134 | ((char= #\u (peek)) 135 | (unless unicodep 136 | (setf unicodep t) 137 | (upgrade-vector vector '(integer 0 65535))) 138 | (advance) 139 | (push-integer (decode-hex 4))) 140 | (t 141 | (push-integer (decode-hex 2))))) 142 | (t 143 | (push-integer (char-code (case char 144 | ((#\+) #\Space) 145 | (otherwise char)))) 146 | (advance)))))) 147 | (cond (unicodep 148 | (upgrade-vector vector 'character :converter #'code-char)) 149 | (t (octets-to-string vector :external-format external-format))))) 150 | 151 | (defun form-url-encoded-list-to-alist (form-url-encoded-list 152 | &optional (external-format *default-external-format*)) 153 | "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an 154 | alist. Both names and values are url-decoded while doing this." 155 | (mapcar #'(lambda (entry) 156 | (destructuring-bind (name &optional value) 157 | (split "=" entry :limit 2) 158 | (cons (string-trim " " (url-decode name external-format)) 159 | (url-decode (or value "") external-format)))) 160 | form-url-encoded-list)) 161 | 162 | (defun url-encode (string &optional (external-format *default-external-format*)) 163 | "URL-encodes a string using the external format EXTERNAL-FORMAT." 164 | (with-output-to-string (s) 165 | (loop for c across string 166 | for index from 0 167 | do (cond ((or (char<= #\0 c #\9) 168 | (char<= #\a c #\z) 169 | (char<= #\A c #\Z) 170 | ;; note that there's no comma in there - because of cookies 171 | (find c "$-_.!*'()" :test #'char=)) 172 | (write-char c s)) 173 | (t (loop for octet across (string-to-octets string 174 | :start index 175 | :end (1+ index) 176 | :external-format external-format) 177 | do (format s "%~2,'0x" octet))))))) 178 | 179 | (defun parse-content-type-header (content-type-header) 180 | "Reads and parses a `Content-Type' header and returns it as three 181 | values - the type, the subtype, and the requests' character set as 182 | specified in the 'charset' parameter in the header, if there is one 183 | and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed 184 | to be the corresponding header value as a string." 185 | (with-input-from-sequence (stream (map 'list 'char-code content-type-header)) 186 | (with-character-stream-semantics 187 | (let* ((*current-error-message* "Corrupted Content-Type header:") 188 | (type (read-token stream)) 189 | (subtype (if (eql #\/ (read-char* stream nil)) 190 | (read-token stream) 191 | (return-from parse-content-type-header 192 | ;; try to return something meaningful 193 | (values "application" "octet-stream" nil)))) 194 | (parameters (read-name-value-pairs stream)) 195 | (charset (cdr (assoc "charset" parameters :test #'string=))) 196 | (charset 197 | (when (string-equal type "text") 198 | charset))) 199 | (values type subtype charset))))) 200 | 201 | (defun sans (args &rest to-remove) 202 | (loop for (k v) on args by #'cddr unless (member k to-remove) collect k and collect v)) -------------------------------------------------------------------------------- /www/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gigamonkey/toot/90f3854f2e548c9ad102c53caba834255dfabfa2/www/favicon.ico -------------------------------------------------------------------------------- /www/img/made-with-lisp-logo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gigamonkey/toot/90f3854f2e548c9ad102c53caba834255dfabfa2/www/img/made-with-lisp-logo.jpg -------------------------------------------------------------------------------- /www/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Welcome to Toot!! 4 | 5 | 6 |

Welcome

7 |

8 | When you're reading this message, Toot has been properly installed. 9 |

10 |

Test forms

11 |

12 | 13 |

14 | 15 | 16 | -------------------------------------------------------------------------------- /www/testforms.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Form testing 5 | 6 | 7 |

Form testing

8 | 9 |

Form test params (GET)

10 |
11 |

Foo:

12 |

Bar:

13 |

Baz:

14 |

15 |
16 | 17 |

Form test params (application/x-www-form-urlencoded)

18 |
19 |

Foo:

20 |

Bar:

21 |

Baz:

22 |

23 |
24 | 25 |

Form test params (multipart/form-data)

26 |
27 |

Foo:

28 |

Bar:

29 |

Baz:

30 |

File:

31 |

32 |
33 | 34 |

Form test octets (application/x-www-form-urlencoded)

35 |
36 |

Foo:

37 |

Bar:

38 |

Baz:

39 |

40 |
41 | 42 |

Form test octets (multipart/form-data)

43 |
44 |

Foo:

45 |

Bar:

46 |

Baz:

47 |

File:

48 |

49 |
50 | 51 |

Form test stream (application/x-www-form-urlencoded)

52 |
53 |

Foo:

54 |

Bar:

55 |

Baz:

56 |

57 |
58 | 59 |

Form test stream (multipart/form-data)

60 |
61 |

Foo:

62 |

Bar:

63 |

Baz:

64 |

File:

65 |

66 |
67 | 68 | 69 | 70 | 71 | --------------------------------------------------------------------------------