hunchentoot-v1.2.38/ 0000755 0000000 0000000 00000000000 13211004253 013016 5 ustar root root hunchentoot-v1.2.38/misc.lisp 0000644 0000000 0000000 00000031504 13211004253 014645 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(let ((scanner-hash (make-hash-table :test #'equal)))
(defun scanner-for-get-param (param-name)
"Returns a CL-PPCRE scanner which matches a GET parameter in a
URL. Scanners are memoized in SCANNER-HASH once they are created."
(or (gethash param-name scanner-hash)
(setf (gethash param-name scanner-hash)
(create-scanner
`(:alternation
;; session=value at end of URL
(:sequence
(:char-class #\? #\&)
,param-name
#\=
(:greedy-repetition 0 nil (:inverted-char-class #\&))
:end-anchor)
;; session=value with other parameters following
(:sequence
(:register (:char-class #\? #\&))
,param-name
#\=
(:greedy-repetition 0 nil (:inverted-char-class #\&))
#\&))))))
(defun add-cookie-value-to-url (url &key
(cookie-name (session-cookie-name *acceptor*))
(value (when-let (session (session *request*))
(session-cookie-value session)))
(replace-ampersands-p t))
"Removes all GET parameters named COOKIE-NAME from URL and then
adds a new GET parameter with the name COOKIE-NAME and the value
VALUE. If REPLACE-AMPERSANDS-P is true all literal ampersands in URL
are replaced with '&'. The resulting URL is returned."
(unless url
;; see URL-REWRITE:*URL-REWRITE-FILL-TAGS*
(setq url (request-uri *request*)))
(setq url (regex-replace-all (scanner-for-get-param cookie-name) url "\\1"))
(when value
(setq url (format nil "~A~:[?~;&~]~A=~A"
url
(find #\? url)
cookie-name
(url-encode value))))
(when replace-ampersands-p
(setq url (regex-replace-all "&" url "&")))
url))
(defun maybe-rewrite-urls-for-session (html &key
(cookie-name (session-cookie-name *acceptor*))
(value (when-let (session (session *request*))
(session-cookie-value session))))
"Rewrites the HTML page HTML such that the name/value pair
COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
true. See the docs for URL-REWRITE:REWRITE-URLS."
(cond ((or (not *rewrite-for-session-urls*)
(null value)
(cookie-in cookie-name))
html)
(t
(with-input-from-string (*standard-input* html)
(with-output-to-string (*standard-output*)
(url-rewrite:rewrite-urls
(lambda (url)
(add-cookie-value-to-url url
:cookie-name cookie-name
:value value))))))))
(defun create-prefix-dispatcher (prefix handler)
"Creates a request dispatch function which will dispatch to the
function denoted by HANDLER if the file name of the current request
starts with the string PREFIX."
(lambda (request)
(let ((mismatch (mismatch (script-name request) prefix
:test #'char=)))
(and (or (null mismatch)
(>= mismatch (length prefix)))
handler))))
(defun create-regex-dispatcher (regex handler)
"Creates a request dispatch function which will dispatch to the
function denoted by HANDLER if the file name of the current request
matches the CL-PPCRE regular expression REGEX."
(let ((scanner (create-scanner regex)))
(lambda (request)
(and (scan scanner (script-name request))
handler))))
(defun abort-request-handler (&optional result)
"This function can be called by a request handler at any time to
immediately abort handling the request. This works as if the handler
had returned RESULT. See the source code of REDIRECT for an example."
(throw 'handler-done result))
(defun maybe-handle-range-header (file)
"Helper function for handle-static-file. Determines whether the
requests specifies a Range header. If so, parses the header and
position the already opened file to the location specified. Returns
the number of bytes to transfer from the file. Invalid specified
ranges are reported to the client with a HTTP 416 status code."
(let ((bytes-to-send (file-length file)))
(cl-ppcre:register-groups-bind
(start end)
("^bytes=(\\d+)-(\\d*)$" (header-in* :range) :sharedp t)
;; body won't be executed if regular expression does not match
(setf start (parse-integer start))
(setf end (if (> (length end) 0)
(parse-integer end)
(1- (file-length file))))
(when (or (< start 0)
(>= end (file-length file)))
(setf (return-code*) +http-requested-range-not-satisfiable+
(header-out :content-range) (format nil "bytes 0-~D/~D" (1- (file-length file)) (file-length file)))
(throw 'handler-done
(format nil "invalid request range (requested ~D-~D, accepted 0-~D)"
start end (1- (file-length file)))))
(file-position file start)
(setf (return-code*) +http-partial-content+
bytes-to-send (1+ (- end start))
(header-out :content-range) (format nil "bytes ~D-~D/~D" start end (file-length file))))
bytes-to-send))
(defun handle-static-file (pathname &optional content-type)
"A function which acts like a Hunchentoot handler for the file
denoted by PATHNAME. Sends a content type header corresponding to
CONTENT-TYPE or \(if that is NIL) tries to determine the content type
via the file's suffix."
(when (or (wild-pathname-p pathname)
(not (fad:file-exists-p pathname))
(fad:directory-exists-p pathname))
;; file does not exist
(setf (return-code*) +http-not-found+)
(abort-request-handler))
(unless content-type
(setf content-type (mime-type pathname)))
(let ((time (or (file-write-date pathname)
(get-universal-time)))
bytes-to-send)
(setf (content-type*) (or (and content-type
(maybe-add-charset-to-content-type-header content-type (reply-external-format*)))
"application/octet-stream")
(header-out :last-modified) (rfc-1123-date time)
(header-out :accept-ranges) "bytes")
(handle-if-modified-since time)
(with-open-file (file pathname
:direction :input
:element-type 'octet)
(setf bytes-to-send (maybe-handle-range-header file)
(content-length*) bytes-to-send)
(let ((out (send-headers))
(buf (make-array +buffer-length+ :element-type 'octet)))
(loop
(when (zerop bytes-to-send)
(return))
(let* ((chunk-size (min +buffer-length+ bytes-to-send)))
(unless (eql chunk-size (read-sequence buf file :end chunk-size))
(error "can't read from input file"))
(write-sequence buf out :end chunk-size)
(decf bytes-to-send chunk-size)))
(finish-output out)))))
(defun create-static-file-dispatcher-and-handler (uri path &optional content-type)
"Creates and returns a request dispatch function which will dispatch
to a handler function which emits the file denoted by the pathname
designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of
the request matches the string URI. If CONTENT-TYPE is NIL, tries to
determine the content type via the file's suffix."
;; the dispatcher
(lambda (request)
(when (string= (script-name request) uri)
;; the handler
(lambda ()
(handle-static-file path content-type)))))
(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
"Creates and returns a dispatch function which will dispatch to a
handler function which emits the file relative to BASE-PATH that is
denoted by the URI of the request relative to URI-PREFIX. URI-PREFIX
must be a string ending with a slash, BASE-PATH must be a pathname
designator for an existing directory. If CONTENT-TYPE is not NIL,
it'll be the content type used for all files in the folder."
(unless (and (stringp uri-prefix)
(plusp (length uri-prefix))
(char= (char uri-prefix (1- (length uri-prefix))) #\/))
(parameter-error "~S must be string ending with a slash." uri-prefix))
(unless (fad:directory-pathname-p base-path)
(parameter-error "~S is supposed to denote a directory." base-path))
(flet ((handler ()
(let ((request-path (request-pathname *request* uri-prefix)))
(when (null request-path)
(setf (return-code*) +http-forbidden+)
(abort-request-handler))
(handle-static-file (merge-pathnames request-path base-path) content-type))))
(create-prefix-dispatcher uri-prefix #'handler)))
(defun no-cache ()
"Adds appropriate headers to completely prevent caching on most browsers."
(setf (header-out :expires)
"Mon, 26 Jul 1997 05:00:00 GMT"
(header-out :cache-control)
"no-store, no-cache, must-revalidate, post-check=0, pre-check=0"
(header-out :pragma)
"no-cache"
(header-out :last-modified)
(rfc-1123-date))
(values))
(defun redirect (target &key (host (host *request*) host-provided-p)
port
(protocol (if (ssl-p) :https :http))
(add-session-id (not (or host-provided-p
(starts-with-scheme-p target)
(cookie-in (session-cookie-name *acceptor*)))))
(code +http-moved-temporarily+))
"Redirects the browser to TARGET which should be a string. If
TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL
are ignored. Otherwise, TARGET should denote the path part of a URL,
PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to
redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET.
Adds a session ID if ADD-SESSION-ID is true. If CODE is a 3xx
redirection code, it will be sent as status code."
(check-type code (integer 300 399))
(let ((url (if (starts-with-scheme-p target)
target
(format nil "~A://~A~@[:~A~]~A"
(ecase protocol
((:http) "http")
((:https) "https"))
(if port
(first (ppcre:split ":" (or host "")))
host)
port target))))
(when add-session-id
(setq url (add-cookie-value-to-url url :replace-ampersands-p nil)))
(setf (header-out :location) url
(return-code*) code)
(abort-request-handler)))
(defun require-authorization (&optional (realm "Hunchentoot"))
"Sends back appropriate headers to require basic HTTP authentication
\(see RFC 2617) for the realm REALM."
(setf (header-out :www-authenticate)
(format nil "Basic realm=\"~A\"" (quote-string realm))
(return-code *reply*)
+http-authorization-required+)
(abort-request-handler))
hunchentoot-v1.2.38/packages.lisp 0000644 0000000 0000000 00000023554 13211004253 015476 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage #:hunchentoot
(:nicknames #:tbnl)
(:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite)
(:shadow #:defconstant
#:url-encode)
#+:lispworks
(:import-from :lw #:with-unique-names #:when-let)
(:export #:*acceptor*
#:*catch-errors-p*
#+:lispworks
#:*cleanup-function*
#+:lispworks
#:*cleanup-interval*
#:*content-types-for-url-rewrite*
#:*default-connection-timeout*
#:*default-content-type*
#:*dispatch-table*
#:*file-upload-hook*
#:*handle-http-errors-p*
#:*header-stream*
#:*http-error-handler*
#:*hunchentoot-default-external-format*
#:*hunchentoot-version*
#:*lisp-errors-log-level*
#:*lisp-warnings-log-level*
#:*log-lisp-backtraces-p*
#:*log-lisp-errors-p*
#:*log-lisp-warnings-p*
#:*methods-for-post-parameters*
#:*reply*
#:*request*
#:*rewrite-for-session-urls*
#:*session*
#:*session-gc-frequency*
#:*session-max-time*
#:*session-secret*
#:*show-lisp-backtraces-p*
#:*show-lisp-errors-p*
#:*tmp-directory*
#:*use-remote-addr-for-sessions*
#:*use-user-agent-for-sessions*
#:+http-accepted+
#:+http-authorization-required+
#:+http-bad-gateway+
#:+http-bad-request+
#:+http-conflict+
#:+http-continue+
#:+http-created+
#:+http-expectation-failed+
#:+http-failed-dependency+
#:+http-forbidden+
#:+http-gateway-time-out+
#:+http-gone+
#:+http-internal-server-error+
#:+http-length-required+
#:+http-method-not-allowed+
#:+http-moved-permanently+
#:+http-moved-temporarily+
#:+http-multi-status+
#:+http-multiple-choices+
#:+http-network-authentication-required+
#:+http-no-content+
#:+http-non-authoritative-information+
#:+http-not-acceptable+
#:+http-not-found+
#:+http-not-implemented+
#:+http-not-modified+
#:+http-ok+
#:+http-partial-content+
#:+http-payment-required+
#:+http-precondition-failed+
#:+http-precondition-required+
#:+http-proxy-authentication-required+
#:+http-request-entity-too-large+
#:+http-request-header-fields-too-large+
#:+http-request-time-out+
#:+http-request-uri-too-large+
#:+http-requested-range-not-satisfiable+
#:+http-reset-content+
#:+http-see-other+
#:+http-service-unavailable+
#:+http-switching-protocols+
#:+http-temporary-redirect+
#:+http-too-many-requests+
#:+http-unsupported-media-type+
#:+http-use-proxy+
#:+http-version-not-supported+
#:abort-request-handler
#:accept-connections
#:acceptor
#:acceptor-access-log-destination
#:acceptor-address
#:acceptor-listen-backlog
#:acceptor-dispatch-request
#:acceptor-error-template-directory
#:acceptor-input-chunking-p
#:acceptor-log-access
#:acceptor-log-message
#:acceptor-message-log-destination
#:acceptor-name
#:acceptor-output-chunking-p
#:acceptor-persistent-connections-p
#:acceptor-port
#:acceptor-read-timeout
#:acceptor-remove-session
#:acceptor-reply-class
#:acceptor-request-class
#:acceptor-ssl-p
#-:hunchentoot-no-ssl #:acceptor-ssl-certificate-file
#-:hunchentoot-no-ssl #:acceptor-ssl-privatekey-file
#-:hunchentoot-no-ssl #:acceptor-ssl-privatekey-password
#:acceptor-status-message
#:acceptor-write-timeout
#:acceptor-document-root
#:acceptor-error-template-directory
#:authorization
#:aux-request-value
#:client-as-string
#:content-length
#:content-length*
#:content-type
#:content-type*
#:cookie-domain
#:cookie-expires
#:cookie-http-only
#:cookie-in
#:cookie-max-age
#:cookie-name
#:cookie-out
#:cookie-path
#:cookie-secure
#:cookie-value
#:cookies-in
#:cookies-in*
#:cookies-out
#:cookies-out*
#:create-folder-dispatcher-and-handler
#:create-prefix-dispatcher
#:create-regex-dispatcher
#:create-request-handler-thread
#:create-static-file-dispatcher-and-handler
#:decrement-taskmaster-thread-count
#:default-document-directory
#:define-easy-handler
#:delete-aux-request-value
#:delete-session-value
#:dispatch-easy-handlers
#:easy-acceptor
#-:hunchentoot-no-ssl #:easy-ssl-acceptor
#:escape-for-html
#:execute-acceptor
#:get-parameter
#:get-parameters
#:get-parameters*
#:handle-incoming-connection
#:handle-if-modified-since
#:handle-request
#:handle-static-file
#:header-in
#:header-in*
#:header-out
#:headers-in
#:headers-in*
#:headers-out
#:headers-out*
#:host
#:http-token-p
#:hunchentoot-condition
#:hunchentoot-error
#:hunchentoot-warning
#:increment-taskmaster-thread-count
#:initialize-connection-stream
#:log-message*
#:maybe-invoke-debugger
#:mime-type
#:multi-threaded-taskmaster
#:next-session-id
#:no-cache
#:one-thread-per-connection-taskmaster
#:parameter
#:parameter-error
#:post-parameter
#:post-parameters
#:post-parameters*
#:process-connection
#:process-request
#:query-string
#:query-string*
#:raw-post-data
#:real-remote-addr
#:reason-phrase
#:recompute-request-parameters
#:redirect
#:referer
#:regenerate-session-cookie-value
#:remote-addr
#:remote-addr*
#:remote-port
#:remote-port*
#:local-addr
#:local-addr*
#:local-port
#:local-port*
#:remove-session
#:reply
#:reply-external-format
#:reply-external-format*
#:request
#:request-acceptor
#:request-method
#:request-method*
#:request-pathname
#:request-uri
#:request-uri*
#:require-authorization
#:reset-connection-stream
#:reset-sessions
#:reset-session-secret
#:return-code
#:return-code*
#:rfc-1123-date
#:script-name
#:script-name*
#:send-headers
#:server-protocol
#:server-protocol*
#:session
#:session-cookie-name
#:session-cookie-value
#:session-created
#:session-db
#:session-db-lock
#:session-gc
#:session-id
#:session-max-time
#:session-remote-addr
#:session-start
#:session-too-old-p
#:session-user-agent
#:session-value
#:session-verify
#:set-cookie
#:set-cookie*
#:shutdown
#:single-threaded-taskmaster
#-:hunchentoot-no-ssl #:ssl-acceptor
#:ssl-p
#:start
#:start-listening
#:start-session
#:start-thread
#:started-p
#:stop
#:taskmaster
#:taskmaster-acceptor
#:taskmaster-max-accept-count
#:taskmaster-max-thread-count
#:taskmaster-thread-count
#:too-many-taskmaster-requests
#:url-decode
#:url-encode
#:user-agent
#:within-request-p
#:detach-socket
#:bad-request))
hunchentoot-v1.2.38/CHANGELOG 0000644 0000000 0000000 00000040262 13211004253 014234 0 ustar root root Version 1.2.38
2017-12-03
Better pathname validation.
A couple of small fixes.
Version 1.2.37
2016-12-11
Support listening on random port number (Lucien Pullen)
Version 1.2.36
2016-12-08
Compare on the path-string. (matthieupeeters)
speed up shutdown and avoid timeout on the listening socket (Felix Lange)
clarify definition of handler function (Robert Smith)
[doc] fix ID clash in index.xml (Alex Dunn)
Version 1.2.35
2016-02-10
Avoid double URL decoding, reported by muyinliu (Hans Huebner)
Remove a duplicate word in the documentation (William Halliburton)
Call convert-hack in name also (José Ronquillo Rivera)
Version 1.2.34
2015-07-06
decode URL considering content-type's charset (Tim Richardt)
Version 1.2.33
2015-07-05
Ignore malformed session IDs (Hans Huebner)
prevent failures when session cookie is malformed (Andrey Kutejko)
correct started-p for lispworks (LinkFly)
Version 1.2.32
2015-05-03
Adds the session-regenerate-cookie-value function (Florian Margaine)
Bugfix: using variables within with-accessors (Dmitry Igrishin)
Added Gitter link (The Gitter Badger)
Add "charset" property to Content-Type HTTP header (Dmitry Igrishin)
"Connection: close" on unthreaded builds (Philipp Marek)
Make the RFC 6585 status constants external (Grim Schjetne)
Add HTTP status codes described in RFC 6585 (Grim Schjetne)
Add charset to Content-Type when serving static (Dmitry Igrishin)
Fix to PROCESS-CONNECTION leaking socket fds (Jussi Lahdenniemi)
Version 1.2.31
2015-03-06
Adds HttpOnly and remove cookie on remove-session (Florian MARGAINE)
Version 1.2.30
2015-02-25
Clear content-length before emitting 304 (Jason Miller)
Treat errors during url decoding as bad requests. (Stas Boukarev)
Version 1.2.29
2014-11-30
temporarily revert ipv6 changes (Hans Huebner)
Version 1.2.28
2014-11-28
Remove dead links and update support information (Hans Huebner)
restore listening to usocket:*wildcard-host* (Hans Huebner)
deal with IPv6 addresses from usocket (Hans Huebner)
eliminate duplicate logging of warnings (reported by loke) (Hans Huebner)
add DETACH-SOCKET function (Hans Huebner)
Add the ability to prevent the sockets from being closed after a request has been processed. (Elias Mårtenson)
document *FINISH-PROCESSING-SOCKET* (Hans Huebner)
Make check for stream timeouts more robust (Raymond Wiker)
Version 1.2.27
2014-05-18
fix warning about missing NAME keyword arg at start-thread (Mark H. David)
remove tbnl-announce list (Hans Huebner)
correct speling eror (Hans Huebner)
Update request.lisp (muyinliu)
file upload file name encoding error fixed (muyinliu)
support use of logical file names for document-root and error-template-directory (Hans Huebner)
Generate www/hunchentoot-doc.html. (Stas Boukarev)
Remove mentions of asdf-install and the darcs mirror from docs. (Stas Boukarev)
Version 1.2.26
2014-01-18
Optimize get-peer/local-address-and-port. (Stas Boukarev)
Close SSL streams after processing connection. (Stas Boukarev)
Version 1.2.25
2014-01-17
allow for handler setting of the "connection" header (William Halliburton)
Version 1.2.24
2014-01-07
Use version number from ASDF system definition, not special var (Hans Huebner)
Version 1.2.23
2014-01-05
Don't set the Connection header to Close if it's already set (AndrejSuc/Stas Boukarev)
Version 1.2.22
2013-12-09
Print header value (if number) in base 10 (Chaitanya Gupta)
Fix for CLISP compilation (Anton Vodonosov)
Version 1.2.21
2013-10-04
Fix capitalization inconsistencies in docs (reported by Stas Boukarev)
Version 1.2.20
2013-10-04
Don't rely on asdf to find default document directory
Add m4v mime type (Wes Henderson)
Version 1.2.19
2013-07-28
Fix ACCEPTOR-REMOVE-SESSION default implementation (Stas Boukarev, Mathieu Lemoine)
Version 1.2.18
2013-05-03
Prevent errors when basic auth user or password contains colon
Add missing implementation for client-as-string for Lispworks, contributed by Raymond Wiker
Version 1.2.17
2013-04-01
New START-THREAD API function (Faré Rideau)
Version 1.2.16
2013-03-31
Fix bug that caused error when requesting nonexistent page.
Version 1.2.15
2013-03-17
Fix race condition in acceptor shutdown (Faré Rideau)
Version 1.2.14
2013-03-08
Call ACCEPTOR-STATUS-MESSAGE in a saner and more useful fashion (sponsored by Ron Garret)
Version 1.2.13
2013-03-03
fix wrong documented signature in acceptor-status-message (reported by Zach Beane)
Version 1.2.12
2013-03-03
Various documentation updates
Fix bug in static file handling that caused Safari to hang on 304 responses by Hunchentoot (reported by Wim Oudshoorn)
Version 1.2.11
2013-01-27
Fix bug in MD5-HEX that could cause session keys to be reused
Version 1.2.10
2013-01-19
Add local-addr* and local-port* functions
Version 1.2.9
2012-12-28
Fix test script to accomodate for Drakma fix regarding redirect from POST to GET
Fix range handling once again
Version 1.2.8
2012-12-19
ECL fixes (Juan Jose Giarcia-Ripoll)
Version 1.2.7
2012-10-19
Fix documentation for COOKIE-IN, which returns a string, not a cookie.
Hunchentoot could not deal with / pointing to a static file directory (Stas Boukarev).
Fixes to pathname sanitizing when handling static files.
Further Range: header handling fixes
Fix some export names relating to taskmaster thread count (Faré Rideau)
Version 1.2.6
2012-09-02
Doc fixes, add .pre-release.sh script
Version 1.2.5
2012-09-02
High-load multithread stability fixes (Mathieu Lemoine)
Version 1.2.4
2012-08-16
Remove dead code & style fixes (Ala'a Mohammad)
Bug fix: setting *print-base* / *print-radix* caused invalid cookie values (Scott L. Burson)
Various documentation and style updates
Fix documentation bug found (Mathieu Lemoine)
Fix bug that could hang Hunchentoot under load (Mathieu Lemoine)
Version 1.2.3
2012-03-03
Fix crash when error occurs while logging error (reported by Xu Jingtao)
Fix compilation with :hunchentoot-no-ssl feature (Mark Evenson)
Fix Range header handling (Simon Sandlund)
Export acceptor-remove-session
ECL timeout support (Juan Jose Giarcia-Ripoll)
Changed cookie handling - Hunchentoot no longer encodes cookies
automatically. Applications must make sure that they only set cookies
to permitted values (refer to RFC6265 for the details, thanks to Ralf
Stoye for debugging help)
Version 1.2.2
2011-11-30
Fix warning on LispWorks (Nico de Jager)
Documentation updates
Remove obsolete symbols from export list
Add easy-ssl-acceptor
Document acceptor-remove-session, remove obsolete *session-removal-hook* export (Issue #15)
Added :description to asdf system definition
Add documentation section describing how to bind to privileged ports
Version 1.2.1
2011-11-04
Use FINISH-OUTPUT instead of FORCE-OUTPUT at connection end (I. Perminov)
Documentation updates
External format EOL style fixes for Windows (Anton Kovalenko)
Version 1.2.0
2011-10-30
Fix to allow send-service-unavailable-reply to work (Faré Rideau)
Make sure we always have a cooked message to send in case of error (Faré Rideau)
Add www/ directory with default file tree that is being served
Add error template mechanism and improve error reporting in general.
Improve automatic testing, SBCL kludge to support asdf:test-op
Allegro CL modern mode fixes
Fix bugs in serving partial responses
Limit maximum number of threads that Hunchentoot creates (Dan Weinreb, Scott McKay)
Export fixes (Gordon Sims, Andrey Moskvitin, Faré Rideau)
Factor out easy-handler logic into separate acceptor subclass
Export two session functions (Nico de Jager)
Allow no Content-Type header (Chaitanya Gupta)
Patch for compilation with ECL (Sohail Somani)
Fix DEFINE-EASY-HANDLER for multiple acceptors (Nicolas Neuss)
Revived *SHOW-LISP-BACKTRACES-P*
Made sure "100 Continue" is returned even if the client sends "Expect: 100-continue" twice (reported by Gordon Sims)
Fixed typo in code which interprets transfer encodings
Version 1.1.1
2010-08-24
Exported WITHIN-REQUEST-P (Faré Rideau)
Safeguard measures against XSS attacks (J.P. Larocque)
Prevent potential leak when closing stream (Matt Lamari, Martin Simmons)
Change some occurrences of HANDLER-CASE* to HANDLER-CASE (Hans Hübner, Allan Dee)
Version 1.1.0
2010-01-08
Architectural changes - see HANDLE-REQUEST (thanks to Andreas Fuchs and Frode Fjeld)
Re-introduced *CATCH-ERRORS-P* and MAYBE-INVOKE-DEBUGGER
Integration with trivial-backtrace (see *LOG-LISP-BACKTRACES-P*)
Treat :UNSPECIFIC like NIL in pathname components (reported by Frode Fjeld)
Fixed RESET-SESSIONS
Prepared for LispWorks 6 (Nico de Jager)
Fixed reading of post parameters (Peter Seibel and Stephen P. Compall)
Fixed STOP by supplying the :READY-ONLY keyword to USOCKET:WAIT-FOR-INPUT
Enabled SSL key passwords for Lisps other than LW (Vsevolod)
Version 1.0.0
2009-02-19
Complete architectural redesign (together with Hans Hübner)
Lots of small fixes and improvements, too many to enumerate here
Version 0.15.6
2008-04-09
Fixed embarrassingly mis-placed parentheses (thanks to Hans Hübner)
Version 0.15.5
2008-04-08
Removed FORCE-OUTPUT* and thus the ACL-COMPAT dependency (thanks to Hans Hübner)
Support for MP-less CMUCL (thanks to Hans Hübner)
Version 0.15.4
2008-03-27
Fixed unportable LOOP usage (caught by "C S S")
Version 0.15.3
2008-03-17
Added CODE parameter to REDIRECT (thanks to Michael Weber)
Version 0.15.2
2008-03-06
Fixed typo in test.lisp (thanks to Ben Hyde)
Changed wrong usage of EQ to EQL (thanks to Ariel Badichi)
Fixed typo in default handler (thanks to Eugene Ossintsev)
Version 0.15.1
2008-02-13
Uses CL-FAD for HANDLE-STATIC-FILE now
Better error reporting for CREATE-FOLDER-DISPATCHER-AND-HANDLER (suggested by Cyrus Harmon)
Faster version of WRITE-HEADER-LINE (thanks to V. Segu�)
Version 0.15.0
2007-12-29
Added support for CLISP (thanks to Anton Vodonosov)
Version 0.14.7
2007-11-15
Replace ENOUGH-NAMESTRING with ENOUGH-URL (patch by Kilian Sprotte and Hans Hübner)
Version 0.14.6
2007-11-08
Fix compilation order (thanks to Tiarnan O'Corrain and Chris Dean)
Version 0.14.5
2007-10-21
Robustified MAKE-SOCKET-STREAM against potential leak (thanks to Alain Picard)
Replaced #-FOO #-FOO constructs for OpenMCL (patch by Michael Weber)
Updated tutorial links
Version 0.14.4
2007-10-20
Made log stream shared on OpenMCL (thanks to Gary Byers)
Version 0.14.3
2007-10-07
Enabled GET-GID-FROM-NAME for newer versions of SBCL (patch by Cyrus Harmon)
Version 0.14.2
2007-09-26
Better handling of PORT parameter in REDIRECT (thanks to Vladimir Sedach)
Version 0.14.1
2007-09-24
Fixed bug where you couldn't set "Server" header (caught by Ralf Mattes)
Documentation clarification for HEADER-OUT function
Version 0.14.0
2007-09-18
Added support for "HttpOnly" cookie attribute
Version 0.13.0
2007-09-14
Added *METHODS-FOR-POST-PARAMETERS* (suggested by Jonathon McKitrick)
Version 0.12.1
2007-09-13
Better support for WITH-TIMEOUT on SBCL/Win32 (thanks to Anton Vodonosov)
Version 0.12.0
2007-09-07
Now uses bound for flexi stream returned by RAW-POST-DATA
Needs FLEXI-STREAMS 0.12.0 or higher
Version 0.11.2
2007-09-05
Fixed typo in docs
Added declaration in server.lisp to appease SBCL
Version 0.11.1
2007-05-25
Fixes for OpenMCL (thanks to Lennart Staflin and Tiarnan O'Corrain)
Version 0.11.0
2007-05-25
Added server names and coupled them with easy handlers (suggested by Mac Chan)
Exported SESSION-COOKIE-VALUE instead of SESSION-STRING (suggested by Slava Akhmechet)
Documentation fixes (thanks to Victor Kryukov and Igor Plekhov)
Version 0.10.0
2007-05-12
Made MAYBE-INVOKE-DEBUGGER a generic function and exported it (suggested by Vladimir Sedach)
Version 0.9.3
2007-05-08
Fixed CREATE-FOLDER-DISPATCHER-AND-HANDLER in the presence of URL-encoded URLs (bug caught by Nicolas Lamirault)
Version 0.9.2
2007-05-01
Made DEF-HTTP-RETURN-CODE more flexible (suggested by Jong-won Choi)
Version 0.9.1
2007-04-29
Added PORT parameter to REDIRECT (suggested by Cyrus Harmon)
Exported REMOVE-SESSION (suggested by Vamsee Kanakala)
Version 0.9.0
2007-04-19
Added socket timeouts for AllegroCL
Catch IO timeout conditions for AllegroCL, SBCL and CMUCL (suggested by Red Daly and others)
Added per-server dispatch tables (suggested by Robert Synnott and Andrei Stebakov)
Version 0.8.6
2007-04-18
USE the CL package explicitly when defining HUNCHENTOOT-MP (bug report by Joel Boehland)
Version 0.8.5
2007-04-10
Correct behaviour for "100 Continue" responses
Version 0.8.4
2007-04-09
Cleanup
Version 0.8.3
2007-04-07
Don't use chunked encoding for empty (NIL) bodies
Version 0.8.2
2007-04-05
Really exported REASON-PHRASE this time (and also *CURRENT-PROCESS*)
Version 0.8.1
2007-04-04
Added HUNCHENTOOT-MP package (suggested by Cyrus Harmon)
Only invoke MARK-AND-SWEEP for 32-bit versions of LW (thanks to Chris Dean)
Exported REASON-PHRASE
Version 0.8.0
2007-03-31
Added *APPROVED-RETURN-CODES*, *HEADER-STREAM*, and +HTTP-FAILED-DEPENDENCY+
Exported MIME-TYPE and SSL-P
Some minor changes
Version 0.7.3
2007-03-28
Added +HTTP-MULTI-STATUS+
Version 0.7.2
2007-03-09
Fix test suite to properly handle non-base characters in LW (bug caught by Jong-won Choi)
Version 0.7.1
2007-03-09
Fixed last change (thanks to Marko Kocic)
Version 0.7.0
2007-03-09
Development port (no threads) to SBCL/Win32 (patch by Marko Kocic)
Support for compilation without SSL
Version 0.6.2
2007-02-22
Don't use NSTRING-UPCASE for outgoing headers (bug caught by Saurabh Nanda)
Changed ProxyPass example in docs from /lisp to /hunchentoot
Version 0.6.1
2007-01-24
Reset to "faithful" external format on each iteration (bug caught by Viljo Marrandi and Ury Marshak)
Version 0.6.0
2007-01-23
Accept chunked transfer encoding for mod_lisp request bodies (thanks to Hugh Winkler's mod_lisp additions)
Robustify against erroneous form-data submissions (caught by Ury Marshak)
Version 0.5.1
2007-01-18
Even more flexible behaviour of RAW-POST-DATA
Version 0.5.0
2007-01-17
More flexible behaviour of RAW-POST-DATA
Robustified PARSE-CONTENT-TYPE
Version 0.4.14
2007-01-17
More meaningful results for RAW-POST-DATA
Version 0.4.13
2007-01-14
Added favicon.ico to example website (thanks to Yoni Rabkin Katzenell, Toby, and Uwe von Loh)
Version 0.4.12
2006-12-27
Added Hunchentoot logo by Uwe von Loh
Version 0.4.11
2006-12-01
Exported symbols related to session GC (suggested by Nico de Jager)
Version 0.4.10
2006-11-19
Added *HANDLE-HTTP-ERRORS-P* (thanks to Marijn Haverbeke)
Remove duplicate headers when reading from mod_lisp
Version 0.4.9
2006-11-12
Fixed HEADER-OUT (thanks to Robert J. Macomber)
Version 0.4.8
2006-11-06
Fixed bug in START-OUTPUT which confused mod_lisp
Version 0.4.7
2006-11-06
Changed behaviour of REAL-REMOTE-ADDR (as suggested by Robert J. Macomber)
Fixed COOKIE-OUT (thanks to Robert J. Macomber)
Version 0.4.6
2006-11-05
Don't bind *DISPATCH-TABLE* too early (thanks to Marijn Haverbeke)
Version 0.4.5
2006-10-25
Fixed bug in AUTHORIZATION function (reported by Michael J. Forster)
Version 0.4.4
2006-10-12
Correct SSL check in REDIRECT function
LOG-MESSAGE now checks for (BOUNDP '*SERVER*)
Version 0.4.3
2006-10-11
OpenMCL fixes (by Ralf Stoye)
Version 0.4.2
2006-10-10
No timeouts for mod_lisp servers (as in Hunchentoot 0.3.x)
Version 0.4.1
2006-10-10
Fixed a typo in easy-handlers.lisp (caught by Travis Cross)
Version 0.4.0
2006-10-10
Ported to CMUCL, SBCL, OpenMCL, and AllegroCL
Merged with TBNL
Tons of small changes, too many to list them individually
Version 0.3.2
2006-09-14
Uses TBNL's WITH-DEBUGGER now
Version 0.3.1
2006-09-14
Added *CATCH-ERRORS-P* (from TBNL)
Version 0.3.0
2006-09-05
Accept HTTP requests with chunked transfer encoding
Use Chunga for chunking
Version 0.2.2
2006-08-31
Skip START-OUTPUT advice completely if working for TBNL
Version 0.2.1
2006-08-28
Added write timeouts for LW 5.0
Updated LW links in documentation
Version 0.2.0
2006-08-28
Serves as infrastructure for TBNL now (to replace KMRCL)
For HTTP/1.1 only send 'Keep-Alive' headers if explicitly requested
Version 0.1.5
2006-08-23
Connection headers are separated by commas, not semicolons
Version 0.1.4
2006-08-22
Refactored streams.lisp to appease LW compiler (thanks to Martin Simmons)
Changed handling of version string
Changed package handling in system definition (thanks to Christophe Rhodes)
Version 0.1.3
2006-02-08
Removed KMRCL workaround
Version 0.1.2
2006-01-03
Mention TBNL version number in server name header
Version 0.1.1
2005-12-31
Fixed package stuff and HYPERDOC support
Version 0.1.0
2005-12-31
Initial public release
[For earlier changes see the file "CHANGELOG_TBNL" that is included with the release.]
hunchentoot-v1.2.38/lispworks.lisp 0000755 0000000 0000000 00000013253 13211004253 015753 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; make sure socket code is loaded
(require "comm"))
(defun get-env-variable-as-directory (name)
"Retrieves the environment variable named NAME and interprets it as
the pathname of a directory which is returned."
(lw:when-let (string (lw:environment-variable name))
(when (plusp (length string))
(cond ((find (char string (1- (length string))) "\\/" :test #'char=) string)
(t (lw:string-append string "/"))))))
(defmacro with-rebinding (bindings &body body)
"Renaming LW:REBINDING for better indentation."
`(lw:rebinding ,bindings ,@body))
#+(and :lispworks4.4 (or :win32 :linux))
(let ((id :system-cons-free-chain))
(unless (scm::patch-id-loaded-p id)
(error "You need a patch to improve the performance of this code. Request patch ~S for ~A for ~A from lisp-support@lispworks.com using the Report Bug command."
id (lisp-implementation-type)
#+:win32 "Windows"
#+:linux "Linux")))
(defvar *cleanup-interval* 100
"Should be NIL or a positive integer. The system calls
*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads
\(counted globally across all acceptors) have been created unless the
value is NIL. The initial value is 100.
This variable is only available on LispWorks.")
(defvar *cleanup-function* 'cleanup-function
"A designator for a function without arguments which is called on a
regular basis if *CLEANUP-INTERVAL* is not NIL. The initial value is
the name of a function which invokes a garbage collection on 32-bit
versions of LispWorks.
This variable is only available on LispWorks.")
(defvar *worker-counter* 0
"Internal counter used to count worker threads. Needed for
*CLEANUP-FUNCTION*.")
(defun cleanup-function ()
"The default for *CLEANUP-FUNCTION*. Invokes a GC on 32-bit
LispWorks."
#-:lispworks-64bit
(hcl:mark-and-sweep 2))
(defun get-peer-address-and-port (socket)
"Returns the peer address and port of the socket SOCKET as two
values. The address is returned as a string in dotted IP address
notation."
(multiple-value-bind (peer-addr peer-port)
(comm:get-socket-peer-address socket)
(values (ignore-errors (comm:ip-address-string peer-addr)) peer-port)))
(defun get-local-address-and-port (socket)
"Returns the local address and port of the socket SOCKET as two
values. The address is returned as a string in dotted IP address
notation."
(multiple-value-bind (local-addr local-port)
(comm:get-socket-address socket)
(values (ignore-errors (comm:ip-address-string local-addr)) local-port)))
(eval-when (:compile-toplevel :load-toplevel)
(when (let ((sym (find-symbol "STREAM-READ-TIMEOUT" :stream)))
(and sym (fboundp sym)))
(pushnew :stream-has-timeouts *features*)))
(defun make-socket-stream (socket acceptor)
"Returns a stream for the socket SOCKET. The ACCEPTOR argument is
used to set the timeouts."
#-stream-has-timeouts
(when (acceptor-write-timeout acceptor)
(parameter-error "You need LispWorks 5 or higher for write timeouts."))
(make-instance 'comm:socket-stream
:socket socket
:direction :io
:read-timeout (acceptor-read-timeout acceptor)
#+stream-has-timeouts #+stream-has-timeouts
:write-timeout (acceptor-write-timeout acceptor)
:element-type 'octet))
(defun make-lock (name)
"Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
(mp:make-lock :name name))
(defmacro with-lock-held ((lock) &body body)
"Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
`(mp:with-lock (,lock) ,@body))
;; some help for the IDE
(dspec:define-dspec-alias defvar-unbound (name)
`(defparameter ,name))
(dspec:define-dspec-alias def-http-return-code (name)
`(defconstant ,name))
(editor:setup-indent "defvar-unbound" 1 2 4)
(editor:setup-indent "def-http-return-code" 1 2 4)
(editor:setup-indent "handler-case*" 1 2 4)
(defun make-condition-variable (&key name)
(declare (ignore name))
(mp:make-condition-variable))
(defun condition-variable-signal (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun condition-variable-wait (condition-variable lock)
(mp:condition-variable-wait condition-variable lock))
hunchentoot-v1.2.38/hunchentoot.asd 0000644 0000000 0000000 00000007751 13211004253 016057 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :hunchentoot-asd
(:use :cl :asdf))
(in-package :hunchentoot-asd)
(defsystem :hunchentoot
:serial t
:version "1.2.38"
:description "Hunchentoot is a HTTP server based on USOCKET and
BORDEAUX-THREADS. It supports HTTP 1.1, serves static files, has a
simple framework for user-defined handlers and can be extended
through subclassing."
:license "BSD-2-Clause"
:depends-on (:chunga
:cl-base64
:cl-fad
:cl-ppcre
:flexi-streams
#-(or :lispworks :hunchentoot-no-ssl) :cl+ssl
:md5
:rfc2388
:trivial-backtrace
#-:lispworks :usocket
#-:lispworks :bordeaux-threads)
:components ((:module url-rewrite
:serial t
:components ((:file "packages")
(:file "specials")
(:file "primitives")
(:file "util")
(:file "url-rewrite")))
(:file "packages")
#+:lispworks (:file "lispworks")
#-:lispworks (:file "compat")
(:file "specials")
(:file "conditions")
(:file "mime-types")
(:file "util")
(:file "log")
(:file "cookie")
(:file "reply")
(:file "request")
(:file "session")
(:file "misc")
(:file "headers")
(:file "set-timeouts")
(:file "taskmaster")
(:file "acceptor")
#-:hunchentoot-no-ssl (:file "ssl")
(:file "easy-handlers")))
(defsystem :hunchentoot-test
:description "Self test functionality for the Hunchentoot HTTP server."
:components ((:module "test"
:serial t
:components ((:file "packages")
(:file "test-handlers")
(:file "script-engine")
(:file "script"))))
:depends-on (:hunchentoot :cl-who :cl-ppcre :drakma))
(defmethod perform ((o test-op) (c (eql (find-system 'hunchentoot))))
(load (merge-pathnames "run-test.lisp" (system-source-directory c))))
(defsystem :hunchentoot-dev
:description "Development tools for Hunchentoot development and releases"
:components ((:file "make-docstrings"))
:depends-on (:hunchentoot
:hunchentoot-test
:xpath
:cxml-stp
:swank))
hunchentoot-v1.2.38/url-rewrite/ 0000755 0000000 0000000 00000000000 13211004253 015277 5 ustar root root hunchentoot-v1.2.38/url-rewrite/packages.lisp 0000644 0000000 0000000 00000003214 13211004253 017746 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage #:url-rewrite
(:use :cl)
(:export #:*url-rewrite-tags*
#:*url-rewrite-fill-tags*
#:starts-with-scheme-p
#:add-get-param-to-url
#:rewrite-urls
#:url-encode)) hunchentoot-v1.2.38/url-rewrite/primitives.lisp 0000644 0000000 0000000 00000015632 13211004253 020372 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :url-rewrite)
(declaim (inline peek-char*))
(defun peek-char* ()
"PEEK-CHAR with input stream bound to *STANDARD-INPUT* and returning
NIL on EOF."
(peek-char nil nil nil))
(declaim (inline whitespacep))
(defun whitespacep (c)
"Checks whether C is a whitespace character."
(find c '(#\Space #\Tab #\Newline #\Linefeed #\Return #\Page)))
(declaim (inline letterp))
(defun letterp (c)
"Checks whether C is a character between A and Z
\(case-insensitive)."
(and (characterp c)
(or (char<= #\a c #\z)
(char<= #\A c #\Z))))
(declaim (inline name-char-p))
(defun name-char-p (c)
"Checks whether C is a name constituent character in the sense of
HTML."
(and (characterp c)
(or (letterp c)
(digit-char-p c)
(char= c #\-)
(char= c #\.))))
(defun comment-start-p ()
"Checks whether *STANDARD-OUTPUT* currently 'looks at' the string
\"--\". Will move the position within the stream by one unless the
first characters it sees is not a hyphen."
(unless (eql (peek-char*) #\-)
;; if the first character isn't #\- we can return immediately
(return-from comment-start-p nil))
;; otherwise read the #\- so we can check the next character
(read-char)
(eql (peek-char*) #\-))
(defun read-while (predicate &key (skip t) (write-through t))
"Reads characters from *STANDARD-INPUT* while PREDICATE returns a
true value for each character. Returns the string which was read
unless SKIP is true. Writes all characters read to *STANDARD-OUTPUT*
if WRITE-THROUGH is true. On EOF the string read so far is returned."
(let ((collector (or skip
(make-array 0
:element-type 'character
:fill-pointer t
:adjustable t))))
(handler-case
(loop while (funcall predicate (peek-char)) do
(let ((char (read-char)))
(when write-through
(write-char char))
(unless skip
(vector-push-extend char collector)))
finally (return (and (not skip) collector)))
(end-of-file ()
(and (not skip) collector)))))
(defun read-until (string &key (skip t) (write-through t))
"Reads characters from *STANDARD-INPUT* up to and including STRING.
Returns the string which was read \(excluding STRING) unless SKIP is
true. Writes all characters read to *STANDARD-OUTPUT* if
WRITE-THROUGH is true. On EOF the string read so far is returned."
(let* ((length (length string))
(offsets
;; we first check whether some substring which starts
;; STRING can be found again later in STRING - this is
;; necessary because we only peek one character ahead
(cond ((gethash string *find-string-hash*))
(t (setf (gethash string *find-string-hash*)
;; the resulting array of offsets is
;; cached in *FIND-STRING-HASH* so we can
;; use it again in case READ-UNTIL is
;; called with the same STRING argument
(loop with offsets = (make-array length
:initial-element nil)
for i from 1 below length
;; check if STRING starting from 0
;; has something in common with
;; STRING starting from I
for mismatch = (mismatch string string
:start1 i :test #'char=)
when (> mismatch i)
;; if this is the case remember the
;; length of the match plus the
;; character which must follow in
;; OFFSETS
do (push (cons (char string (- mismatch i))
(1+ (- mismatch i)))
(svref offsets i))
finally (return offsets))))))
(collector (or skip
(make-array 0
:element-type 'character
:fill-pointer t
:adjustable t))))
(handler-case
(loop for i = 0 then (cond (match (1+ i))
;; if there is an offset (see above)
;; we don't have to start from the
;; beginning of STRING
((cdr (assoc c (svref offsets i))))
(t 0))
for c = (peek-char)
for match = (char= c (char string i))
while (or (not match) (< (1+ i) length)) do
(cond (skip (read-char))
(t (vector-push-extend (read-char) collector)))
when write-through do
(write-char c)
finally (if write-through
(write-char (read-char))
(read-char))
(unless skip
;; decrement the fill pointer because collector now also
;; contains STRING itself
(decf (fill-pointer collector) (1- length)))
(return (and (not skip) collector)))
(end-of-file ()
(and (not skip) collector)))))
hunchentoot-v1.2.38/url-rewrite/url-rewrite.lisp 0000644 0000000 0000000 00000037565 13211004253 020471 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :url-rewrite)
(defun starts-with-scheme-p (string)
"Checks whether the string STRING represents a URL which starts with
a scheme, i.e. something like 'https://' or 'mailto:'."
(loop with scheme-char-seen-p = nil
for c across string
when (or (char-not-greaterp #\a c #\z)
(digit-char-p c)
(member c '(#\+ #\- #\.) :test #'char=))
do (setq scheme-char-seen-p t)
else return (and scheme-char-seen-p
(char= c #\:))))
(defun url-encode (string)
"URL-encode a string."
(with-output-to-string (s)
(loop for c across string
do (cond ((or (char<= #\0 c #\9)
(char<= #\a c #\z)
(char<= #\A c #\Z)
(find c "$-_.!*'()," :test #'char=))
(write-char c s))
((char= c #\Space)
(write-char #\+ s))
(t (format s "%~2,'0x" (char-code c)))))))
(defun add-get-param-to-url (url name value)
"URL is assumed to be a http URL. The pair of NAME and VALUE will be
added as a GET parameter to this URL. Assumes that there's no other
parameter of the same name. Only checks if #\? is part of the string
to decide how to attach the new parameter to the end of the string."
;; possible bug: doesn't check for #\? which is written as, say,
;; "&x3f;" - also, is there any other way a question mark could be a
;; legitimate part of a URL?
(concatenate 'string
url
(if (find #\? url :test #'char=)
"&"
"?")
name
"="
(url-encode value)))
(defun rewrite-urls (rewrite-fn &optional (test-fn (complement #'starts-with-scheme-p)))
"Reads an \(X)HTML document from *STANDARD-INPUT* and writes it back
to *STANDARD-OUTPUT*. Any attribute value which is in one of the
positions denoted by *URL-REWRITE-TAGS* is rewritten by REWRITE-FN if
it passes the test denoted by the optional function TEST-FN which
defaults to the complement of STARTS-WITH-SCHEME-P.
This function aims to yield correct results for correct \(X)HTML input
and it also tries hard to never signal an error although it may warn
if it encounters syntax errors. It will NOT detect any possible error
nor is there any warranty that it will work correctly with faulty
input."
(loop
;; read (and write back) until we see a #\< which is a candidate
;; for a tag or a markup declaration
(read-until "<")
;; get next char without reading it
(let ((peek-char (peek-char*)))
(cond ((null peek-char)
;; stop if EOF
(return-from rewrite-urls))
((char= peek-char #\!)
;; we've seen ")
;; "" is nothing special, just write the
;; char and go back to the start of the loop
(write-char (read-char)))
((letterp peek-char)
;; a letter, so this should be something like
;; - we just check for names and
;; delimited strings separated by whitespace
;; until we see the next #\>
(read-name)
(skip-whitespace)
(block parameter-loop
(loop
(let ((peek-char (peek-char*)))
(cond ((null peek-char)
;; stop if EOF
(warn "EOF in markup declaration")
(return-from rewrite-urls))
((char= peek-char #\>)
;; a #\> ends the markup
;; declaration - write it back
;; and exit the loop
(write-char (read-char))
(return-from parameter-loop))
((or (letterp peek-char)
(find peek-char '(#\' #\") :test #'char=))
;; a delimiter or a letter, so
;; we expect a delimited string
(read-delimited-string)
(skip-whitespace))
((comment-start-p)
;; a comment - skip it and write it back
(skip-comment))
(t
;; something else - this is an error
;; so we warn and exit the loop
(warn "Unexpected character ~S in markup declaration"
peek-char)
(return-from parameter-loop)))))))
((comment-start-p)
;; we've seen "
<xsl:value-of select="clix:title"/>
[]
=>
[]
=>
=>
[]
(setf (
) new-value)
=>
[]
=>
(setf (
) new-value)
=>
(setf (
) new-value)
[]
[Constants]
[]
[]
&
-
#
-
#
#
-
Generic function
Method
Macro
Function
Generic reader
Specialized reader
Reader
Generic reader
Specialized reader
Reader
Generic readers
Specialized readers
Readers
Generic accessors
Specialized accessors
Accessors
Generic writer
Specialized writer
Writer
Generic accessor
Specialized accessor
Accessor
Generic accessor
Specialized accessor
Accessor
Special variable
Standard class
Condition type
Symbol
Constant
Constant
hunchentoot-v1.2.38/mime-types.lisp 0000644 0000000 0000000 00000055407 13211004253 016013 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defparameter *mime-type-list* '(("application/andrew-inset" "ez")
("application/cu-seeme" "cu")
("application/dsptype" "tsp")
("application/futuresplash" "spl")
("application/hta" "hta")
("application/java-archive" "jar")
("application/java-serialized-object" "ser")
("application/java-vm" "class")
("application/mac-binhex40" "hqx")
("application/mac-compactpro" "cpt")
("application/mathematica" "nb")
("application/msaccess" "mdb")
("application/msword" "doc" "dot")
("application/octet-stream" "bin")
("application/oda" "oda")
("application/ogg" "ogg")
("application/pdf" "pdf")
("application/pgp-keys" "key")
("application/pgp-signature" "pgp")
("application/pics-rules" "prf")
("application/postscript" "ps" "ai" "eps")
("application/rar" "rar")
("application/rdf+xml" "rdf")
("application/rss+xml" "rss")
("application/smil" "smi" "smil")
("application/wordperfect" "wpd")
("application/wordperfect5.1" "wp5")
("application/xhtml+xml" "xhtml" "xht")
("application/xml" "fo" "xml" "xsl")
("application/zip" "zip")
("application/vnd.cinderella" "cdy")
("application/vnd.mozilla.xul+xml" "xul")
("application/vnd.ms-excel" "xls" "xlb" "xlt")
("application/vnd.ms-pki.seccat" "cat")
("application/vnd.ms-pki.stl" "stl")
("application/vnd.ms-powerpoint" "ppt" "pps")
("application/vnd.oasis.opendocument.chart" "odc")
("application/vnd.oasis.opendocument.database" "odb")
("application/vnd.oasis.opendocument.formula" "odf")
("application/vnd.oasis.opendocument.graphics" "odg")
("application/vnd.oasis.opendocument.graphics-template" "otg")
("application/vnd.oasis.opendocument.image" "odi")
("application/vnd.oasis.opendocument.presentation" "odp")
("application/vnd.oasis.opendocument.presentation-template" "otp")
("application/vnd.oasis.opendocument.spreadsheet" "ods")
("application/vnd.oasis.opendocument.spreadsheet-template" "ots")
("application/vnd.oasis.opendocument.text" "odt")
("application/vnd.oasis.opendocument.text-master" "odm")
("application/vnd.oasis.opendocument.text-template" "ott")
("application/vnd.oasis.opendocument.text-web" "oth")
("application/vnd.rim.cod" "cod")
("application/vnd.smaf" "mmf")
("application/vnd.stardivision.calc" "sdc")
("application/vnd.stardivision.draw" "sda")
("application/vnd.stardivision.impress" "sdd" "sdp")
("application/vnd.stardivision.math" "smf")
("application/vnd.stardivision.writer" "sdw" "vor")
("application/vnd.stardivision.writer-global" "sgl")
("application/vnd.sun.xml.calc" "sxc")
("application/vnd.sun.xml.calc.template" "stc")
("application/vnd.sun.xml.draw" "sxd")
("application/vnd.sun.xml.draw.template" "std")
("application/vnd.sun.xml.impress" "sxi")
("application/vnd.sun.xml.impress.template" "sti")
("application/vnd.sun.xml.math" "sxm")
("application/vnd.sun.xml.writer" "sxw")
("application/vnd.sun.xml.writer.global" "sxg")
("application/vnd.sun.xml.writer.template" "stw")
("application/vnd.symbian.install" "sis")
("application/vnd.visio" "vsd")
("application/vnd.wap.wbxml" "wbxml")
("application/vnd.wap.wmlc" "wmlc")
("application/vnd.wap.wmlscriptc" "wmlsc")
("application/x-123" "wk")
("application/x-abiword" "abw")
("application/x-apple-diskimage" "dmg")
("application/x-bcpio" "bcpio")
("application/x-bittorrent" "torrent")
("application/x-cdf" "cdf")
("application/x-cdlink" "vcd")
("application/x-chess-pgn" "pgn")
("application/x-cpio" "cpio")
("application/x-csh" "csh")
("application/x-debian-package" "deb" "udeb")
("application/x-director" "dcr" "dir" "dxr")
("application/x-dms" "dms")
("application/x-doom" "wad")
("application/x-dvi" "dvi")
("application/x-flac" "flac")
("application/x-font" "pfa" "pfb" "gsf" "pcf")
("application/x-freemind" "mm")
("application/x-futuresplash" "spl")
("application/x-gnumeric" "gnumeric")
("application/x-go-sgf" "sgf")
("application/x-graphing-calculator" "gcf")
("application/x-gtar" "gtar" "tgz" "taz")
("application/x-hdf" "hdf")
("application/x-httpd-php" "phtml" "pht" "php")
("application/x-httpd-php-source" "phps")
("application/x-httpd-php3" "php3")
("application/x-httpd-php3-preprocessed" "php3p")
("application/x-httpd-php4" "php4")
("application/x-ica" "ica")
("application/x-internet-signup" "ins" "isp")
("application/x-iphone" "iii")
("application/x-iso9660-image" "iso")
("application/x-java-jnlp-file" "jnlp")
("application/x-javascript" "js")
("application/x-jmol" "jmz")
("application/x-kchart" "chrt")
("application/x-killustrator" "kil")
("application/x-koan" "skp" "skd" "skt" "skm")
("application/x-kpresenter" "kpr" "kpt")
("application/x-kspread" "ksp")
("application/x-kword" "kwd" "kwt")
("application/x-latex" "latex")
("application/x-lha" "lha")
("application/x-lzh" "lzh")
("application/x-lzx" "lzx")
("application/x-maker" "frm" "maker" "frame" "fm" "fb" "book" "fbdoc")
("application/x-mif" "mif")
("application/x-ms-wmd" "wmd")
("application/x-ms-wmz" "wmz")
("application/x-msdos-program" "com" "exe" "bat" "dll")
("application/x-msi" "msi")
("application/x-netcdf" "nc")
("application/x-ns-proxy-autoconfig" "pac")
("application/x-nwc" "nwc")
("application/x-object" "o")
("application/x-oz-application" "oza")
("application/x-pkcs7-certreqresp" "p7r")
("application/x-pkcs7-crl" "crl")
("application/x-python-code" "pyc" "pyo")
("application/x-quicktimeplayer" "qtl")
("application/x-redhat-package-manager" "rpm")
("application/x-sh" "sh")
("application/x-shar" "shar")
("application/x-shockwave-flash" "swf" "swfl")
("application/x-stuffit" "sit")
("application/x-sv4cpio" "sv4cpio")
("application/x-sv4crc" "sv4crc")
("application/x-tar" "tar")
("application/x-tcl" "tcl")
("application/x-tex-gf" "gf")
("application/x-tex-pk" "pk")
("application/x-texinfo" "texinfo" "texi")
("application/x-trash" "~%" "" "bak" "old" "sik")
("application/x-troff" "tt" "r" "roff")
("application/x-troff-man" "man")
("application/x-troff-me" "me")
("application/x-troff-ms" "ms")
("application/x-ustar" "ustar")
("application/x-wais-source" "src")
("application/x-wingz" "wz")
("application/x-x509-ca-cert" "crt")
("application/x-xcf" "xcf")
("application/x-xfig" "fig")
("application/x-xpinstall" "xpi")
("audio/basic" "au" "snd")
("audio/midi" "mid" "midi" "kar")
("audio/mpeg" "mpga" "mpega" "mp2" "mp3" "m4a")
("audio/mpegurl" "m3u")
("audio/prs.sid" "sid")
("audio/x-aiff" "aif" "aiff" "aifc")
("audio/x-gsm" "gsm")
("audio/x-mpegurl" "m3u")
("audio/x-ms-wma" "wma")
("audio/x-ms-wax" "wax")
("audio/x-pn-realaudio" "ra" "rm" "ram")
("audio/x-realaudio" "ra")
("audio/x-scpls" "pls")
("audio/x-sd2" "sd2")
("audio/x-wav" "wav")
("chemical/x-alchemy" "alc")
("chemical/x-cache" "cac" "cache")
("chemical/x-cache-csf" "csf")
("chemical/x-cactvs-binary" "cbin" "cascii" "ctab")
("chemical/x-cdx" "cdx")
("chemical/x-cerius" "cer")
("chemical/x-chem3d" "c3d")
("chemical/x-chemdraw" "chm")
("chemical/x-cif" "cif")
("chemical/x-cmdf" "cmdf")
("chemical/x-cml" "cml")
("chemical/x-compass" "cpa")
("chemical/x-crossfire" "bsd")
("chemical/x-csml" "csml" "csm")
("chemical/x-ctx" "ctx")
("chemical/x-cxf" "cxf" "cef")
("chemical/x-embl-dl-nucleotide" "emb" "embl")
("chemical/x-galactic-spc" "spc")
("chemical/x-gamess-input" "inp" "gam" "gamin")
("chemical/x-gaussian-checkpoint" "fch" "fchk")
("chemical/x-gaussian-cube" "cub")
("chemical/x-gaussian-input" "gau" "gjc" "gjf")
("chemical/x-gaussian-log" "gal")
("chemical/x-gcg8-sequence" "gcg")
("chemical/x-genbank" "gen")
("chemical/x-hin" "hin")
("chemical/x-isostar" "istr" "ist")
("chemical/x-jcamp-dx" "jdx" "dx")
("chemical/x-kinemage" "kin")
("chemical/x-macmolecule" "mcm")
("chemical/x-macromodel-input" "mmd" "mmod")
("chemical/x-mdl-molfile" "mol")
("chemical/x-mdl-rdfile" "rd")
("chemical/x-mdl-rxnfile" "rxn")
("chemical/x-mdl-sdfile" "sd" "sdf")
("chemical/x-mdl-tgf" "tgf")
("chemical/x-mmcif" "mcif")
("chemical/x-mol2" "mol2")
("chemical/x-molconn-Z" "b")
("chemical/x-mopac-graph" "gpt")
("chemical/x-mopac-input" "mop" "mopcrt" "mpc" "dat" "zmt")
("chemical/x-mopac-out" "moo")
("chemical/x-mopac-vib" "mvb")
("chemical/x-ncbi-asn1" "asn")
("chemical/x-ncbi-asn1-ascii" "prt" "ent")
("chemical/x-ncbi-asn1-binary" "val" "aso")
("chemical/x-ncbi-asn1-spec" "asn")
("chemical/x-pdb" "pdb" "ent")
("chemical/x-rosdal" "ros")
("chemical/x-swissprot" "sw")
("chemical/x-vamas-iso14976" "vms")
("chemical/x-vmd" "vmd")
("chemical/x-xtel" "xtel")
("chemical/x-xyz" "xyz")
("image/gif" "gif")
("image/ief" "ief")
("image/jpeg" "jpeg" "jpg" "jpe")
("image/pcx" "pcx")
("image/png" "png")
("image/svg+xml" "svg" "svgz")
("image/tiff" "tiff" "tif")
("image/vnd.djvu" "djvu" "djv")
("image/vnd.wap.wbmp" "wbmp")
("image/x-cmu-raster" "ras")
("image/x-coreldraw" "cdr")
("image/x-coreldrawpattern" "pat")
("image/x-coreldrawtemplate" "cdt")
("image/x-corelphotopaint" "cpt")
("image/x-icon" "ico")
("image/x-jg" "art")
("image/x-jng" "jng")
("image/x-ms-bmp" "bmp")
("image/x-photoshop" "psd")
("image/x-portable-anymap" "pnm")
("image/x-portable-bitmap" "pbm")
("image/x-portable-graymap" "pgm")
("image/x-portable-pixmap" "ppm")
("image/x-rgb" "rgb")
("image/x-xbitmap" "xbm")
("image/x-xpixmap" "xpm")
("image/x-xwindowdump" "xwd")
("model/iges" "igs" "iges")
("model/mesh" "msh" "mesh" "silo")
("model/vrml" "wrl" "vrml")
("text/calendar" "ics" "icz")
("text/comma-separated-values" "csv")
("text/css" "css")
("text/h323" "323")
("text/html" "html" "htm" "shtml")
("text/iuls" "uls")
("text/mathml" "mml")
("text/plain" "asc" "txt" "text" "diff" "pot")
("text/richtext" "rtx")
("text/rtf" "rtf")
("text/scriptlet" "sct" "wsc")
("text/texmacs" "tm" "ts")
("text/tab-separated-values" "tsv")
("text/vnd.sun.j2me.app-descriptor" "jad")
("text/vnd.wap.wml" "wml")
("text/vnd.wap.wmlscript" "wmls")
("text/x-bibtex" "bib")
("text/x-boo" "boo")
("text/x-c++hdr" "h++" "hpp" "hxx" "hh")
("text/x-c++src" "c++" "cpp" "cxx" "cc")
("text/x-chdr" "h")
("text/x-component" "htc")
("text/x-csh" "csh")
("text/x-csrc" "c")
("text/x-dsrc" "d")
("text/x-haskell" "hs")
("text/x-java" "java")
("text/javascript" "js")
("text/x-literate-haskell" "lhs")
("text/x-moc" "moc")
("text/x-pascal" "pp" "as")
("text/x-pcs-gcd" "gcd")
("text/x-perl" "pl" "pm")
("text/x-python" "py")
("text/x-setext" "etx")
("text/x-sh" "sh")
("text/x-tcl" "tcl" "tk")
("text/x-tex" "tex" "ltx" "sty" "cls")
("text/x-vcalendar" "vcs")
("text/x-vcard" "vcf")
("video/dl" "dl")
("video/dv" "dif" "dv")
("video/fli" "fli")
("video/gl" "gl")
("video/mpeg" "mpeg" "mpg" "mpe")
("video/mp4" "mp4")
("video/quicktime" "qt" "mov")
("video/vnd.mpegurl" "mxu")
("video/x-la-asf" "lsf" "lsx")
("video/x-m4v" "m4v")
("video/x-mng" "mng")
("video/x-ms-asf" "asf" "asx")
("video/x-ms-wm" "wm")
("video/x-ms-wmv" "wmv")
("video/x-ms-wmx" "wmx")
("video/x-ms-wvx" "wvx")
("video/x-msvideo" "avi")
("video/x-sgi-movie" "movie")
("x-conference/x-cooltalk" "ice")
("x-world/x-vrml" "vrm" "vrml" "wrl"))
"An alist where the cars are MIME types and the cdrs are list
of file suffixes for the corresponding type.")
(defparameter *mime-type-hash*
(let ((hash (make-hash-table :test #'equalp)))
(loop for (type . suffixes) in *mime-type-list* do
(loop for suffix in suffixes do
(setf (gethash suffix hash) type)))
hash)
"A hash table which maps file suffixes to MIME types.")
(defun mime-type (pathspec)
"Given a pathname designator PATHSPEC returns the MIME type
\(as a string) corresponding to the suffix of the file denoted by
PATHSPEC \(or NIL)."
(gethash (pathname-type pathspec) *mime-type-hash*)) hunchentoot-v1.2.38/www/ 0000755 0000000 0000000 00000000000 13211004253 013642 5 ustar root root hunchentoot-v1.2.38/www/hunchentoot-doc.html 0000644 0000000 0000000 00000721624 13211004253 017645 0 ustar root root
Hunchentoot - The Common Lisp web server formerly known as TBNL
Hunchentoot - The Common Lisp web server formerly known as TBNL
Hunchentoot is a web server written in Common Lisp and at the
same time a toolkit for building dynamic websites. As a
stand-alone web server, Hunchentoot is capable of HTTP/1.1
chunking (both directions), persistent connections
(keep-alive), and SSL.
Hunchentoot provides facilities like automatic session
handling (with and without cookies), logging, customizable
error handling, and easy access to GET and POST parameters
sent by the client. It does not include functionality
to programmatically generate HTML output. For this task you
can use any library you like, e.g. (shameless self-plug)
CL-WHO or
HTML-TEMPLATE.
Hunchentoot talks with its front-end or with the client over
TCP/IP sockets and optionally uses multiprocessing to handle
several requests at the same time. Therefore, it cannot be
implemented completely in portable
Common Lisp. It currently works with LispWorks and all Lisps
which are supported by the compatibility layers usocket and
Bordeaux
Threads.
Hunchentoot comes with a
BSD-style
license so you can basically do with it whatever you want.
Hunchentoot is (or was) for example used by
QuickHoney,
City Farming,
Heike Stephan.
Download shortcut:
http://weitz.de/files/hunchentoot.tar.gz.
- Abstract
- Contents
-
Download and installation
- Running Hunchentoot on port 80
- Hunchentoot behind a proxy
- Support
- Your own webserver (the easy teen-age New York version)
- Third party documentation and add-ons
-
Function and variable reference
- Acceptors
- Customizing acceptor behaviour
- An example of how to subclass ACCEPTOR
- Taskmasters
- Request dispatch and handling
- Using the easy-handler framework
- Request objects
- Reply objects
- Sessions
- Customizing session behaviour
- Cookies
- Logging
- Conditions and error handling
- Miscellaneous
- Testing
- Debugging
- History
- Symbol index
- Acknowledgements
Hunchentoot depends on a couple of other Lisp libraries which you'll need
to install first:
- Pierre R. Mai's MD5,
- Kevin Rosenberg's CL-BASE64,
- Janis Dzerins' RFC2388,
- Peter Seibel's CL-FAD,
- Gary King's trivial-backtrace,
- Erik Huelsmann's usocket (unless you're using LispWorks),
- Greg Pfeil's Bordeaux Threads (unless you're using LispWorks),
-
David Lichteblau's CL+SSL
(unless you're using LispWorks),
-
and my own FLEXI-STREAMS (0.12.0 or higher),
Chunga (1.0.0 or
higher), and
CL-PPCRE (plus
CL-WHO for the example code
and Drakma for the tests).
Make sure to use the newest versions of all of these
libraries (which might themselves depend on other libraries) - try
the repository versions if you're in doubt. Note: You can compile
Hunchentoot without SSL support - and thus without the need to
have CL+SSL - if you add :HUNCHENTOOT-NO-SSL to
*FEATURES* before you compile it.
Hunchentoot will only work with Lisps where
the character
codes of
all Latin-1
characters coincide with their
Unicode code
points (which is the case for all current implementations I
know).
Hunchentoot itself together with this documentation can be
downloaded from
https://github.com/edicl/hunchentoot/archive/v1.2.38.tar.gz.
The current version is 1.2.38.
The preferred method to compile and load Hunchentoot is via ASDF. If you want to avoid
downloading and installing all the dependencies manually, give
Zach Beane's excellent Quicklisp system a try.
Hunchentoot and its dependencies can also be installed with clbuild.
There's also a port for Gentoo
Linux thanks to Matthew Kennedy.
The current development version of Hunchentoot can be found
at https://github.com/edicl/hunchentoot.
If you want to send patches, please fork the github repository and send pull requests.
Hunchentoot does not come with code to help with running it on a
privileged port (i.e. port 80 or 443) on Unix-like operating
systems. Modern Unix-like systems have specific, non-portable
ways to allow non-root users to listen to privileged ports, so
including such functionality in Hunchentoot was considered
unnecessary. Please refer to online resources for help. At the
time of this writing, the YAWS documentation has a comprehensive
writeup on the topic.
If you're feeling unsecure about exposing Hunchentoot to the wild,
wild Internet or if your Lisp web application is part of a larger
website, you can hide it behind a
proxy server.
One approach that I have used several times is to employ Apache's
mod_proxy
module with a configuration that looks like this:
ProxyPass /hunchentoot http://127.0.0.1:3000/hunchentoot
ProxyPassReverse /hunchentoot http://127.0.0.1:3000/hunchentoot
This will tunnel all requests where the URI path begins with
"/hunchentoot" to a (Hunchentoot) server listening on
port 3000 on the same machine.
Of course, there are
several
other (more lightweight) web proxies that you could use
instead of Apache.
The development version of Hunchentoot can be found on
github. Please use the github issue tracking system to
submit bug reports. Patches are welcome, please use GitHub pull
requests. If you want to make a change, please read this
first.
Starting your own web server is pretty easy. Do something like this:
(hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 4242))
That's it. Now you should be able to enter the address
"http://127.0.0.1:4242/" in
your browser and see something, albeit nothing very interesting
for now.
By default, Hunchentoot serves the files from the
www/ directory in its source tree. In the
distribution, that directory contains a HTML version of the
documentation as well as the error templates. The location of
the document root directory can be specified when creating a new
ACCEPTOR instance by the way of the
ACCEPTOR-DOCUMENT-ROOT. Likewise, the
location of the error template directory can be specified by the
ACCEPTOR-ERROR-TEMPLATE-DIRECTORY. Both
ACCEPTOR-DOCUMENT-ROOT and
ACCEPTOR-ERROR-TEMPLATE-DIRECTORY can be
specified using a logical pathname, which will be translated
once when the ACCEPTOR is instantiated.
The EASY-ACCEPTOR class implements a
framework for developing web applications. Handlers are defined
using the DEFINE-EASY-HANDLER macro.
Request dispatching is performed according to the list of
dispatch functions in *DISPATCH-TABLE*.
Each of the functions on that list is called to determine
whether it wants to handle the request, provided as single
argument. If a dispatcher function wants to handle the request,
it returns another function to actually create the desired page.
DEFINE-EASY-HANDLER is accompanied by a set
of dispatcher creation functions that can be used to create
dispatchers for standard tasks. These are documented in the subchapter on easy
handlers
Now be a bit more adventurous, try this
(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
(setf (hunchentoot:content-type*) "text/plain")
(format nil "Hey~@[ ~A~]!" name))
and see what happens at "http://127.0.0.1:4242/yo" or
"http://127.0.0.1:4242/yo?name=Dude" .
Hunchentoot comes with a little example website which you can use
to see if it works and which should also demonstrate a couple of
the things you can do with Hunchentoot. To start the example
website, enter the following code into your listener:
(asdf:oos 'asdf:load-op :hunchentoot-test)
Now go to "http://127.0.0.1:4242/hunchentoot/test" and play a bit.
Adam Petersen has written a book called "Lisp for
the Web" which explains how Hunchentoot and some other
libraries can be used to build web sites.
Here is some software which extends Hunchentoot or is based on it:
-
Weblocks by
Slava Akhmechet is a "continuations-based web framework" which
is based on Hunchentoot.
-
hunchentoot-cgi
(by Cyrus Harmon) provides
CGI
handlers for Hunchentoot.
-
CL-WEBDAV is a WebDAV
server based on Hunchentoot.
-
RESTAS is a web
framework based on Hunchentoot.
If you want Hunchentoot to actually do something, you have to create and
start an acceptor.
You can also run several acceptors in one image, each one
listening on a different different port.
[Standard class]
acceptor
To create a Hunchentoot webserver, you make an instance of
this class or one of its subclasses and use the generic
function START to start it (and
STOP to stop it). Use the
:port initarg if you don't want to listen
on the default http port 80. If 0 is specified for the
port, the system chooses a random port to listen on. The
port number choosen can be retrieved using the
ACCEPTOR-PORT accessor. The port
number chosen is retained across stopping and starting the
acceptor.
There are other initargs most of which you probably
won't need very often. They are explained in detail
in the docstrings of the slot definitions.
Unless you are in a Lisp without MP capabilities, you can
have several active instances of
ACCEPTOR (listening on different
ports) at the same time.
[Standard class]
ssl-acceptor
Create and START an instance of this class
(instead of ACCEPTOR) if you want an https server. There are two
required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for
pathname designators denoting the certificate file and the key file in
PEM format. On LispWorks, you can have both in one file in which case
the second initarg is optional. You can also use the
:SSL-PRIVATEKEY-PASSWORD initarg to provide a password
(as a string) for the key file (or NIL, the default, for
no password).
The default port for SSL-ACCEPTOR instances is 443 instead of 80
[Generic function]
start acceptor
=>
acceptor
Starts acceptor so that it begins accepting
connections. Returns the acceptor.
[Generic function]
stop acceptor &key soft
=>
acceptor
Stops the acceptor so
that it no longer accepts requests. If
soft is true, and there are any requests
in progress, wait until all requests are fully processed, but
meanwhile do not accept new requests. Note that
soft must not be set when calling
stop from within a request handler, as
that will deadlock.
[Special variable]
*acceptor*
The current ACCEPTOR object in the context of a request.
[Generic function]
acceptor-listen-backlog listen-backlog
=>
number-of-pending-connections
Number of pending connections allowed in the listen socket
before the kernel rejects further incoming connections.
Non-LispWorks only.
[Generic readers]
acceptor-address acceptor
=>
address
acceptor-port acceptor
=>
port
acceptor-read-timeout acceptor
=>
read-timeout
acceptor-ssl-certificate-file ssl-acceptor
=>
ssl-certificate-file
acceptor-ssl-privatekey-file ssl-acceptor
=>
ssl-privatekey-file
acceptor-ssl-privatekey-password ssl-acceptor
=>
ssl-privatekey-password
acceptor-write-timeout acceptor
=>
write-timeout
These are readers for various slots of ACCEPTOR
objects (and some of them obviously only make sense
for SSL-ACCEPTOR objects). See the docstrings of
these slots for more information and note that there are corresponding
initargs for all of them.
[Generic accessors]
acceptor-access-log-destination acceptor
=>
(or pathname null)
(setf (acceptor-access-log-destination acceptor
) new-value)
acceptor-document-root acceptor
=>
(or pathname null)
(setf (acceptor-document-root acceptor
) new-value)
acceptor-error-template-directory acceptor
=>
(or pathname null)
(setf (acceptor-error-template-directory acceptor
) new-value)
acceptor-input-chunking-p acceptor
=>
input-chunking-p
(setf (acceptor-input-chunking-p acceptor
) new-value)
acceptor-message-log-destination acceptor
=>
(or pathname null)
(setf (acceptor-message-log-destination acceptor
) new-value)
acceptor-name acceptor
=>
name
(setf (acceptor-name acceptor
) new-value)
acceptor-output-chunking-p acceptor
=>
output-chunking-p
(setf (acceptor-output-chunking-p acceptor
) new-value)
acceptor-persistent-connections-p acceptor
=>
persistent-connections-p
(setf (acceptor-persistent-connections-p acceptor
) new-value)
acceptor-reply-class acceptor
=>
reply-class
(setf (acceptor-reply-class acceptor
) new-value)
acceptor-request-class acceptor
=>
request-class
(setf (acceptor-request-class acceptor
) new-value)
These are accessors for various slots of ACCEPTOR
objects. See the docstrings of these slots for more information and
note that there are corresponding initargs for all of them.
[Generic function]
acceptor-ssl-p acceptor
=>
generalized-boolean
Returns a true value if acceptor uses SSL
connections. The default is to unconditionally return NIL and
subclasses of ACCEPTOR must specialize this method to signal that
they're using secure connections - see the SSL-ACCEPTOR class.
[Special variable]
*default-connection-timeout*
The default connection timeout used when an
acceptor is reading from and writing to a socket stream. Note that
some Lisps allow you to set different timeouts for reading and writing
and you can specify both values via initargs when you create
an acceptor.
[Generic function]
acceptor-remove-session acceptor session
=>
|
This function is called whenever a session in
ACCEPTOR is being destroyed because of
a session timout or an explicit
REMOVE-SESSION call.
If you want to modify what acceptors do, you should subclass
ACCEPTOR (or SSL-ACCEPTOR) and
specialize the generic functions that constitute their behaviour (see
example below). The life of an acceptor looks like this: It is started
with the function START which immediately calls
START-LISTENING and then applies the function
EXECUTE-ACCEPTOR to its taskmaster. This function will eventually call
ACCEPT-CONNECTIONS which is responsible for setting
things up to wait for clients to connect. For each incoming connection
which comes in, HANDLE-INCOMING-CONNECTION is applied
to the taskmaster which will either call
PROCESS-CONNECTION directly, or will create a thread
to call it. PROCESS-CONNECTION calls
INITIALIZE-CONNECTION-STREAM before it does anything
else, then it selects and calls a function which handles the request, and finally it sends the reply to the client before it calls
RESET-CONNECTION-STREAM. If the connection is
persistent, this procedure is repeated (except for the intialization step)
in a loop until the connection is closed. The acceptor is stopped with
STOP.
If you just want to use the standard acceptors that come with
Hunchentoot, you don't need to know anything about the functions
listed in this section.
[Generic function]
start-listening acceptor
=>
|
Sets up a listen socket for the given acceptor and
enables it to listen to incoming connections. This function is called
from the thread that starts the acceptor initially and may return
errors resulting from the listening operation (like 'address in use'
or similar).
[Generic function]
accept-connections acceptor
=>
nil
In a loop, accepts a connection and hands it over
to the acceptor's taskmaster for processing using
HANDLE-INCOMING-CONNECTION. On LispWorks, this
function returns immediately, on other Lisps it returns only once the
acceptor has been stopped.
[Generic function]
process-connection acceptor socket
=>
nil
This function is called by the taskmaster when a new client
connection has been established. Its arguments are the
ACCEPTOR object and a LispWorks socket
handle or a usocket socket stream object in
socket. It reads the request headers,
sets up the request and reply objects, and hands over to
PROCESS-REQUEST which calls
HANDLE-REQUEST to select and call a
handler for the request and sends its reply to the client.
This is done in a loop until the stream has to be closed or
until a connection timeout occurs. It is probably not a
good idea to re-implement this method until you really,
really know what you're doing.
Handlers may call to the
DETACH-SOCKET generic function to
indicate that no further requests should be handled on
the connection by Hunchentoot, and that responsibility for
the socket is assumed by third-party software. This can
be used by specialized handlers that wish to hand over
connection polling or processing to functions outside of
Hunchentoot, i.e. for connection multiplexing or
implementing specialized client protocols. Hunchentoot
will finish processing the request and the
PROCESS-CONNECTION function will
return without closing the connection. At that point,
the acceptor may interact with the socket in whatever
fashion required.
[Generic function]
detach-socket acceptor
=>
stream
Indicate to Hunchentoot that it should stop serving requests
on the current request's socket. Hunchentoot will finish
processing the current request and then return from
PROCESS-CONNECTION without closing the
connection to the client.
DETACH-SOCKET can only be called from
within a request handler function.
[Generic function]
initialize-connection-stream acceptor stream
=>
stream
Can be used to modify the stream which is used to
communicate between client and server before the request is
read. The default method of ACCEPTOR
does nothing, but see for example the method defined for
SSL-ACCEPTOR. All methods of this
generic function must return the stream to use.
[Generic function]
reset-connection-stream acceptor stream
=>
stream
Resets the stream which is used to communicate
between client and server after one request has been served so that it
can be used to process the next request. This generic function is
called after a request has been processed and must return the
stream.
[Generic function]
acceptor-log-access acceptor &key return-code
Function to call to log access to the acceptor. The
return-code keyword argument contains additional
information about the request to log. In addition, it can use the
standard request and reply accessor functions that are available to
handler functions to find out more information about the request.
[Generic function]
acceptor-log-message acceptor log-level format-string &rest format-arguments
Function to call to log messages by the acceptor. It must accept
a severity level for the message, which will be one of :ERROR, :INFO,
or :WARNING, a format string and an arbitary number of formatting
arguments.
[Generic function]
acceptor-status-message acceptor http-return-code &key &allow-other-keys
This function is called when a request's handler has been
called but failed to provide content to send back to the
client. It converts the
HTTP-STATUS-CODE to some request
contents, typically a human readable description of the
status code to be displayed to the user.
If an ERROR-TEMPLATE-DIRECTORY is set in the current
acceptor and the directory contains a file corresponding to
HTTP-STATUS-CODE named <code>.html, that file is sent
to the client after variable substitution. Variables are
referenced by ${<variable-name>}.
Additional keyword arguments may be provided which are made
available to the templating logic as substitution variables.
These variables can be interpolated into error message
templates in, which contains the current URL relative to the
server and without GET parameters.
In addition to the variables corresponding to keyword
arguments, the script-name, lisp-implementation-type,
lisp-implementation-version and hunchentoot-version
variables are available.
This example shows how to subclass ACCEPTOR in order to
provide Hunchentoot with basic virtual host support. It assumes
Hunchentoot is sitting behind an Internet-facing reverse-proxy web server
that maps the host (or domain) part of incoming HTTP requests to unique
localhost ports.
(asdf:load-system "hunchentoot")
(asdf:load-system "drakma")
;;; Subclass ACCEPTOR
(defclass vhost (tbnl:acceptor)
;; slots
((dispatch-table
:initform '()
:accessor dispatch-table
:documentation "List of dispatch functions"))
;; options
(:default-initargs ; default-initargs must be used
:address "127.0.0.1")) ; because ACCEPTOR uses it
;;; Specialise ACCEPTOR-DISPATCH-REQUEST for VHOSTs
(defmethod tbnl:acceptor-dispatch-request ((vhost vhost) request)
;; try REQUEST on each dispatcher in turn
(mapc (lambda (dispatcher)
(let ((handler (funcall dispatcher request)))
(when handler ; Handler found. FUNCALL it and return result
(return-from tbnl:acceptor-dispatch-request (funcall handler)))))
(dispatch-table vhost))
(call-next-method))
;;; ======================================================================
;;; Now all we need to do is test it
;;; Instantiate VHOSTs
(defvar vhost1 (make-instance 'vhost :port 50001))
(defvar vhost2 (make-instance 'vhost :port 50002))
;;; Populate each dispatch table
(push
(tbnl:create-prefix-dispatcher "/foo" 'foo1)
(dispatch-table vhost1))
(push
(tbnl:create-prefix-dispatcher "/foo" 'foo2)
(dispatch-table vhost2))
;;; Define handlers
(defun foo1 () "Hello")
(defun foo2 () "Goodbye")
;;; Start VHOSTs
(tbnl:start vhost1)
(tbnl:start vhost2)
;;; Make some requests
(drakma:http-request "http://127.0.0.1:50001/foo")
;;; =|
;;; 127.0.0.1 - [2012-06-08 14:30:39] "GET /foo HTTP/1.1" 200 5 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
;;; =>
;;; "Hello"
;;; 200
;;; ((:CONTENT-LENGTH . "5") (:DATE . "Fri, 08 Jun 2012 14:30:39 GMT")
;;; (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
;;; (:CONTENT-TYPE . "text/html; charset=utf-8"))
;;; #<PURI:URI http://127.0.0.1:50001/foo>
;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CA90059}>
;;; T
;;; "OK"
(drakma:http-request "http://127.0.0.1:50002/foo")
;;; =|
;;; 127.0.0.1 - [2012-06-08 14:30:47] "GET /foo HTTP/1.1" 200 7 "-" "Drakma/1.2.6 (SBCL 1.0.56; Linux; 2.6.32-5-686; http://weitz.de/drakma/)"
;;; =>
;;; "Goodbye"
;;; 200
;;; ((:CONTENT-LENGTH . "7") (:DATE . "Fri, 08 Jun 2012 14:30:47 GMT")
;;; (:SERVER . "Hunchentoot 1.2.3") (:CONNECTION . "Close")
;;; (:CONTENT-TYPE . "text/html; charset=utf-8"))
;;; #<PURI:URI http://127.0.0.1:50002/foo>
;;; #<FLEXI-STREAMS:FLEXI-IO-STREAM {CAE8059}>
;;; T
;;; "OK"
How to make each VHOST write to separate access log streams (or files) is
left as an exercise to the reader.
As a "normal" Hunchentoot user, you can completely ignore
taskmasters and skip this section. But if you're still reading,
here are the dirty details: Each acceptor has a taskmaster associated with
it at creation time. It is the taskmaster's job to distribute
the work of accepting and handling incoming connections. The
acceptor calls the taskmaster if appropriate and the taskmaster
calls back into the acceptor. This is done using the generic
functions described in this and the previous section. Hunchentoot
comes with two standard taskmaster implementations - one (which
is the default used on multi-threaded Lisps) which starts a new
thread for each incoming connection and one which handles all
requests sequentially. It should for example be relatively
straightforward to create a taskmaster which allocates threads
from a fixed pool instead of creating a new one for each
connection.
You can control the resources consumed by a threaded taskmaster via
two initargs. :max-thread-count lets you set the maximum
number of request threads that can be processes simultaneously. If
this is nil, the is no thread limit imposed.
:max-accept-count lets you set the maximum number of requests
that can be outstanding (i.e. being processed or queued for processing).
If :max-thread-count is supplied and :max-accept-count
is NIL, then a +HTTP-SERVICE-UNAVAILABLE+
error will be generated if there are more than the max-thread-count
threads processing requests. If both :max-thread-count
and :max-accept-count are supplied, then max-thread-count
must be less than max-accept-count; if more than max-thread-count
requests are being processed, then requests up to max-accept-count
will be queued until a thread becomes available. If more than
max-accept-count requests are outstanding, then a +HTTP-SERVICE-UNAVAILABLE+
error will be generated.
In a load-balanced environment with multiple Hunchentoot servers, it's
reasonable to provide :max-thread-count but leave
:max-accept-count null. This will immediately result
in +HTTP-SERVICE-UNAVAILABLE+ when one server is
out of resources, so the load balancer can try to find another server.
In an environment with a single Hunchentoot server, it's reasonable
to provide both :max-thread-count and a somewhat larger value
for :max-accept-count. This will cause a server that's almost
out of resources to wait a bit; if the server is completely out of resources,
then the reply will be +HTTP-SERVICE-UNAVAILABLE+.
The default for these values is 100 and 120, respectively.
If you want to implement your own taskmasters, you should subclass
TASKMASTER or one of its subclasses,
SINGLE-THREADED-TASKMASTER or
ONE-THREAD-PER-CONNECTION-TASKMASTER, and
specialize the generic functions in this section.
[Standard class]
taskmaster
An instance of this class is responsible for distributing
the work of handling requests for its acceptor. This is an
"abstract" class in the sense that usually only instances of
subclasses of TASKMASTER will be used.
[Standard class]
one-thread-per-connection-taskmaster
A taskmaster that starts one thread for listening to
incoming requests and one thread for each incoming
connection.
This is the default taskmaster implementation for multi-threaded Lisp
implementations.
[Standard class]
single-threaded-taskmaster
A taskmaster that runs synchronously in the
thread where the START function was invoked (or
in the case of LispWorks in the thread started
by COMM:START-UP-SERVER).
This is the simplest possible taskmaster implementation in that its
methods do nothing but calling their acceptor "sister"
methods - EXECUTE-ACCEPTOR calls ACCEPT-CONNECTIONS,
HANDLE-INCOMING-CONNECTION calls PROCESS-CONNECTION.
[Standard class]
multi-threaded-taskmaster
This is an abstract class for taskmasters that use multiple threads;
it is not a concrete class and you should not instantiate it with
MAKE-INSTANCE.
Instead, you should instantiate its subclass
ONE-THREAD-PER-CONNECTION-TASKMASTER described above.
MULTI-THREADED-TASKMASTER
is intended to be inherited from by extensions to Hunchentoot,
such as quux-hunchentoot's
THREAD-POOLING-TASKMASTER,
though at the moment, doing so only inherits one slot and one method,
on EXECUTE-ACCEPTOR,
to have it start a new thread for the acceptor,
then saved in said slot.
[Generic function]
execute-acceptor taskmaster
=>
result
This is a callback called by the acceptor once it
has performed all initial processing to start listening for incoming
connections (see START-LISTENING). It usually calls the
ACCEPT-CONNECTIONS method of the acceptor, but depending on the
taskmaster instance the method might be called from a new thread.
[Generic function]
handle-incoming-connection taskmaster socket
=>
result
This function is called by the acceptor to start
processing of requests on a new incoming connection. socket is the
usocket instance that represents the new connection (or a socket
handle on LispWorks). The taskmaster starts processing requests on
the incoming connection by calling the PROCESS-CONNECTION
method of the acceptor instance. The socket argument is passed to
PROCESS-CONNECTION as an argument.
If the taskmaster is a multi-threaded taskmaster, HANDLE-INCOMING-THREAD
will call CREATE-REQUEST-HANDLER-THREAD, which will call
PROCESS-CONNECTION in a new thread.
HANDLE-INCOMING-THREAD might issue a
+HTTP-SERVICE-UNAVAILABLE+ error
if there are too many request threads or it might block waiting for a
request thread to finish.
[Generic function]
start-thread taskmaster thunk &key
=>
thread
This function is a callback that
starts a new thread that will call the given thunk
in the context of the proper taskmaster,
with appropriate context-dependent keyword arguments.
ONE-THREAD-PER-CONNECTION-TASKMASTER uses it in
EXECUTE-ACCEPTOR
and CREATE-REQUEST-HANDLER-THREAD,
but specialized taskmasters may define more functions that use it.
By default, it just creates a thread calling the thunk
with a specified name keyword argument.
Specialized taskmasters may wrap special bindings and condition handlers
around the thunk call, register the thread in a management table, etc.
[Generic function]
create-request-handler-thread taskmaster socket
=>
thread
This function is called by HANDLE-INCOMING-THREAD
to create a new thread which calls PROCESS-CONNECTION.
If you specialize this function, you must be careful to have the thread
call DECREMENT-TASKMASTER-REQUEST-COUNT before
it exits. A typical method will look like this:
(defmethod create-request-handler-thread ((taskmaster monitor-taskmaster) socket)
(bt:make-thread
(lambda ()
(with-monitor-error-handlers
(unwind-protect
(with-monitor-variable-bindings
(process-connection (taskmaster-acceptor taskmaster) socket))
(decrement-taskmaster-request-count taskmaster))))))
[Generic function]
shutdown taskmaster
=>
taskmaster
Shuts down the taskmaster, i.e. frees all resources
that were set up by it. For example, a multi-threaded taskmaster
might terminate all threads that are currently associated with it.
This function is called by the acceptor's STOP method.
[Generic accessor]
taskmaster-acceptor taskmaster
=>
acceptor
(setf (taskmaster-acceptor taskmaster
) new-value)
This is an accessor for the slot of a TASKMASTER
object that links back to the acceptor it is
associated with.
The main job of HANDLE-REQUEST is to select
and call a function which handles the request, i.e. which looks
at the data the client has sent and prepares an appropriate
reply to send back. This is by default implemented as follows:
The ACCEPTOR class defines a
ACCEPTOR-DISPATCH-REQUEST generic
function which is used to actually dispatch the request. This
function is called by the default method of
HANDLE-REQUEST. Each
ACCEPTOR-DISPATCH-REQUEST method looks at
the request object and depending on its contents decides to
either handle the request or call the next method.
In order to dispatch a request, Hunchentoot calls the
ACCEPTOR-DISPATCH-REQUEST generic
functions. The method for ACCEPTOR tries
to serve a static file relative to it's
ACCEPTOR-DOCUMENT-ROOT. Application
specific acceptor subclasses will typically perform URL
parsing and dispatching according to the policy that is
required.
The default method of HANDLE-REQUEST sets
up standard logging and error handling
before it calls the acceptor's request dispatcher.
Request handlers do their work by modifying
the reply object if necessary and by eventually
returning the response body in the form of a string or a binary
sequence. As an alternative, they can also
call SEND-HEADERS and write directly to a stream.
The EASY-ACCEPTOR class defines a method
for ACCEPTOR-DISPATCH-REQUEST that walks
through the list *DISPATCH-TABLE* which
consists of dispatch functions. Each of these
functions accepts the request object as its only argument and
either returns a request handler to handle the request or
NIL which means that the next dispatcher in the
list will be tried. A request handler is a function
of zero arguments which relies on the special variable
*REQUEST* to access the request instance
being serviced. If all dispatch functions return
NIL, the next
ACCEPTOR-DISPATCH-REQUEST will be called.
N.B. All functions and variables in this
section are related to the easy request dispatch mechanism and
are meaningless if you're using your own request dispatcher.
[Standard class]
easy-acceptor
This class defines no additional slots with respect to
ACCEPTOR. It only serves as an
additional type for dispatching calls to
ACCEPTOR-DISPATCH-REQUEST. In order to
use the easy handler framework, acceptors of this class or
one of its subclasses must be used.
[Standard class]
easy-ssl-acceptor
This class mixes the SSL-ACCEPTOR and
the EASY-ACCEPTOR classes. It is used
when both ssl and the easy handler framework are required.
[Special variable]
*dispatch-table*
A global list of dispatch functions. The initial value is a
list consisting of the symbol
DISPATCH-EASY-HANDLERS.
[Function]
create-prefix-dispatcher prefix handler
=>
dispatch-fn
A convenience function which will return a dispatcher that
returns handler whenever the path part of
the request URI starts with the
string prefix.
[Function]
create-regex-dispatcher regex handler
=>
dispatch-fn
A convenience function which will return a dispatcher that
returns handler whenever the path part of
the request URI matches
the CL-PPCRE regular
expression regex (which can be a string, an
s-expression, or a scanner).
[Function]
create-folder-dispatcher-and-handler uri-prefix base-path &optional content-type
=>
dispatch-fn
Creates and returns a dispatch function which will dispatch to
a handler function which emits the file relative
to base-path that is denoted by the URI of
the request relative
to uri-prefix. uri-prefix
must be a string ending with a
slash, base-path must be a pathname
designator for an existing directory.
Uses HANDLE-STATIC-FILE internally.
If content-type is not
NIL, it will be used as a the content type for
all files in the folder. Otherwise (which is the default)
the content type of each file will be
determined as usual.
[Function]
create-static-file-dispatcher-and-handler uri path
&optional
content-type
=>
result
Creates and returns a request dispatch function which will
dispatch to a handler function which emits the file denoted
by the pathname designator PATH with content type
CONTENT-TYPE if the SCRIPT-NAME of the request matches the
string URI. If CONTENT-TYPE is NIL, tries to determine the
content type via the file's suffix.
[Macro]
define-easy-handler description lambda-list [[declaration* | documentation]] form*
Defines a handler as if
by
DEFUN and optionally registers it with a
URI so that it will be found
by DISPATCH-EASY-HANDLERS.
description is either a
symbol name or a list matching the
destructuring
lambda list
(name &key uri acceptor-names default-parameter-type default-request-type).
lambda-list is a list the elements of which
are either a symbol var or a list matching
the destructuring lambda list
(var &key real-name parameter-type init-form request-type).
The resulting handler will be a Lisp function with the
name name and keyword parameters named by
the var symbols.
Each var will be bound to the value of the
GET or POST parameter called real-name (a
string) before the body of the function is executed.
If real-name is not provided, it will be
computed
by downcasing
the symbol name of var.
If uri (which is evaluated) is provided,
then it must be a string or
a function
designator for a unary function. In this case, the
handler will be returned
by DISPATCH-EASY-HANDLERS,
if uri is a string and
the script name of the current
request is uri, or
if uri designates a function and applying
this function to
the current REQUEST
object returns a true value.
acceptor-names (which is evaluated) can be a
list of symbols which means that the handler will only be
returned by DISPATCH-EASY-HANDLERS in
acceptors which have one of these names
(see ACCEPTOR-NAME). acceptor-names can also be the
symbol T which means that the handler will be
returned by DISPATCH-EASY-HANDLERS
in every acceptor.
Whether the GET or POST parameter (or both) will be taken into
consideration, depends on request-type
which can
be :GET, :POST, :BOTH,
or NIL. In the last case, the value of
default-request-type (the default of which
is :BOTH) will be used.
The value of var will usually be a string
(unless it resulted from a file upload
in which case it won't be converted at all), but
if parameter-type (which is evaluated) is
provided, the string will be converted to another Lisp type by
the following rules:
If the corresponding GET or POST parameter wasn't provided by
the client, var's value will
be NIL. If parameter-type
is 'STRING,
var's value remains as is.
If parameter-type is 'INTEGER
and the parameter string consists solely of decimal
digits, var's value will be the
corresponding integer, otherwise NIL.
If parameter-type is
'KEYWORD, var's value will be
the keyword obtained
by interning
the upcased
parameter string into
the keyword
package. If parameter-type
is 'CHARACTER and the parameter string is of
length one, var's value will be the single
character of this string, otherwise NIL.
If parameter-type
is 'BOOLEAN, var's value will
always be T (unless it is NIL by the
first rule above, of course).
If parameter-type is any other atom, it is
supposed to be
a function
designator for a unary function which will be called to
convert the string to something else.
Those were the rules for simple parameter types, but
parameter-type can also be a list starting
with one of the symbols
LIST, ARRAY,
or HASH-TABLE. The second value of the list must
always be a simple parameter type as in the last paragraph -
we'll call it the inner type below.
In the case of 'LIST, all GET/POST parameters
called real-name will be collected,
converted to the inner type as by the rules above, and
assembled into a list which will be the value of
var.
In the case of 'ARRAY, all GET/POST parameters
which have a name like the result of
(format nil "~A[~A]" real-name n)
where n is a non-negative integer, will be
assembled into an array where the nth element
will be set accordingly, after conversion to the inner type.
The array, which will become the value
of var, will be big enough to hold all
matching parameters, but not bigger. Array elements not set as
described above will be NIL. Note
that VAR will always be bound to an array, which
may be empty, so it will never be NIL, even if no
appropriate GET/POST parameters are found.
The full form of a 'HASH-TABLE parameter type is
(hash-table inner-type key-type test-function)
but key-type
and test-function can be left out in which
case they default to 'STRING
and 'EQUAL, respectively. For this parameter type,
all GET/POST parameters which have a name like the result of
(format nil "~A{~A}" real-name key)
(where key is a string that doesn't contain
curly brackets) will become the values (after conversion
to inner-type) of a hash table with test
function test-function
where key (after conversion
to key-type) will be the corresponding key.
Note that var will always be bound to a hash
table, which may be empty, so it will never be NIL,
even if no appropriate GET/POST parameters are found.
To make matters even more complicated, the three compound
parameter types also have an abbreviated form - just one of
the symbols LIST, ARRAY,
or HASH-TABLE. In this case, the inner type will
default to 'STRING.
If parameter-type is not provided
or NIL, default-parameter-type
(the default of which is 'STRING) will be used
instead.
If the result of the computations above would be
that var would be bound
to NIL, then init-form (if
provided) will be evaluated instead,
and var will be bound to the result of this
evaluation.
Handlers built with this macro are constructed in such a way
that the resulting Lisp function is useful even outside of
Hunchentoot. Specifically, all the parameter computations
above will only happen if *REQUEST* is
bound, i.e. if we're within a Hunchentoot request.
Otherwise, var will always be bound to the
result of evaluating init-form unless a
corresponding keyword argument is provided.
The example code that comes with
Hunchentoot contains an example which demonstrates some of the
features of DEFINE-EASY-HANDLER.
[Function]
dispatch-easy-handlers request
=>
result
This is a dispatcher which returns the appropriate handler
defined with DEFINE-EASY-HANDLER, if there is one.
For each incoming request, the acceptor (in
PROCESS-CONNECTION) creates a
REQUEST object and makes it available to handlers via the special variable
*REQUEST*. This object contains all relevant
information about the request and this section collects the functions
which can be used to query such an object. In all function where
request is an optional or keyword parameter, the
default is *REQUEST*.
If you need more fine-grained control over the behaviour of request
objects, you can subclass REQUEST and initialize
the REQUEST-CLASS
slot of the ACCEPTOR class accordingly. The
acceptor will generate request objects of the class named by this
slot.
[Standard class]
request
Objects of this class hold all the information
about an incoming request. They are created automatically by
acceptors and can be accessed by the
corresponding handler.
You should not mess with the slots of these objects directly, but you
can subclass REQUEST in order to implement your
own behaviour. See
the REQUEST-CLASS
slot of the ACCEPTOR class.
[Special variable]
*request*
The current REQUEST object while in the context of a request.
[Function]
real-remote-addr
&optional
request
=>
string{, list}
Returns the 'X-Forwarded-For' incoming http header as the
second value in the form of a list of IP addresses and the first
element of this list as the first value if this header exists.
Otherwise returns the value of REMOTE-ADDR as the only value.
[Function]
parameter name
&optional
request
=>
string
Returns the GET or the POST parameter with name
name (a string) - or NIL
if there is none. If both a GET and a POST parameter with
the same name exist the GET parameter is returned. Search
is case-sensitive. See also
GET-PARAMETER and
POST-PARAMETER.
[Function]
get-parameter name &optional request
=>
string
Returns the value of the GET parameter (as provided via the
request URI) named by the string name as a
string (or NIL if there ain't no GET parameter
with this name). Note that only the first value will be
returned if the client provided more than one GET parameter
with the name name. See
also GET-PARAMETERS*.
[Function]
post-parameter name &optional request
=>
string
Returns the value of the POST parameter (as provided in the
request's body) named by the
string name. Note that only the first value
will be returned if the client provided more than one POST
parameter with the name name. This value
will usually be a string (or NIL if there ain't
no POST parameter with this name). If, however, the browser
sent a file through
a
multipart/form-data
form, the value of this function is a three-element list
(path file-name content-type)
where path is a pathname denoting the place
were the uploaded file was
stored, file-name (a string) is the file
name sent by the browser, and content-type
(also a string) is the content type sent by the browser. The
file denoted by path will be deleted after
the request has been handled - you have to move or copy it
somewhere else if you want to keep it.
POST parameters will only be computed if the content type of
the request body was multipart/form-data
or application/x-www-form-urlencoded. Although
this function is called POST-PARAMETER, you can
instruct Hunchentoot to compute these parameters for other
request methods by
setting *METHODS-FOR-POST-PARAMETERS*.
See also POST-PARAMETERS
and *TMP-DIRECTORY*.
[Function]
get-parameters* &optional request
=>
alist
Returns
an alist
of all GET parameters (as provided via the request
URI). The car
of each element of this list is the parameter's name while
the cdr
is its value (as a string). The elements of this list are in
the same order as they were within the request URI. See
also GET-PARAMETER.
[Function]
post-parameters* &optional request
=>
alist
Returns
an alist
of all POST parameters (as provided via the request's
body). The car
of each element of this list is the parameter's name while
the cdr
is its value. The elements of this list are in the same order
as they were within the request's body.
See also POST-PARAMETER.
[Special variable]
*methods-for-post-parameters*
A list of the request method types (as keywords) for which
Hunchentoot will try to compute post-parameters.
[Function]
cookie-in name
&optional
request
=>
string
Returns the cookie with the name name (a string) as sent by the
browser - or NIL if there is none.
[Function]
cookies-in*
&optional
request
=>
alist
Returns an alist of all cookies associated with the REQUEST object
request.
[Function]
host
&optional
request
=>
host
Returns the 'Host' incoming http header value.
[Function]
query-string*
&optional
request
=>
string
Returns the query string of the REQUEST object request. That's
the part behind the question mark (i.e. the GET parameters).
[Function]
referer
&optional
request
=>
result
Returns the 'Referer' (sic!) http header.
[Function]
request-method*
&optional
request
=>
keyword
Returns the request method as a Lisp keyword.
[Function]
request-uri*
&optional
request
=>
uri
Returns the request URI.
[Function]
server-protocol*
&optional
request
=>
keyword
Returns the request protocol as a Lisp keyword.
[Function]
user-agent
&optional
request
=>
result
Returns the 'User-Agent' http header.
[Function]
header-in* name
&optional
request
=>
header
Returns the incoming header with name
name. name can be
a keyword (recommended) or a string.
[Function]
headers-in*
&optional
request
=>
alist
Returns an alist of the incoming headers associated with the
REQUEST object
request.
[Function]
remote-addr*
&optional
request
=>
address
Returns the address the current request originated from.
[Function]
remote-port*
&optional
request
=>
port
Returns the port the current request originated from.
[Function]
local-addr*
&optional
request
=>
address
The IP address of the local system that the client connected to.
[Function]
local-port*
&optional
request
=>
port
The TCP port number of the local system that the client connected to.
[Function]
script-name*
&optional
request
=>
script-name
Returns the file name of the REQUEST
object request. That's the
requested URI without the query string (i.e the GET
parameters).
[Accessor]
aux-request-value symbol
&optional
request
=>
value, present-p
(setf (aux-request-value symbol
&optional
request
) new-value)
This accessor can be used to associate arbitrary
data with the the symbol symbol in the REQUEST object
request. present-p is true if such data was found, otherwise NIL.
[Function]
delete-aux-request-value symbol
&optional
request
=>
|
Removes the value associated with symbol from the REQUEST object
request.
[Function]
authorization
&optional
request
=>
result
Returns as two values the user and password (if any) as
encoded in the 'AUTHORIZATION' header. Returns
NIL if there is no such header.
[Special variable]
*hunchentoot-default-external-format*
The external format used to compute the REQUEST object.
[Special variable]
*file-upload-hook*
If this is not NIL, it should be a unary
function which will be called with a pathname for each file
which is uploaded to Hunchentoot. The
pathname denotes the temporary file to which the uploaded
file is written. The hook is called directly before the
file is created. At this point,
*REQUEST* is already bound to the
current REQUEST object, but obviously
you can't access the post parameters yet.
[Function]
raw-post-data
&key
request external-format force-text force-binary want-stream
=>
raw-body-or-stream
Returns the content sent by the client in the request body if
there was any (unless the content type
was multipart/form-data in which
case NIL is returned). By default, the result is
a string if the type of the Content-Type
media type
is "text", and a vector of octets otherwise. In
the case of a string, the external format to be used to decode
the content will be determined from the charset
parameter sent by the client (or
otherwise *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*
will be used).
You can also provide an external format explicitly (through
external-format) in which case the result
will unconditionally be a string. Likewise, you can provide
a true value for force-text which will
force Hunchentoot to act as if the type of the media type
had been "text"
(with external-format taking precedence
if provided). Or you can provide a true value
for force-binary which means that you
want a vector of octets at any rate. (If both
force-text
and force-binary are true, an error will
be signaled.)
If, however, you provide a true value
for want-stream, the other parameters are
ignored and you'll get the content (flexi) stream to read
from it yourself. It is then your responsibility to read
the correct amount of data, because otherwise you won't be
able to return a response to the client. The stream will
have
its octet
position set to 0. If the client provided
a Content-Length header, the stream will also
have a
corresponding bound,
so no matter whether the client used chunked encoding or
not, you can always read until EOF.
If the content type of the request
was multipart/form-data
or application/x-www-form-urlencoded, the
content has been read by Hunchentoot already and you can't
read from the stream anymore.
You can call RAW-POST-DATA more than once
per request, but you can't mix calls which have different
values for want-stream.
Note that this function is slightly misnamed because a
client can send content even if the request method is not
POST.
[Function]
recompute-request-parameters
&key
request external-format
=>
|
Recomputes the GET and POST parameters for the REQUEST object
request. This only makes sense if you're switching external formats
during the request.
[Generic function]
process-request request
=>
nil
This function is called by PROCESS-CONNECTION
after the incoming headers have been read. It
calls HANDLE-REQUEST (and is more or less just a
thin wrapper around it) to select and call a
handler and send the output of this handler to
the client. Note that PROCESS-CONNECTION is
called once per connection and loops in case of a persistent
connection while PROCESS-REQUEST is called anew
for each request.
The return value of this function is ignored.
Like PROCESS-CONNECTION, this is another function
the behaviour of which you should only modify if you really, really
know what you're doing.
[Generic function]
handle-request acceptor request
=>
content
This function is called by PROCESS-REQUEST once
the request has been read and a REQUEST object
has been created. Its job is to actually handle the request, i.e. to
return something to the client.
The default method calls the
acceptor's request dispatcher, but you
can of course implement a different behaviour. The default method
also sets up standard error handling for
the handler.
Might be a good place to bind or rebind special variables which can
then be accessed by your handlers.
[Generic function]
acceptor-dispatch-request acceptor request
=>
content
This function is called to actually dispatch the request
once the standard logging and error handling has been set
up. ACCEPTOR subclasses implement
methods for this function in order to perform their own
request routing. If a method does not want to handle the
request, it is supposed to invoke CALL-NEXT-METHOD
so that the next ACCEPTOR in the
inheritance chain gets a chance to handle the request.
[Generic readers]
cookies-in request
=>
cookies
get-parameters request
=>
get-parameters
header-in name request
=>
result
headers-in request
=>
headers
post-parameters request
=>
post-parameters
query-string request
=>
query-string
remote-addr request
=>
address
remote-port request
=>
port
local-addr request
=>
address
local-port request
=>
port
request-acceptor request
=>
acceptor
request-method request
=>
method
request-uri request
=>
uri
server-protocol request
=>
protocol
script-name request
=>
result
These are various generic readers which are used
to read information about a REQUEST object. If you are writing a
handler, you should not use these readers but instead utilize the
corresponding functions with an asterisk at the end of their name,
also listed in this section. These generic readers are only
exported for users who want to create their own subclasses of
REQUEST.
For each incoming request, the acceptor
(in PROCESS-CONNECTION) creates
a REPLY object and makes it available
to handlers via the special variable
*REPLY*. This object contains all relevant
information (except for the content body) about the reply that will be
sent to the client and this section collects the functions which can
be used to query and modify such an object. In all function
where reply is an optional or keyword parameter,
the default is *REPLY*.
If you need more fine-grained control over the behaviour of reply
objects, you can subclass REPLY and initialize
the REPLY-CLASS
slot of the ACCEPTOR class accordingly. The
acceptor will generate reply objects of the class named by this
slot.
[Standard class]
reply
Objects of this class hold all the information about an
outgoing reply. They are created automatically by
Hunchentoot and can be accessed and modified by the
corresponding handler.
You should not mess with the slots of these objects directly, but you
can subclass REPLY in order to implement your own behaviour. See the
:reply-class initarg
of the ACCEPTOR class.
[Special variable]
*reply*
The current REPLY object in the context of a request.
[Accessor]
header-out name
&optional
reply
=>
string
(setf (header-out name
&optional
reply
) new-value)
HEADER-OUT returns the outgoing http
header named by the keyword name if
there is one, otherwise NIL. SETF
of HEADER-OUT changes the current value
of the header named name. If no header
named name exists, it is created. For
backwards compatibility, name can also
be a string in which case the association between a header
and its name is case-insensitive.
Note that the header 'Set-Cookie' cannot be queried by
HEADER-OUT and must not be set by
SETF of HEADER-OUT. See
also HEADERS-OUT*,
CONTENT-TYPE*,
CONTENT-LENGTH*,
COOKIES-OUT*, and
COOKIE-OUT.
[Function]
headers-out*
&optional
reply
=>
alist
Returns an alist of the outgoing headers associated with the
REPLY object reply. See also HEADER-OUT.
[Accessor]
content-length*
&optional
reply
=>
content-length
(setf (content-length*
&optional
reply
) new-value)
The outgoing 'Content-Length' http header of reply.
[Accessor]
content-type*
&optional
reply
=>
content-type
(setf (content-type*
&optional
reply
) new-value)
The outgoing 'Content-Type' http header of reply.
[Function]
cookie-out name
&optional
reply
=>
result
Returns the current value of the outgoing cookie named
name. Search is case-sensitive.
[Accessor]
cookies-out*
&optional
reply
=>
alist
(setf (cookies-out*
&optional
reply
) new-value)
Returns or sets an alist of the outgoing cookies associated with the
REPLY object
reply.
[Accessor]
return-code*
&optional
reply
=>
return-code
(setf (return-code*
&optional
reply
) new-value)
Gets or sets the http return code of
reply. The return code of each
REPLY object is initially set to
+HTTP-OK+.
[Function]
send-headers
=>
stream
Sends the initial status line and all headers as determined
by the REPLY
object *REPLY*. Returns
a binary
stream to which the body of the reply can be written. Once
this function has been called, further changes
to *REPLY* don't have any effect.
Also, automatic handling of errors (i.e. sending the
corresponding status code to the browser, etc.) is turned
off for this request and functions
like REDIRECT or
to ABORT-REQUEST-HANDLER won't have the
desired effect once the headers are sent.
If your handlers return the full body as a string or as an
array of octets, you should not call this function.
If a handler calls SEND-HEADERS , its
return value is ignored.
[Accessor]
reply-external-format*
&optional
reply
=>
external-format
(setf (reply-external-format*
&optional
reply
) new-value)
Gets or sets the external format of reply which is used for character output.
[Special variable]
*default-content-type*
The default content-type header which is returned to the client.
[Constants]
+http-continue+
+http-switching-protocols+
+http-ok+
+http-created+
+http-accepted+
+http-non-authoritative-information+
+http-no-content+
+http-reset-content+
+http-partial-content+
+http-multi-status+
+http-multiple-choices+
+http-moved-permanently+
+http-moved-temporarily+
+http-see-other+
+http-not-modified+
+http-use-proxy+
+http-temporary-redirect+
+http-bad-request+
+http-authorization-required+
+http-payment-required+
+http-forbidden+
+http-not-found+
+http-method-not-allowed+
+http-not-acceptable+
+http-proxy-authentication-required+
+http-request-time-out+
+http-conflict+
+http-gone+
+http-length-required+
+http-precondition-failed+
+http-request-entity-too-large+
+http-request-uri-too-large+
+http-unsupported-media-type+
+http-requested-range-not-satisfiable+
+http-expectation-failed+
+http-failed-dependency+
+http-internal-server-error+
+http-not-implemented+
+http-bad-gateway+
+http-service-unavailable+
+http-gateway-time-out+
+http-version-not-supported+
The values of these constants are 100, 101, 200, 201, 202,
203, 204, 205, 206, 207, 300, 301, 302, 303, 304, 305, 307,
400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411,
412, 413, 414, 415, 416, 417, 424, 500, 501, 502, 503, 504,
and 505. See RETURN-CODE.
[Generic readers]
content-length reply
=>
content-length
content-type reply
=>
content-type
headers-out reply
=>
headers-out
These are various generic readers which are used
to read information about a REPLY object. If you are writing a
handler, you should not use these readers but instead utilize the
corresponding functions with an asterisk at the end of their name,
also listed in this section. These generic readers are only
exported for users who want to create their own subclasses of
REPLY.
[Generic accessors]
cookies-out reply
=>
result
(setf (cookies-out reply
) new-value)
return-code reply
=>
result
(setf (return-code reply
) new-value)
reply-external-format reply
=>
result
(setf (reply-external-format reply
) new-value)
These are various generic accessors which are
used to query and modify a REPLY objects. If
you are writing a
handler, you should not use these
accessors but instead utilize the corresponding functions with an
asterisk at the end of their name, also listed in this section.
These generic accessors are only exported for users who want to
create their own subclasses of
REPLY.
Hunchentoot supports sessions: Once a request
handler has called START-SESSION, Hunchentoot
uses either cookies or (if the client doesn't send the cookies
back) rewrites URLs to keep
track of this client, i.e. to provide a kind of 'state' for the
stateless http protocol. The session associated with the client is a
CLOS object which can be used
to store arbitrary data between requests.
Hunchentoot makes some reasonable effort to prevent eavesdroppers from
hijacking sessions (see below), but this should not be considered
really secure. Don't store sensitive data in sessions and rely solely
on the session mechanism as a safeguard against malicious users who
want to get at this data!
For each request there's one SESSION object which is accessible to the
handler via the special
variable *SESSION*. This object holds all the
information available about the session and can be accessed with the
functions described in this chapter. Note that the internal structure
of SESSION objects should be considered opaque
and may change in future releases of Hunchentoot.
Sessions are automatically verified for
validity and age when the REQUEST object is
instantiated, i.e. if *SESSION* is not NIL then
this session is valid (as far as Hunchentoot is concerned) and
not too old. Old sessions
are automatically removed.
Hunchentoot also provides a SESSION-REGENERATE-COOKIE-VALUE
function that creates a new cookie value. This helps to prevent against
session fixation
attacks, and should be used when a user logs in according to the application.
[Standard class]
session
SESSION objects are
automatically maintained by Hunchentoot. They should not be created
explicitly with MAKE-INSTANCE but implicitly
with START-SESSION and they should be treated as
opaque objects.
You can ignore Hunchentoot's SESSION objects and
implement your own sessions if you provide corresponding methods for
SESSION-COOKIE-VALUE
and SESSION-VERIFY.
[Function]
start-session
=>
session
Returns the current SESSION
object. If there is no current session, creates one and updates the
corresponding data structures. In this case the function will also
send a session cookie to the browser.
[Accessor]
session-value symbol
&optional
session
=>
value, present-p
(setf (session-value symbol
&optional
session
) new-value)
This accessor can be used to associate arbitrary data with the the
symbol symbol in the SESSION
object session. present-p is
true if such data was found, otherwise NIL. The default
value for session is
*SESSION*.
If SETF of SESSION-VALUE is called
with session being NIL then a
session is automatically instantiated
with START-SESSION.
[Function]
delete-session-value symbol
&optional
session
=>
|
Removes the value associated with
symbol from
session if there is one.
[Special variable]
*session*
The current session while in the context of a request, or
NIL.
[Function]
remove-session session
=>
|
Completely removes the SESSION object
session from Hunchentoot's
internal session database.
[Function]
reset-sessions
&optional
acceptor
=>
|
Removes all stored sessions of
acceptor. The default for
acceptor is
*ACCEPTOR*.
[Function]
regenerate-session-cookie-value session
=>
cookie
Regenerates the session cookie value. This should be used
when a user logs in according to the application to prevent
against session fixation attacks. The cookie value being
dependent on ID, USER-AGENT, REMOTE-ADDR, START, and
*SESSION-SECRET*, the only value we can change is START to
regenerate a new value. Since we're generating a new cookie,
it makes sense to have the session being restarted, in
time. That said, because of this fact, calling this function
twice in the same second will regenerate twice the same
value.
[Special variable]
*rewrite-for-session-urls*
Whether HTML pages should possibly be rewritten for cookie-less
session-management.
[Special variable]
*content-types-for-url-rewrite*
The content types for which url-rewriting is OK. See
*REWRITE-FOR-SESSION-URLS*.
[Special variable]
*use-remote-addr-for-sessions*
Whether the client's remote IP (as returned by REAL-REMOTE-ADDR)
should be encoded into the session string. If this value is true, a
session will cease to be accessible if the client's remote IP changes.
This might for example be an issue if the client uses a proxy server
which doesn't send correct 'X-Forwarded-For' headers.
[Generic function]
session-remote-addr session
=>
remote-addr
The remote IP address of the client when this session was started (as
returned by REAL-REMOTE-ADDR).
[Special variable]
*use-user-agent-for-sessions*
Whether the 'User-Agent' header should
be encoded into the session string. If this value is true, a session
will cease to be accessible if the client sends a different
'User-Agent' header.
[Generic function]
session-user-agent session
=>
user-agent
The incoming 'User-Agent' header that
was sent when this session was created.
[Generic accessor]
session-max-time session
=>
max-time
(setf (session-max-time session
) new-value)
Gets or sets the time (in seconds) after
which session expires if it's not used.
[Special variable]
*session-max-time*
The default time (in seconds) after which a session times out.
[Special variable]
*session-gc-frequency*
A session GC (see function SESSION-GC) will happen every
*SESSION-GC-FREQUENCY* requests (counting only
requests which create a new session) if this variable is
not NIL. See SESSION-CREATED.
[Function]
session-gc
=>
|
Removes sessions from the current session database which are
too old - see SESSION-TOO-OLD-P.
[Function]
session-too-old-p session
=>
generalized-boolean
Returns true if the SESSION object session has not been active in
the last (session-max-time session) seconds.
[Generic function]
session-id session
=>
session-id
The unique ID (an INTEGER) of the session.
[Generic function]
session-start session
=>
universal-time
The time this session was started.
For everyday session usage, you will probably just
use START-SESSION,
SESSION-VALUE,
and maybe DELETE-SESSION-VALUE
and *SESSION*. However, there are two ways to
customize the way Hunchentoot maintains sessions.
One way is to mostly leave the session mechanism intact but to tweak
it a bit:
- The publicly visible part of a session is encoded using a
secret which you can set yourself.
- And it is stored using a cookie (or GET
parameter) name that you can
override.
- Each session receives a new ID when
it is created and you can implement a more robust way to do that.
- You can arrange to be called whenever a session
is created to trigger some action. You
might also do this to invent your own
session garbage collection.
- By default, all sessions are stored in a global alist in memory.
You can't change the alist part, but you can distribute your sessions
over different "databases".
- By default, every operation which modifies sessions or one of the
session databases is guarded by a global lock, but you can arrange to
provide different locks for this.
The other way to customize Hunchentoot's sessions is to completely
replace them. This is actually pretty easy: Create your own class to
store state (which doesn't have to and probably shouldn't inherit
from SESSION) and implement methods for
SESSION-VERIFY
and SESSION-COOKIE-VALUE - that's it.
Hunchentoot will continue to use cookies and/or to rewrite URLs to
keep track of session state and it will store "the current session"
(whatever that is in your implementation)
in *SESSION*. Everything else (like persisting
sessions, GC, getting and setting values) you'll have to take care of
yourself and the other session functions
(like START-SESSION or
SESSION-VALUE) won't work anymore. (Almost)
total freedom, but a lot of responsibility as well... :)
[Special variable]
*session-secret*
A random ASCII string that's used to encode the public
session data. This variable is initially unbound and will
be set (using RESET-SESSION-SECRET) the
first time a session is created, if necessary. You can
prevent this from happening if you set the value yourself
before starting acceptors.
[Function]
reset-session-secret
=>
secret
Sets *SESSION-SECRET* to a
new random value. All old sessions will cease to be valid.
[Generic function]
session-cookie-name acceptor
=>
name
Returns the name (a string) of the cookie (or
the GET parameter) which is used to store a session on the client
side. The default is to use the
string "hunchentoot-session", but you can
specialize this function if you want another name.
[Generic function]
session-created acceptor new-session
=>
result
This function is called whenever a new session
has been created. There's a default method which might trigger
a session GC based on the value of
*SESSION-GC-FREQUENCY*.
The return value is ignored.
[Generic function]
next-session-id acceptor
=>
id
Returns the next sequential session ID, an
integer, which should be unique per session. The default method uses
a simple global counter and isn't guarded by a lock. For a
high-performance production environment you might consider using a
more robust implementation.
[Generic accessor]
session-db acceptor
=>
database
(setf (session-db acceptor
) new-value)
Returns the current session database which is an
alist where each car is a session's ID and the cdr is the
corresponding SESSION object itself. The default
is to use a global list for all acceptors.
[Generic function]
session-db-lock acceptor
&key
whole-db-p
=>
lock
A function which returns a lock that will be
used to prevent concurrent access to sessions. The first argument
will be the acceptor that handles the
current request, the second argument is true
if the whole (current) session database is modified. If it
is NIL, only one existing session in the database is
modified.
This function can return NIL which means that sessions or
session databases will be modified without a lock held (for example
for single-threaded environments). The default is to always return a
global lock (ignoring the acceptor argument) for
Lisps that support threads and NIL otherwise.
[Generic function]
session-verify request
=>
session-or-nil
Tries to get a session identifier from the cookies
(or alternatively from the GET parameters) sent by the client (see
SESSION-COOKIE-NAME
and SESSION-COOKIE-VALUE). This identifier is
then checked for validity against the REQUEST
object
request. On success the corresponding session object (if not too
old) is returned (and updated). Otherwise NIL is returned.
A default method is provided and you only need to write your own one
if you want to maintain your own sessions.
[Generic function]
session-cookie-value session
=>
string
Returns a string which can be used to safely
restore the session session if as session has
already been established. This is used as the value stored in the
session cookie or in the corresponding GET parameter and verified
by SESSION-VERIFY.
A default
method is provided and there's no reason to change it unless you
want to use your own session objects.
Outgoing cookies are stored in the request's REPLY
object (see COOKIE-OUT
and COOKIES-OUT*). They are CLOS objects
defined like this:
(defclass cookie ()
((name :initarg :name
:reader cookie-name
:type string
:documentation "The name of the cookie - a string.")
(value :initarg :value
:accessor cookie-value
:initform ""
:documentation "The value of the cookie. Will be URL-encoded when sent to the browser.")
(expires :initarg :expires
:initform nil
:accessor cookie-expires
:documentation "The time (a universal time) when the cookie expires (or NIL).")
(max-age :initarg :max-age
:initform nil
:accessor cookie-max-age
:documentation "The time delta (in seconds) after which the cookie expires (or NIL).")
(path :initarg :path
:initform nil
:accessor cookie-path
:documentation "The path this cookie is valid for (or NIL).")
(domain :initarg :domain
:initform nil
:accessor cookie-domain
:documentation "The domain this cookie is valid for (or NIL).")
(secure :initarg :secure
:initform nil
:accessor cookie-secure
:documentation "A generalized boolean denoting whether this is a secure cookie.")
(http-only :initarg :http-only
:initform nil
:accessor cookie-http-only
:documentation "A generalized boolean denoting whether this is a HttpOnly cookie.")))
The reader
COOKIE-NAME and
the accessors
COOKIE-VALUE, COOKIE-EXPIRES, COOKIE-MAX-AGE,
COOKIE-PATH, COOKIE-DOMAIN, COOKIE-SECURE,
and COOKIE-HTTP-ONLY are all exported from
the HUNCHENTOOT package. For now, the class name itself is not exported.
[Function]
set-cookie
name &key value expires path
domain secure http-only reply
=>
cookie
Creates a COOKIE object from the parameters
provided to this function and adds it to the outgoing cookies
of the REPLY object
reply. If a cookie with the same name
(case-sensitive) already exists, it is replaced. The default
for reply
is *REPLY*. The default
for value is the empty string.
[Function]
set-cookie* cookie &optional reply
=>
cookie
Adds the COOKIE object cookie
to the outgoing cookies of
the REPLY object
reply. If a cookie with the same name
(case-sensitive) already exists, it is replaced. The default
for reply is *REPLY*.
Hunchentoot can log accesses and diagnostic messages to two
separate destinations, which can be either files in the file
system or streams. Logging can also be disabled by setting the
ACCESS-LOG-DESTINATION and
MESSAGE-LOG-DESTINATION slots in the
ACCEPTOR to NIL. The two
slots can be initialized by providing the
:ACCESS-LOG-DESTINATION and :MESSAGE-LOG-DESTINATION
initialization arguments when creating the acceptor or set by
setting the slots through its
ACCEPTOR-MESSAGE-LOG-DESTINATION and
ACCEPTOR-ACCESS-LOG-DESTINATION accessors.
When the path for the message or accept log is set to a
variable holding an output stream, hunchentoots writes
corresponding log entries to that stream. By default,
Hunchentoot logs to *STANDARD-ERROR*.
Access logging is done in a format similar to what
the Apache web server can write so that logfile analysis using
standard tools is possible. Errors during request processing are
logged to a separate file.
The standard logging mechanism is deliberately simple and slow. The
log files are opened for each log entry and closed again after
writing, and access to them is protected by a global lock. Derived
acceptor classes can implement methods for the
ACCEPTOR-LOG-MESSAGE and
ACCEPTOR-LOG-ACCESS generic functions in order to
log differently (e.g. to a central logging server or in a different
file format.
Errors happening within a handler
which are not caught by the handler itself are handled by
Hunchentoot by logging them to the established
ACCEPTOR-MESSAGE-LOG-DESTINATION.
[Function]
log-message* log-level format-string
&rest
format-arguments
=>
result
Convenience function which calls the message
logger of the current acceptor (if there is one) with the same
arguments it accepts. Returns NIL if there is no message
logger or whatever the message logger returns.
This is the function which Hunchentoot itself uses to log errors it
catches during request processing.
[Special variable]
*log-lisp-errors-p*
Whether Lisp errors in request handlers should be logged.
[Special variable]
*log-lisp-backtraces-p*
Whether Lisp backtraces should be logged. Only
has an effect if *LOG-LISP-ERRORS-P* is true
as well.
[Special variable]
*log-lisp-warnings-p*
Whether Lisp warnings in request handlers should be logged.
[Special variable]
*lisp-errors-log-level*
Log level for Lisp errors. Should be one
of :ERROR (the default), :WARNING,
or :INFO.
[Special variable]
*lisp-warnings-log-level*
Log level for Lisp warnings.
Should be one of :ERROR, :WARNING
(the default), or :INFO.
This section describes how Hunchentoot deals with exceptional
situations. See also the secion about logging.
When an error occurs while processing a request, Hunchentoot's
default behavior is to catch the error, log it and
optionally display it to the client in the HTML response.
This behavior can be customized through the values of a number
of special variables, which are documented below.
[Special variable]
*catch-errors-p*
If the value of this variable is NIL
(the default is T), then errors which happen while a
request is handled aren't caught as usual, but
instead your
Lisp's debugger
is invoked.
This variable should obviously always be set to a true value
in a production environment.
See MAYBE-INVOKE-DEBUGGER
if you want to fine-tune this behaviour.
[Special variable]
*show-lisp-errors-p*
Whether Lisp errors should be shown in HTML output. Note
that this only affects canned responses generated by Lisp.
If an error template is present for the "internal server
error" status code, this special variable is not used (see
acceptor-status-message).
[Special variable]
*show-lisp-backtraces-p*
Whether Lisp backtraces should be shown in HTML output if
*SHOW-LISP-ERRORS-P* is true and an error occurs.
[Generic function]
maybe-invoke-debugger condition
=>
|
This generic function is called whenever a
condition condition
is signaled in Hunchentoot. You might want to specialize it on
specific condition classes for debugging purposes. The default
method invokes
the debugger with condition if
*CATCH-ERRORS-P* is NIL.
[Condition type]
hunchentoot-condition
Superclass for all conditions related to Hunchentoot.
[Condition type]
hunchentoot-error
Superclass for all errors related to Hunchentoot and a subclass of HUNCHENTOOT-CONDITION.
[Condition type]
parameter-error
Signalled if a function was called with incosistent or illegal parameters. A subclass of HUNCHENTOOT-ERROR.
[Condition type]
hunchentoot-warning
Superclass for all warnings related to Hunchentoot and a subclass of HUNCHENTOOT-CONDITION.
Various functions and variables which didn't fit into one of the
other categories.
[Function]
abort-request-handler
&optional
result
=>
result
This function can be called by a request handler
at any time to immediately abort handling the request. This works as
if the handler had returned result. See the
source code of REDIRECT for an example.
[Function]
handle-if-modified-since time &optional request
=>
|
This function is designed to be used inside
a handler. If the client has sent an
'If-Modified-Since' header
(see RFC 2616,
section 14.25) and the time specified matches the universal
time
time then the
header +HTTP-NOT-MODIFIED+ with no content
is immediately returned to the client.
Note that for this function to be useful you should usually
send 'Last-Modified' headers back to the client. See the
code
of CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER
for an example.
[Function]
handle-static-file path &optional content-type
=>
nil
Sends the file denoted by the pathname designator
path with content type
content-type to the client. Sets the
necessary handlers. In particular the function employs
HANDLE-IF-MODIFIED-SINCE.
If content-type is NIL the
function tries to determine the correct content type from
the file's suffix or falls back
to "application/octet-stream" as a last resort.
Note that this function
calls SEND-HEADERS internally, so after
you've called it, the headers are sent and the return value
of your handler is ignored.
[Function]
redirect target &key host port protocol add-session-id code
=>
|
Sends back appropriate headers to redirect the client
to target (a string).
If target is a full URL starting with a
scheme, host, port,
and protocol are ignored.
Otherwise, target should denote the path
part of a URL, protocol must be one of
the keywords :HTTP or :HTTPS, and
the URL to redirect to will be constructed
from host, port, protocol,
and target.
code must be a 3xx HTTP redirection
status code to send to the client. It defaults to 302
("Found"). If host is not provided,
the current host (see HOST) will be
used. If protocol is the keyword
:HTTPS, the client will be redirected to a
https URL, if it's :HTTP it'll be sent to a
http URL. If both host and
protocol aren't provided, then the
value of protocol will match the
current request.
[Function]
require-authorization &optional realm
=>
|
Sends back appropriate headers to require basic HTTP
authentication
(see RFC 2617)
for the realm realm. The default value
for realm is "Hunchentoot".
[Function]
no-cache
=>
|
Adds appropriate headers to completely prevent caching on most browsers.
[Function]
ssl-p
&optional
acceptor
=>
generalized-boolean
Whether the current connection to the client is secure. See ACCEPTOR-SSL-P.
[Function]
reason-phrase return-code
=>
string
Returns a reason phrase for the HTTP return code return-code
(which should be an integer) or NIL for return codes Hunchentoot
doesn't know.
[Function]
rfc-1123-date
&optional
time
=>
string
Generates a time string according to RFC 1123. Default is current time.
This can be used to send a 'Last-Modified' header - see HANDLE-IF-MODIFIED-SINCE.
[Function]
url-encode string
&optional
external-format
=>
string
URL-encodes a string using the external format external-format. The default for external-format is the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*.
[Function]
url-decode string
&optional
external-format
=>
string
Decodes a URL-encoded string which is assumed to
be encoded using the external
format external-format, i.e. this is the inverse
of URL-ENCODE. It is assumed that you'll rarely
need this function, if ever. But just in case - here it is. The
default for external-format is the value
of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*.
[Function]
escape-for-html string
=>
result
Escapes the characters #\<, #\>, #\', #\", and #\& for HTML output.
[Function]
http-token-p object
=>
generalized-boolean
This function tests whether object is a
non-empty string which is a token according
to RFC
2068 (i.e. whether it may be used for, say, cookie names).
[Function]
mime-type pathspec
=>
result
Given a pathname designator pathspec returns the MIME type
(as a string) corresponding to the suffix of the file denoted by
pathspec (or NIL).
[Function]
within-request-p
=>
generalized-boolean
Returns true if in the context of a request. Otherwise, NIL.
[Special variable]
*tmp-directory*
This should be a pathname denoting a directory where temporary
files can be stored. It is used for file
uploads.
[Special variable]
*header-stream*
If this variable is not NIL, it should be bound to a stream to
which incoming and outgoing headers will be written for debugging
purposes.
[Special variable]
*cleanup-function*
A designator for a function without arguments which is called on a
regular basis if *CLEANUP-INTERVAL* is not NIL. The initial value is
the name of a function which invokes a garbage collection on 32-bit
versions of LispWorks.
This variable is only available on LispWorks.
[Special variable]
*cleanup-interval*
Should be NIL or a positive integer. The system calls
*CLEANUP-FUNCTION*
whenever *CLEANUP-INTERVAL* new worker threads
(counted globally across all acceptors) have been created unless the
value is NIL. The initial value is 100.
This variable is only available on LispWorks.
Hunchentoot comes with a test script which verifies that the
example web server responds as expected. This test script uses the
Drakma HTTP client library
and thus shares a significant amount of its base code with
Hunchentoot itself. Still, running the test script is a useful
confidence test, and it is also possible to run the script across
machines in order to verify a new Hunchentoot (or, for that matter
Drakma) port.
To run the confidence test, start
the example web server. Then, in your Lisp
listener, type
(hunchentoot-test:test-hunchentoot "http://localhost:4242")
You will see some diagnostic output and a summary line that
reports whether any tests have failed. (You can also use the
example certificate and key files in the test directory and
start and test an https server instead.)
[Function]
hunchentoot-test:test-hunchentoot base-url &key
=>
|
Runs the built-in confidence
test. base-url is the base URL to use
for testing, it should not have a trailing slash. The keyword
arguments accepted are for future extension and should not
currently be used.
The script expects the Hunchentoot example test server to be
running at the given base-url and
retrieves various pages from that server, expecting certain
responses.
By default, Hunchentoot intercepts all errors that occur while
executing request handlers, logs them to the log file and displays
a static error page to the user. While developing applications,
you may want to change that behavior so that the debugger is
invoked when an error occurs. You can set
the *CATCH-ERRORS-P* to NIL to
make that happen. Alternatively, you may want to have Hunchentoot
display detailed error information in the error response page.
You can set the *SHOW-LISP-ERRORS-P* to a
true value to make that happen. If you don't want to see Lisp
backtraces in these error pages, you can
set *SHOW-LISP-BACKTRACES-P*
to NIL.
Hunchentoot's predecessor TBNL
(which is short for "To Be Named Later") grew over the years as a
toolkit that I used for various commercial and private
projects. In August 2003, Daniel Barlow started
a review of
web APIs on
the lispweb mailing
list and
I described
the API of my hitherto-unreleased bunch of code (and christened it
"TBNL").
It turned out that
Jeff Caldwell had
worked on something similar so he emailed me and proposed to
join our efforts. As I had no immediate plans to release my code
(which was poorly organized, undocumented, and mostly
CMUCL-specific), I gave it to Jeff and he worked towards a
release. He added docstrings, refactored, added some stuff, and
based it on KMRCL to make it portable across several Lisp
implementations.
Unfortunately, Jeff is at least as busy as I am so he didn't
find the time to finish a full release. But in spring 2004 I
needed a documented version of the code for a client of mine who
thought it would be good if the toolkit were publicly available
under an open source license. So I took Jeff's code, refactored
again (to sync with the changes I had done in the meantime), and
added documentation. This resulted in TBNL 0.1.0 (which
initially required mod_lisp as its front-end).
In March 2005, Bob Hutchinson sent patches which enabled TBNL to
use other front-ends than mod_lisp. This made me aware that
TBNL was already almost a full web server, so
eventually I wrote Hunchentoot which was a full web
server, implemented as a wrapper around TBNL. Hunchentoot 0.1.0
was released at the end of 2005 and was originally
LispWorks-only.
Hunchentoot 0.4.0, released in October 2006, was the first
release which also worked with other Common Lisp
implementations. It is a major rewrite and also incorporates
most of TBNL and replaces it completely.
Hunchentoot 1.0.0, released in February 2009, is again a major
rewrite and should be considered work in progress. It moved to
using
the usocket
and Bordeaux
Threads libraries for non-LispWorks Lisps, thereby removing most of
the platform dependent code. Threading behaviour was made
controllable through the introduction of
taskmasters. mod_lisp
support and several other things were removed in this release to
simplify the code base (and partly due to the lack of interest).
Several architectural changes (lots of them not
backwards-compatible) were made to ease customization of
Hunchentoot's behaviour. A significant part of the 1.0.0
redesign was done
by Hans Hübner.
Here are all exported symbols of the HUNCHENTOOT
package in alphabetical order linked to their corresponding
documentation entries:
Thanks to Jeff Caldwell - TBNL would not have been released
without his efforts. Thanks
to Stefan
Scholl and Travis Cross for various additions and fixes to
TBNL, to Michael
Weber for initial file upload code, and
to Janis Dzerins for
his RFC 2388
code. Thanks to Bob Hutchison for his code for multiple
front-ends (which made me realize that TBNL was already pretty
close to a "real" web server) and the initial UTF-8 example.
Thanks to Hans Hübner
for a lot of architectural and implementation enhancements for the
1.0.0 release and also for transferring the documentation to sane
XHTML. Thanks to John
Foderaro's AllegroServe
for inspiration. Thanks to Uwe von
Loh for
the Hunchentoot
logo.
Hunchentoot originally used code
from ACL-COMPAT,
specifically the chunking code from Jochen Schmidt. (This has been
replaced by Chunga.) When I ported
Hunchentoot to other Lisps than LispWorks, I stole code from
ACL-COMPAT, KMRCL,
and trivial-sockets for
implementation-dependent stuff like sockets and MP. (This has been replaced by
Bordeaux
Threads
and usocket.)
Parts of this documentation were prepared
with DOCUMENTATION-TEMPLATE,
no animals were harmed.
BACK TO MY HOMEPAGE
hunchentoot-v1.2.38/www/img/ 0000755 0000000 0000000 00000000000 13211004253 014416 5 ustar root root hunchentoot-v1.2.38/www/img/made-with-lisp-logo.jpg 0000644 0000000 0000000 00000030447 13211004253 020712 0 ustar root root JFIF d d Ducky P Adobe d
d,
s !1AQa"q2B#R3b$r%C4Scs5D'6Tdt&
EFVU(eufv7GWgw8HXhx)9IYiy*:JZjz m !1AQa"q2#BRbr3$4CS%cs5DT
&6E'dtU7()euFVfvGWgw8HXhx9IYiy*:JZjz ? v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثW~Hbj k_%ŗ1u,hB4DTV*'7ğ 2u8F>~n>){GɘK/ʞy|V]`y-?_֠x$Vy,%
fNJa0 ]2Dz3쩵ثWb]v*UثWb]v*UثWbXyɒ\y3"iצEsi @dE** =
[;aG}sLʛ]v*UثWb]v*UثWb]v*Uߟ qmy/T%Eǚ^q
m
ޟ%+H ,/VQL^?O8ڜ ,v] V BFSiMiW@ԭ|i]v;.uhdT Bsb,g4躰 ?-CT2u#'_Oi|5ن|HoG&;x-xnf!Tg B!B4^:;=42}sr Y;v*Uث4)p-o/4O$'$dxҭ$*Ϊ@3Myr q2/?61 0?4g|2B֒].\q XˀD sZ \v|>~ i CV|-M6O/警~`jQL~Ңgk~C$ qb(HEy](3lثWb]v*UثWb]v*UثWb]5o? .i~iQs XoujFVAۏl;p߱t=$~t鶩Z"G?Rb%#<ax|9=Gs Yj1 /{ [_/%Pvq[ 5jk>\O.XΊrf1)yaB"GhZ)g9 1'@Q3̹zLfkySy^Z^s6 [-)OQ- ~r*J*rPj"0#A2K= u)i #dl>O.!KU)}v9 kۦrL?vOJ[{}*H/% j\Li$f >jMi?+ `h:$χm 8
ǣk>0Xlu;DTJ 6fK\s ?93ۯ4?>@w( >;]{J ygB!#N'PVG]K1&"Wtm9Hwcv];Xc\ C˗k<* %41f7dKXHWrp i}o{Wb]v*UثWb]v*UثWb]v*U ?5kv^bi{ۙZ^$.4_m'j 8q8as4O^[r &9FR } [^G]R'Jlb
O,j=[s}ޝ>x;Og
~95$=)oO8@wx'Yhdx4] D2IN .cXʞd?/ٿŖ][k}IdfxdIE?S,|15 9q ~cɑτ|y~ rsZ]/*, Vw-GCq : uWW[oȯ>}`ssxcH=Q[35 cK}j >g
?**~I b.U 4+|-^2kj4ys%T0};k[xOlf Nc`"m\ =Wgz Z 7*˦[Sx)Ђlvg2T 789B1ɿ p4}k ,5R 1k5̆;{d K*Fv}1Qܺ˨L ` D%ַgVʻ珽6sG?[; 1>+5[Ke?<{{s˗s4P^Fģ
0+ BPc=2GOsoqr= ų%M[jPn-,$de!Pj2 # Oq}Y{ 9| CE" yWcTC}&} /b=לּ ? ?7áݵ _ <~v'8q?scp< Ρ ?:)PZZDlux)솬?,}xgf["yCU5=^*z2ۢ0g{ ;O i)O6 1 36k
=Eg tV
6Z
<93O'm'5͈|t'
SYNQ\V ~0ء ]wjG vd~o{ *'@חiX#@hw;RK1݉9,⑲XሠsCr)? +$G;zgc>"o5[,@5~c& H.&Uc<[kq[ΟFǟ?=|=[H~TlKrI(o7M8zy T4y0\Y,O/K=6qHc>kM vF"
";. FLY$?wq~p}?v?/rpsBUӼأNӑ^1
m'fNi.PŇV Nq/F)~9t~G D_~zv;1nRrJcȱ>xN Xw}T3
=1ܗb]v*UثWb]v*UثWb]v*U-մm#_4wJִu ͼYX|4Q(
"wDIsQ]_@fG FBhR'HA4R7߮]-VY
3${TtآlD q I[>\KX= ͖`,T)e"W~5%ӛۻ
F qR~) @ k~NYj^iԩ[s\2jVVI.*xݘ"G\y 2>nSٙ1!_f֦6l<@Z}R֔HFSM&12 }}i 8 9 O}T#>(_ڥ .fk W~pky:g?]NϓKoGhܲ
-,ҕUQJ*~473EgB9J~G9&CV$ =1"$t{>LR 8,ZD- 8q (0O`Z=9*źIod c/m&\>Bȉum/ϾBeWht H*XG 0q>AĿ8?2^c~< 8泥IopoSzŹP>p7¥X
1RW6N9ap#㓪ْ~ ǽf 9&h?^`mg6 h̷ֱ>l` )Socw 2öXc>wK[M
֬OoibD?ߋr {4 ȍX/Ώ#ݻ'觘4P( U3]3 spȹU470qo*\["ttqUeaPA"qWb]v*UثWb]v*UثWb]v* "m68 0+o?.? ZzFm z7kR:p$")P$sn$:<ɨ7~ 8~FOl/U=G<˫3? FuQ3CơQE6om,ב֫}{6N?5 Rq}<|R? c -~W溷9logR9O
F0ppIӿ29hD7SwBeKZ5n
oJԘ# 6 'sοm 9I?gЮOM8 q 3+C'#zL*MIul?߉8q_>)? 8'j7|ɩyRXNAmI :S}d?D52 vo>1ͦ :pACc,[:.F ;c ~I*隆 9/͞`^o7yV5mlӧ%GVpwծ>N2qo> & k?_Pzƿ^Qn&_ۭhbRB*h`k$h n }5!-yi% [ GoۏƵl8^+' [{Q 8kie
E^[^~`I]I C,V CXPuÄ_mACWbO= s˦+kn' cEiB1h)[KVl ) ^k| WmK˾bKPh&3[ɺI\$ram9 a#s 18Ed;v*UثWb ORѴCX.Lmod!2K#R*' A, ??7]oc ˿4 -uMbs$Ϥj*v>ejΛKXpfᔇqCjs>@ gyoȨ?2b+/i]f3 喟9 )!+40 UXľ/l~>vL!'4NG"[[o]EXX]JI.]ݸ
*:O7LX eJ 7 eG/6]OU^Gj+ONZSՂ O}OE~
?]7/?! &/?1tX}[WLe,RL) Q)kAI/`I痘m]--2z4 Ԫ]
V ,T = <_7 S ~/_AO)vwzC)ѣY& <TӮN (c0OOsFmId"R1_I>yoͭ?}a$]ռ]B}^+ 9-#恂iȶj Ď>vgDo_!럙g?uykl^pк@ ԍ$H(C `tv1 a u ${yR o溒}KIk&{ 5EhiyG7 G /gtzCuց L ' >6 UahyTR+hC#a; ~(M ~3 ] z4ZC,SV/ϰ |~{b I~g[]sliw^VҢH[y)K.wC^#_0p>rvŖ(yE >y60>R bWԦ%-l( j@;w3 d@!p`Y&,K~-c?_Ku[[ʹ.u]V-ݼpC b:tvNbq/õp4M,\F^M y[2A5գUnNI[ire&&17vq!!);?$ ?(< 9+ 9dj_z=sKIV7K: +!ߐ 7ڽDt` A;U4%2%C{ %ik WF 2y>(;}]XZ. ΎV6qܺQ1ϥHn a `lszgkRc~Iyri5-CZX#PMvp< އ7݇ }ߥv .hBMI%P9Kb( >Q~|y/Z4sgkGAԦӯ#c9CчG6ݙ 7c~Nxgĉ>Tv u>h_k^̿i3k/4kw|֊%ZR"^0lJqq
D &l~Wk^}͇nN%ͮm6oqo,d\U> ̘2DGt#Ǜ 9 & 8_5O8iSO[YE>)vrM&nlZ泲&jݿ'cf|ۛ01#"4 ?-yk6^_P9! (J TPqC] #F| l)2_>/寞|?dl'MR~3pws-@A!YOŰ3E YGY0R_@f+UثWb]O /&^C"~B O8)mNnepZjC 5i/♡ CF=", 7 {ӿ3@m:m > *P [Ow~]Nx}/PKiAB W/{W~vfj9=? Oϝ. /<++ߔ^` -;IԜzg*\]ʊaj1"B9zm 'gӿߟ~A_ߑɋ] q"0Y B*Qy^_䍳0 C\AٙHJ 8 8 8+t͝ ^["] όkH'zfEYHsU+LkcH廓if3s 8iO?̯ůmk3~{hRy=W9a&>9r yqg50: оfS~wyF.iMĒj`~ ~xGi t{>c?O̟mJ_˹㲾d3}vSC"Dz> 2? yW6{HӜb 'WL&=G|u
U,Cm
uJ^d#м:pUV^gl>1JOڝ_gc._fyDT~D?)'wN b
WȀl3_Q㼖G^>qB p Xq
Lvڝ__GmZD SFm3v 3Cà͏),ۿrOQ 9$R4o7 Ky-t+tx7^J^~
`?
3r[ gʶv fʗ̍Ko2wBKZ_S&s a$a&sɟqpTkvX> ;;?o?:\__Լ9-(Ӧi!2^o
MAڙŨ hr|B5/νr+I cQO쮟|~':eҌ6l?bI:G21
4 9 8 9m+_)k^ym6+/1hEF<#qpxU = $u:~zwӟ qssOSӯ.LwB- Uג*45ktħG"T ;7և 9+ä~^y^H$[ޛe .)qY8l=K,hf FѴ.^C-6:Vn"qD:*3U)O2#CL)v*UثWbR
+y[4ռw
$3[Eg &Fn*QS12̀0$gdUثWb]v*UثWb]v*UثWb]v*Uث?1 ?( 6<5~`yLB/_}P&uY1Dɣ. R%!d{ǘ]v*UثWb]v*UثWb]v*UثWb]v*UثWb]v*UثWb hunchentoot-v1.2.38/www/index.html 0000644 0000000 0000000 00000000611 13211004253 015635 0 ustar root root
Welcome to Hunchentoot!
Welcome
When you're reading this message, Hunchentoot has been properly installed.
Please read the documentation.
hunchentoot-v1.2.38/www/errors/ 0000755 0000000 0000000 00000000000 13211004253 015156 5 ustar root root hunchentoot-v1.2.38/www/errors/500.html 0000644 0000000 0000000 00000001033 13211004253 016345 0 ustar root root
Internal Server Error
Internal Server Error
An error occurred while processing your ${script-name} request.
Error Message
${error}
Backtrace
${backtrace}
Hunchentoot ${hunchentoot-version} running on ${lisp-implementation-type} ${lisp-implementation-version}
hunchentoot-v1.2.38/www/errors/404.html 0000644 0000000 0000000 00000000300 13211004253 016344 0 ustar root root
Not found
Resource ${script-name} not found.
hunchentoot-v1.2.38/www/favicon.ico 0000644 0000000 0000000 00000002576 13211004253 015775 0 ustar root root h ( ~ Ǐ ǟ ? ? ? hunchentoot-v1.2.38/acceptor.lisp 0000644 0000000 0000000 00000115602 13211004253 015514 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun default-document-directory (&optional sub-directory)
(let ((source-directory #.(or *compile-file-truename* *load-truename*)))
(merge-pathnames (make-pathname :directory (append (pathname-directory source-directory)
(list "www")
(when sub-directory
(list sub-directory)))
:name nil
:type nil
:defaults source-directory)))))
(defclass acceptor ()
((port :initarg :port
:reader acceptor-port
:documentation "The port the acceptor is listening on. The
default is 80. Note that depending on your operating system you might
need special privileges to listen on port 80. When 0, the port will be
chosen by the system the first time the acceptor is started.")
(address :initarg :address
:reader acceptor-address
:documentation "The address the acceptor is listening on.
If address is a string denoting an IP address, then the server only
receives connections for that address. This must be one of the
addresses associated with the machine and allowed values are host
names such as \"www.zappa.com\" and address strings such as
\"72.3.247.29\". If address is NIL, then the server will receive
connections to all IP addresses on the machine. This is the default.")
(name :initarg :name
:accessor acceptor-name
:documentation "The optional name of the acceptor, a symbol.
This name can be utilized when defining \"easy handlers\" - see
DEFINE-EASY-HANDLER. The default name is an uninterned symbol as
returned by GENSYM.")
(request-class :initarg :request-class
:accessor acceptor-request-class
:documentation "Determines which class of request
objects is created when a request comes in and should be \(a symbol
naming) a class which inherits from REQUEST. The default is the
symbol REQUEST.")
(reply-class :initarg :reply-class
:accessor acceptor-reply-class
:documentation "Determines which class of reply
objects is created when a request is served in and should be \(a
symbol naming) a class which inherits from REPLY. The default is the
symbol REPLY.")
(taskmaster :initarg :taskmaster
:reader acceptor-taskmaster
:documentation "The taskmaster \(i.e. an instance of a
subclass of TASKMASTER) that is responsible for scheduling the work
for this acceptor. The default depends on the MP capabilities of the
underlying Lisp.")
(output-chunking-p :initarg :output-chunking-p
:accessor acceptor-output-chunking-p
:documentation "A generalized boolean denoting
whether the acceptor may use chunked encoding for output, i.e. when
sending data to the client. The default is T and there's usually no
reason to change this to NIL.")
(input-chunking-p :initarg :input-chunking-p
:accessor acceptor-input-chunking-p
:documentation "A generalized boolean denoting
whether the acceptor may use chunked encoding for input, i.e. when
accepting request bodies from the client. The default is T and
there's usually no reason to change this to NIL.")
(persistent-connections-p :initarg :persistent-connections-p
:accessor acceptor-persistent-connections-p
:documentation "A generalized boolean
denoting whether the acceptor supports persistent connections, which
is the default for threaded acceptors. If this property is NIL,
Hunchentoot closes each incoming connection after having processed one
request. This is the default for non-threaded acceptors.")
(read-timeout :initarg :read-timeout
:reader acceptor-read-timeout
:documentation "The read timeout of the acceptor,
specified in \(fractional) seconds. The precise semantics of this
parameter is determined by the underlying Lisp's implementation of
socket timeouts. NIL means no timeout.")
(write-timeout :initarg :write-timeout
:reader acceptor-write-timeout
:documentation "The write timeout of the acceptor,
specified in \(fractional) seconds. The precise semantics of this
parameter is determined by the underlying Lisp's implementation of
socket timeouts. NIL means no timeout.")
#+:lispworks
(process :accessor acceptor-process
:documentation "The Lisp process which accepts incoming
requests. This is the process started by COMM:START-UP-SERVER and no
matter what kind of taskmaster you are using this will always be a new
process different from the one where START was called.")
#-:lispworks
(listen-socket :initform nil
:accessor acceptor-listen-socket
:documentation "The socket listening for incoming
connections.")
#-:lispworks
(listen-backlog :initarg :listen-backlog
:reader acceptor-listen-backlog
:documentation "Number of pending connections
allowed in the listen socket before the kernel rejects
further incoming connections.")
(acceptor-shutdown-p :initform t
:accessor acceptor-shutdown-p
:documentation "A flag that makes the acceptor
shutdown itself when set to something other than NIL.")
(requests-in-progress :initform 0
:accessor accessor-requests-in-progress
:documentation "The number of
requests currently in progress.")
(shutdown-queue :initform (make-condition-variable)
:accessor acceptor-shutdown-queue
:documentation "A condition variable
used with soft shutdown, signaled when all requests
have been processed.")
(shutdown-lock :initform (make-lock "hunchentoot-acceptor-shutdown")
:accessor acceptor-shutdown-lock
:documentation "The lock protecting the shutdown-queue
condition variable and the requests-in-progress counter.")
(access-log-destination :initarg :access-log-destination
:accessor acceptor-access-log-destination
:documentation "Destination of the access log
which contains one log entry per request handled in a format similar
to Apache's access.log. Can be set to a pathname or string
designating the log file, to a open output stream or to NIL to
suppress logging.")
(message-log-destination :initarg :message-log-destination
:accessor acceptor-message-log-destination
:documentation "Destination of the server
error log which is used to log informational, warning and error
messages in a free-text format intended for human inspection. Can be
set to a pathname or string designating the log file, to a open output
stream or to NIL to suppress logging.")
(error-template-directory :initarg :error-template-directory
:accessor acceptor-error-template-directory
:documentation "Directory pathname that
contains error message template files for server-generated error
messages. Files must be named .html with
representing the HTTP return code that the file applies to,
i.e. 404.html would be used as the content for a HTTP 404 Not found
response.")
(document-root :initarg :document-root
:accessor acceptor-document-root
:documentation "Directory pathname that points to
files that are served by the acceptor if no more specific
acceptor-dispatch-request method handles the request."))
(:default-initargs
:address nil
:port 80
:name (gensym)
:request-class 'request
:reply-class 'reply
#-lispworks :listen-backlog #-lispworks 50
:taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
(t 'single-threaded-taskmaster)))
:output-chunking-p t
:input-chunking-p t
:persistent-connections-p t
:read-timeout *default-connection-timeout*
:write-timeout *default-connection-timeout*
:access-log-destination *error-output*
:message-log-destination *error-output*
:document-root (load-time-value (default-document-directory))
:error-template-directory (load-time-value (default-document-directory "errors")))
(:documentation "To create a Hunchentoot webserver, you make an
instance of this class and use the generic function START to start it
\(and STOP to stop it). Use the :PORT initarg if you don't want to
listen on the default http port 80. There are other initargs most of
which you probably won't need very often. They are explained in
detail in the docstrings of the slot definitions for this class.
Unless you are in a Lisp without MP capabilities, you can have several
active instances of ACCEPTOR \(listening on different ports) at the
same time."))
(defmethod print-object ((acceptor acceptor) stream)
(print-unreadable-object (acceptor stream :type t)
(format stream "\(host ~A, port ~A)"
(or (acceptor-address acceptor) "*") (acceptor-port acceptor))))
(defmethod initialize-instance :after ((acceptor acceptor) &key)
(with-accessors ((document-root acceptor-document-root)
(persistent-connections-p acceptor-persistent-connections-p)
(taskmaster acceptor-taskmaster)
(error-template-directory acceptor-error-template-directory)) acceptor
(when (typep taskmaster
'single-threaded-taskmaster)
(setf persistent-connections-p nil))
(when document-root
(setf document-root (translate-logical-pathname document-root)))
(when error-template-directory
(setf error-template-directory (translate-logical-pathname error-template-directory)))))
(defgeneric start (acceptor)
(:documentation "Starts the ACCEPTOR so that it begins accepting
connections. Returns the acceptor."))
(defgeneric stop (acceptor &key soft)
(:documentation "Stops the ACCEPTOR so that it no longer accepts
requests. If SOFT is true, and there are any requests in progress,
wait until all requests are fully processed, but meanwhile do not
accept new requests. Note that SOFT must not be set when calling
STOP from within a request handler, as that will deadlock."))
(defgeneric started-p (acceptor)
(:documentation "Tells if ACCEPTOR has been started.
The default implementation simply queries ACCEPTOR for its listening
status, so if T is returned to the calling thread, then some thread
has called START or some thread's call to STOP hasn't finished. If NIL
is returned either some thread has called STOP, or some thread's call
to START hasn't finished or START was never called at all for
ACCEPTOR.")
(:method (acceptor)
#-lispworks (and (acceptor-listen-socket acceptor) t)
#+lispworks (not (acceptor-shutdown-p acceptor))))
(defgeneric start-listening (acceptor)
(:documentation "Sets up a listen socket for the given ACCEPTOR and
enables it to listen to incoming connections. This function is called
from the thread that starts the acceptor initially and may return
errors resulting from the listening operation \(like 'address in use'
or similar)."))
(defgeneric accept-connections (acceptor)
(:documentation "In a loop, accepts a connection and hands it over
to the acceptor's taskmaster for processing using
HANDLE-INCOMING-CONNECTION. On LispWorks, this function returns
immediately, on other Lisps it retusn only once the acceptor has been
stopped."))
(defgeneric initialize-connection-stream (acceptor stream)
(:documentation "Can be used to modify the stream which is used to
communicate between client and server before the request is read. The
default method of ACCEPTOR does nothing, but see for example the
method defined for SSL-ACCEPTOR. All methods of this generic function
must return the stream to use."))
(defgeneric reset-connection-stream (acceptor stream)
(:documentation "Resets the stream which is used to communicate
between client and server after one request has been served so that it
can be used to process the next request. This generic function is
called after a request has been processed and must return the
stream."))
(defgeneric process-connection (acceptor socket)
(:documentation "This function is called by the taskmaster when a
new client connection has been established. Its arguments are the
ACCEPTOR object and a LispWorks socket handle or a usocket socket
stream object in SOCKET. It reads the request headers, sets up the
request and reply objects, and hands over to PROCESS-REQUEST. This is
done in a loop until the stream has to be closed or until a connection
timeout occurs.
It is probably not a good idea to re-implement this method until you
really, really know what you're doing."))
(defgeneric handle-request (acceptor request)
(:documentation "This function is called once the request has been
read and a REQUEST object has been created. Its job is to set up
standard error handling and request logging.
Might be a good place for around methods specialized for your subclass
of ACCEPTOR which bind or rebind special variables which can then be
accessed by your handlers."))
(defgeneric acceptor-dispatch-request (acceptor request)
(:documentation "This function is called to actually dispatch the
request once the standard logging and error handling has been set up.
ACCEPTOR subclasses implement methods for this function in order to
perform their own request routing. If a method does not want to
handle the request, it is supposed to invoke CALL-NEXT-METHOD so that
the next ACCEPTOR in the inheritance chain gets a chance to handle the
request."))
(defgeneric acceptor-ssl-p (acceptor)
(:documentation "Returns a true value if ACCEPTOR uses SSL
connections. The default is to unconditionally return NIL and
subclasses of ACCEPTOR must specialize this method to signal that
they're using secure connections - see the SSL-ACCEPTOR class."))
;; general implementation
(defmethod start ((acceptor acceptor))
(setf (acceptor-shutdown-p acceptor) nil)
(let ((taskmaster (acceptor-taskmaster acceptor)))
(setf (taskmaster-acceptor taskmaster) acceptor)
(start-listening acceptor)
(execute-acceptor taskmaster))
acceptor)
(defmethod stop ((acceptor acceptor) &key soft)
(with-lock-held ((acceptor-shutdown-lock acceptor))
(setf (acceptor-shutdown-p acceptor) t))
#-lispworks
(wake-acceptor-for-shutdown acceptor)
(when soft
(with-lock-held ((acceptor-shutdown-lock acceptor))
(when (plusp (accessor-requests-in-progress acceptor))
(condition-variable-wait (acceptor-shutdown-queue acceptor)
(acceptor-shutdown-lock acceptor)))))
(shutdown (acceptor-taskmaster acceptor))
#-lispworks
(usocket:socket-close (acceptor-listen-socket acceptor))
#-lispworks
(setf (acceptor-listen-socket acceptor) nil)
#+lispworks
(mp:process-kill (acceptor-process acceptor))
acceptor)
#-lispworks
(defun wake-acceptor-for-shutdown (acceptor)
"Creates a dummy connection to the acceptor, waking ACCEPT-CONNECTIONS while it is waiting.
This is supposed to force a check of ACCEPTOR-SHUTDOWN-P."
(handler-case
(multiple-value-bind (address port) (usocket:get-local-name (acceptor-listen-socket acceptor))
(let ((conn (usocket:socket-connect address port)))
(usocket:socket-close conn)))
(error (e)
(acceptor-log-message acceptor :error "Wake-for-shutdown connect failed: ~A" e))))
(defmethod initialize-connection-stream ((acceptor acceptor) stream)
;; default method does nothing
stream)
(defmethod reset-connection-stream ((acceptor acceptor) stream)
;; turn chunking off at this point
(cond ((typep stream 'chunked-stream)
;; flush the stream first and check if there's unread input
;; which would be an error
(setf (chunked-stream-output-chunking-p stream) nil
(chunked-stream-input-chunking-p stream) nil)
;; switch back to bare socket stream
(chunked-stream-stream stream))
(t stream)))
(defmethod process-connection :around ((*acceptor* acceptor) (socket t))
;; this around method is used for error handling
;; note that this method also binds *ACCEPTOR*
(with-conditions-caught-and-logged ()
(with-mapped-conditions ()
(call-next-method))))
(defun do-with-acceptor-request-count-incremented (*acceptor* function)
(with-lock-held ((acceptor-shutdown-lock *acceptor*))
(incf (accessor-requests-in-progress *acceptor*)))
(unwind-protect
(funcall function)
(with-lock-held ((acceptor-shutdown-lock *acceptor*))
(decf (accessor-requests-in-progress *acceptor*))
(when (acceptor-shutdown-p *acceptor*)
(condition-variable-signal (acceptor-shutdown-queue *acceptor*))))))
(defmacro with-acceptor-request-count-incremented ((acceptor) &body body)
"Execute BODY with ACCEPTOR-REQUESTS-IN-PROGRESS of ACCEPTOR
incremented by one. If the ACCEPTOR-SHUTDOWN-P returns true after
the BODY has been executed, the ACCEPTOR-SHUTDOWN-QUEUE condition
variable of the ACCEPTOR is signalled in order to finish shutdown
processing."
`(do-with-acceptor-request-count-incremented ,acceptor (lambda () ,@body)))
(defun acceptor-make-request (acceptor socket
&key
headers-in
content-stream
method
uri
server-protocol)
"Make a REQUEST instance for the ACCEPTOR, setting up those slots
that are determined from the SOCKET by calling the appropriate
socket query functions."
(multiple-value-bind (remote-addr remote-port)
(get-peer-address-and-port socket)
(multiple-value-bind (local-addr local-port)
(get-local-address-and-port socket)
(make-instance (acceptor-request-class acceptor)
:acceptor acceptor
:local-addr local-addr
:local-port local-port
:remote-addr remote-addr
:remote-port remote-port
:headers-in headers-in
:content-stream content-stream
:method method
:uri uri
:server-protocol server-protocol))))
(defgeneric detach-socket (acceptor)
(:documentation "Indicate to Hunchentoot that it should stop serving
requests on the current request's socket.
Hunchentoot will finish processing the current
request and then return from PROCESS-CONNECTION
without closing the connection to the client.
DETACH-SOCKET can only be called from within a
request handler function."))
(defmethod detach-socket ((acceptor acceptor))
(setf *finish-processing-socket* t
*close-hunchentoot-stream* nil))
(defmethod process-connection ((*acceptor* acceptor) (socket t))
(let* ((socket-stream (make-socket-stream socket *acceptor*))
(*hunchentoot-stream*)
(*close-hunchentoot-stream* t))
(unwind-protect
;; process requests until either the acceptor is shut down,
;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
;; handler, or the peer fails to send a request
(progn
(setq *hunchentoot-stream* (initialize-connection-stream *acceptor* socket-stream))
(loop
(let ((*finish-processing-socket* t))
(when (acceptor-shutdown-p *acceptor*)
(return))
(multiple-value-bind (headers-in method url-string protocol)
(get-request-data *hunchentoot-stream*)
;; check if there was a request at all
(unless method
(return))
;; bind per-request special variables, then process the
;; request - note that *ACCEPTOR* was bound above already
(let ((*reply* (make-instance (acceptor-reply-class *acceptor*)))
(*session* nil)
(transfer-encodings (cdr (assoc* :transfer-encoding headers-in))))
(when transfer-encodings
(setq transfer-encodings
(split "\\s*,\\s*" transfer-encodings))
(when (member "chunked" transfer-encodings :test #'equalp)
(cond ((acceptor-input-chunking-p *acceptor*)
;; turn chunking on before we read the request body
(setf *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)
(chunked-stream-input-chunking-p *hunchentoot-stream*) t))
(t (hunchentoot-error "Client tried to use ~
chunked encoding, but acceptor is configured to not use it.")))))
(with-acceptor-request-count-incremented (*acceptor*)
(process-request (acceptor-make-request *acceptor* socket
:headers-in headers-in
:content-stream *hunchentoot-stream*
:method method
:uri url-string
:server-protocol protocol))))
(finish-output *hunchentoot-stream*)
(setq *hunchentoot-stream* (reset-connection-stream *acceptor* *hunchentoot-stream*))
(when *finish-processing-socket*
(return))))))
(when *close-hunchentoot-stream*
(flet ((close-stream (stream)
;; as we are at the end of the request here, we ignore all
;; errors that may occur while flushing and/or closing the
;; stream.
(ignore-errors*
(finish-output stream))
(ignore-errors*
(close stream :abort t))))
(unless (or (not *hunchentoot-stream*)
(eql socket-stream *hunchentoot-stream*))
(close-stream *hunchentoot-stream*))
(close-stream socket-stream))))))
(defmethod acceptor-ssl-p ((acceptor t))
;; the default is to always answer "no"
nil)
(defgeneric acceptor-log-access (acceptor &key return-code)
(:documentation
"Function to call to log access to the acceptor. The RETURN-CODE,
CONTENT and CONTENT-LENGTH keyword arguments contain additional
information about the request to log. In addition, it can use the
standard request accessor functions that are available to handler
functions to find out more information about the request."))
(defmethod acceptor-log-access ((acceptor acceptor) &key return-code)
"Default method for access logging. It logs the information to the
destination determined by (ACCEPTOR-ACCESS-LOG-DESTINATION ACCEPTOR)
\(unless that value is NIL) in a format that can be parsed by most
Apache log analysis tools.)"
(with-log-stream (stream (acceptor-access-log-destination acceptor) *access-log-lock*)
(format stream "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
~A\" ~D ~:[-~;~:*~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
(remote-addr*)
(header-in* :x-forwarded-for)
(authorization)
(iso-time)
(request-method*)
(script-name*)
(query-string*)
(server-protocol*)
return-code
(content-length*)
(referer)
(user-agent))))
(defgeneric acceptor-log-message (acceptor log-level format-string &rest format-arguments)
(:documentation
"Function to call to log messages by the ACCEPTOR. It must accept
a severity level for the message, which will be one of :ERROR, :INFO,
or :WARNING, a format string and an arbitary number of formatting
arguments."))
(defmethod acceptor-log-message ((acceptor acceptor) log-level format-string &rest format-arguments)
"Default function to log server messages. Sends a formatted message
to the destination denoted by (ACCEPTOR-MESSAGE-LOG-DESTINATION
ACCEPTOR). FORMAT and ARGS are as in FORMAT. LOG-LEVEL is a
keyword denoting the log level or NIL in which case it is ignored."
(with-log-stream (stream (acceptor-message-log-destination acceptor) *message-log-lock*)
(handler-case
(format stream "[~A~@[ [~A]~]] ~?~%"
(iso-time) log-level
format-string format-arguments)
(error (e)
(ignore-errors
(format *trace-output* "error ~A while writing to error log, error not logged~%" e))))))
(defun log-message* (log-level format-string &rest format-arguments)
"Convenience function which calls the message logger of the current
acceptor \(if there is one) with the same arguments it accepts.
This is the function which Hunchentoot itself uses to log errors it
catches during request processing."
(apply 'acceptor-log-message *acceptor* log-level format-string format-arguments))
;; usocket implementation
#-:lispworks
(defmethod start-listening ((acceptor acceptor))
(when (acceptor-listen-socket acceptor)
(hunchentoot-error "acceptor ~A is already listening" acceptor))
(setf (acceptor-listen-socket acceptor)
(usocket:socket-listen (or (acceptor-address acceptor)
usocket:*wildcard-host*)
(acceptor-port acceptor)
:reuseaddress t
:backlog (acceptor-listen-backlog acceptor)
:element-type '(unsigned-byte 8)))
(values))
#-:lispworks
(defmethod start-listening :after ((acceptor acceptor))
(when (zerop (acceptor-port acceptor))
(setf (slot-value acceptor 'port) (usocket:get-local-port (acceptor-listen-socket acceptor)))))
#-:lispworks
(defmethod accept-connections ((acceptor acceptor))
(usocket:with-server-socket (listener (acceptor-listen-socket acceptor))
(loop
(with-lock-held ((acceptor-shutdown-lock acceptor))
(when (acceptor-shutdown-p acceptor)
(return)))
(when (usocket:wait-for-input listener :ready-only t)
(when-let (client-connection
(handler-case (usocket:socket-accept listener)
;; ignore condition
(usocket:connection-aborted-error ())))
(set-timeouts client-connection
(acceptor-read-timeout acceptor)
(acceptor-write-timeout acceptor))
(handle-incoming-connection (acceptor-taskmaster acceptor)
client-connection))))))
;; LispWorks implementation
#+:lispworks
(defmethod start-listening ((acceptor acceptor))
(multiple-value-bind (listener-process startup-condition)
(comm:start-up-server :service (acceptor-port acceptor)
:address (acceptor-address acceptor)
:process-name (format nil "Hunchentoot listener \(~A:~A)"
(or (acceptor-address acceptor) "*")
(acceptor-port acceptor))
;; this function is called once on startup - we
;; use it to check for errors and random port
:announce (lambda (socket &optional condition)
(when condition
(error condition))
(when (or (null (acceptor-port acceptor))
(zerop (acceptor-port acceptor)))
(multiple-value-bind (address port)
(comm:get-socket-address socket)
(declare (ignore address))
(setf (slot-value acceptor 'port) port))))
;; this function is called whenever a connection
;; is made
:function (lambda (handle)
(unless (acceptor-shutdown-p acceptor)
(handle-incoming-connection
(acceptor-taskmaster acceptor) handle)))
;; wait until the acceptor was successfully started
;; or an error condition is returned
:wait t)
(when startup-condition
(error startup-condition))
(mp:process-stop listener-process)
(setf (acceptor-process acceptor) listener-process)
(values)))
#+:lispworks
(defmethod accept-connections ((acceptor acceptor))
(mp:process-unstop (acceptor-process acceptor))
nil)
(defmethod acceptor-dispatch-request ((acceptor acceptor) request)
"Detault implementation of the request dispatch method, generates an
+http-not-found+ error."
(let ((path (and (acceptor-document-root acceptor)
(request-pathname request))))
(cond
(path
(handle-static-file
(merge-pathnames (if (equal "/" (script-name request)) #p"index.html" path)
(acceptor-document-root acceptor))))
(t
(setf (return-code *reply*) +http-not-found+)
(abort-request-handler)))))
(defmethod handle-request ((*acceptor* acceptor) (*request* request))
"Standard method for request handling. Calls the request dispatcher
of *ACCEPTOR* to determine how the request should be handled. Also
sets up standard error handling which catches any errors within the
handler."
(handler-bind ((error
(lambda (cond)
;; if the headers were already sent, the error
;; happened within the body and we have to close
;; the stream
(when *headers-sent*
(setq *finish-processing-socket* t))
(throw 'handler-done
(values nil cond (get-backtrace))))))
(with-debugger
(acceptor-dispatch-request *acceptor* *request*))))
(defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys)
(:documentation
"This function is called after the request's handler has been
invoked to convert the HTTP-STATUS-CODE to a HTML message to be
displayed to the user. If this function returns a string, that
string is sent to the client instead of the content produced by the
handler, if any.
If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and
the directory contains a file corresponding to HTTP-STATUS-CODE
named .html, that file is sent to the client after variable
substitution. Variables are referenced by ${}.
Additional keyword arguments may be provided which are made
available to the templating logic as substitution variables. These
variables can be interpolated into error message templates in,
which contains the current URL relative to the server and without
GET parameters.
In addition to the variables corresponding to keyword arguments,
the script-name, lisp-implementation-type,
lisp-implementation-version and hunchentoot-version variables are
available."))
(defun make-cooked-message (http-status-code &key error backtrace)
(labels ((cooked-message (format &rest arguments)
(setf (content-type*) "text/html; charset=iso-8859-1")
(format nil "~D ~A~:*~A
~?
~A"
http-status-code (reason-phrase http-status-code)
format (mapcar (lambda (arg)
(if (stringp arg)
(escape-for-html arg)
arg))
arguments)
(address-string))))
(case http-status-code
((#.+http-moved-temporarily+
#.+http-moved-permanently+)
(cooked-message "The document has moved here" (header-out :location)))
((#.+http-authorization-required+)
(cooked-message "The server could not verify that you are authorized to access the document requested. ~
Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't ~
understand how to supply the credentials required."))
((#.+http-forbidden+)
(cooked-message "You don't have permission to access ~A on this server."
(script-name *request*)))
((#.+http-not-found+)
(cooked-message "The requested URL ~A was not found on this server."
(script-name *request*)))
((#.+http-bad-request+)
(cooked-message "Your browser sent a request that this server could not understand."))
((#.+http-internal-server-error+)
(if *show-lisp-errors-p*
(cooked-message "~A~@[~%~%Backtrace:~%~%~A~]
"
(escape-for-html (princ-to-string error))
(when *show-lisp-backtraces-p*
(escape-for-html (princ-to-string backtrace))))
(cooked-message "An error has occurred")))
(t
(when (<= 400 http-status-code)
(cooked-message "An error has occurred"))))))
(defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys)
(apply 'make-cooked-message http-status-code args))
(defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys)
(handler-case
(call-next-method)
(error (e)
(log-message* :error "error ~A during error processing, sending cooked message to client" e)
(apply 'make-cooked-message http-status-code args))))
(defun string-as-keyword (string)
"Intern STRING as keyword using the reader so that case conversion is done with the reader defaults."
(let ((*package* (find-package :keyword)))
(read-from-string string)))
(defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys)
"Default function to generate error message sent to the client."
(labels
((substitute-request-context-variables (string)
(let ((properties (append `(:script-name ,(script-name*)
:lisp-implementation-type ,(lisp-implementation-type)
:lisp-implementation-version ,(lisp-implementation-version)
:hunchentoot-version ,*hunchentoot-version*)
properties)))
(unless *show-lisp-backtraces-p*
(setf (getf properties :backtrace) nil))
(cl-ppcre:regex-replace-all "(?i)\\$\\{([a-z0-9-_]+)\\}"
string
(lambda (target-string start end match-start match-end reg-starts reg-ends)
(declare (ignore start end match-start match-end))
(let ((variable-name (string-as-keyword (subseq target-string
(aref reg-starts 0)
(aref reg-ends 0)))))
(escape-for-html (princ-to-string (getf properties variable-name variable-name))))))))
(file-contents (file)
(let ((buf (make-string (file-length file))))
(read-sequence buf file)
buf))
(error-contents-from-template ()
(let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor)
(probe-file (make-pathname :name (princ-to-string http-status-code)
:type "html"
:defaults (acceptor-error-template-directory acceptor))))))
(when error-file-template-pathname
(with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character)
(when file
(setf (content-type*) "text/html")
(substitute-request-context-variables (file-contents file))))))))
(or (unless (< 300 http-status-code)
(call-next-method)) ; don't ever try template for positive return codes
(when *show-lisp-errors-p*
(error-contents-from-template)) ; try template
(call-next-method)))) ; fall back to cooked message
(defgeneric acceptor-remove-session (acceptor session)
(:documentation
"This function is called whenever a session in ACCEPTOR is being
destroyed because of a session timout or an explicit REMOVE-SESSION
call."))
(defmethod acceptor-remove-session ((acceptor acceptor) (session t))
"Default implementation for the session removal hook function. This
function is called whenever a session is destroyed."
nil)
(defgeneric acceptor-server-name (acceptor)
(:documentation "Returns a string which can be used for 'Server' headers.")
(:method ((acceptor acceptor))
(format nil "Hunchentoot ~A" *hunchentoot-version*)))
hunchentoot-v1.2.38/reply.lisp 0000644 0000000 0000000 00000015430 13211004253 015045 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defclass reply ()
((content-type :reader content-type
:documentation "The outgoing 'Content-Type' http
header which defaults to the value of *DEFAULT-CONTENT-TYPE*.")
(content-length :reader content-length
:initform nil
:documentation "The outgoing 'Content-Length'
http header which defaults NIL. If this is NIL, Hunchentoot will
compute the content length.")
(headers-out :initform nil
:reader headers-out
:documentation "An alist of the outgoing http headers
not including the 'Set-Cookie', 'Content-Length', and 'Content-Type'
headers. Use the functions HEADER-OUT and \(SETF HEADER-OUT) to
modify this slot.")
(return-code :initform +http-ok+
:accessor return-code
:documentation "The http return code of this
reply. The return codes Hunchentoot can handle are defined in
specials.lisp.")
(external-format :initform *hunchentoot-default-external-format*
:accessor reply-external-format
:documentation "The external format of the reply -
used for character output.")
(cookies-out :initform nil
:accessor cookies-out
:documentation "The outgoing cookies. This slot's
value should only be modified by the functions defined in
cookies.lisp."))
(:documentation "Objects of this class hold all the information
about an outgoing reply. They are created automatically by
Hunchentoot and can be accessed and modified by the corresponding
handler.
You should not mess with the slots of these objects directly, but you
can subclass REPLY in order to implement your own behaviour. See the
REPLY-CLASS slot of the ACCEPTOR class."))
(defmethod initialize-instance :after ((reply reply) &key)
(setf (header-out :content-type reply) *default-content-type*))
(defun headers-out* (&optional (reply *reply*))
"Returns an alist of the outgoing headers associated with the
REPLY object REPLY."
(headers-out reply))
(defun cookies-out* (&optional (reply *reply*))
"Returns an alist of the outgoing cookies associated with the
REPLY object REPLY."
(cookies-out reply))
(defun (setf cookies-out*) (new-value &optional (reply *reply*))
"Sets the alist of the outgoing cookies associated with the REPLY
object REPLY."
(setf (cookies-out reply) new-value))
(defun content-type* (&optional (reply *reply*))
"The outgoing 'Content-Type' http header of REPLY."
(content-type reply))
(defun (setf content-type*) (new-value &optional (reply *reply*))
"Sets the outgoing 'Content-Type' http header of REPLY."
(setf (header-out :content-type reply) new-value))
(defun content-length* (&optional (reply *reply*))
"The outgoing 'Content-Length' http header of REPLY."
(content-length reply))
(defun (setf content-length*) (new-value &optional (reply *reply*))
"Sets the outgoing 'Content-Length' http header of REPLY."
(setf (header-out :content-length reply) new-value))
(defun return-code* (&optional (reply *reply*))
"The http return code of REPLY. The return codes Hunchentoot can
handle are defined in specials.lisp."
(return-code reply))
(defun (setf return-code*) (new-value &optional (reply *reply*))
"Sets the http return code of REPLY."
(setf (return-code reply) new-value))
(defun reply-external-format* (&optional (reply *reply*))
"The external format of REPLY which is used for character output."
(reply-external-format reply))
(defun (setf reply-external-format*) (new-value &optional (reply *reply*))
"Sets the external format of REPLY."
(setf (reply-external-format reply) new-value))
(defun header-out-set-p (name &optional (reply *reply*))
"Returns a true value if the outgoing http header named NAME has
been specified already. NAME should be a keyword or a string."
(assoc* name (headers-out reply)))
(defun header-out (name &optional (reply *reply*))
"Returns the current value of the outgoing http header named NAME.
NAME should be a keyword or a string."
(cdr (assoc name (headers-out reply))))
(defun cookie-out (name &optional (reply *reply*))
"Returns the current value of the outgoing cookie named
NAME. Search is case-sensitive."
(cdr (assoc name (cookies-out reply) :test #'string=)))
(defgeneric (setf header-out) (new-value name &optional reply)
(:documentation "Changes the current value of the outgoing http
header named NAME \(a keyword or a string). If a header with this
name doesn't exist, it is created.")
(:method (new-value (name symbol) &optional (reply *reply*))
;; the default method
(let ((entry (assoc name (headers-out reply))))
(if entry
(setf (cdr entry) new-value)
(setf (slot-value reply 'headers-out)
(acons name new-value (headers-out reply))))
new-value))
(:method (new-value (name string) &optional (reply *reply*))
"If NAME is a string, it is converted to a keyword first."
(setf (header-out (as-keyword name :destructivep nil) reply) new-value))
(:method :after (new-value (name (eql :content-length)) &optional (reply *reply*))
"Special case for the `Content-Length' header."
(check-type new-value integer)
(setf (slot-value reply 'content-length) new-value))
(:method :after (new-value (name (eql :content-type)) &optional (reply *reply*))
"Special case for the `Content-Type' header."
(check-type new-value (or null string))
(setf (slot-value reply 'content-type) new-value)))
hunchentoot-v1.2.38/taskmaster.lisp 0000644 0000000 0000000 00000054155 13211004253 016077 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defclass taskmaster ()
((acceptor :accessor taskmaster-acceptor
:documentation "A backpointer to the acceptor instance
this taskmaster works for."))
(:documentation "An instance of this class is responsible for
distributing the work of handling requests for its acceptor. This is
an \"abstract\" class in the sense that usually only instances of
subclasses of TASKMASTER will be used."))
(defgeneric execute-acceptor (taskmaster)
(:documentation "This is a callback called by the acceptor once it
has performed all initial processing to start listening for incoming
connections \(see START-LISTENING). It usually calls the
ACCEPT-CONNECTIONS method of the acceptor, but depending on the
taskmaster instance the method might be called from a new thread."))
(defgeneric handle-incoming-connection (taskmaster socket)
(:documentation "This function is called by the acceptor to start
processing of requests on a new incoming connection. SOCKET is the
usocket instance that represents the new connection \(or a socket
handle on LispWorks). The taskmaster starts processing requests on
the incoming connection by calling the PROCESS-CONNECTION method of
the acceptor instance. The SOCKET argument is passed to
PROCESS-CONNECTION as an argument."))
(defgeneric shutdown (taskmaster)
(:documentation "Shuts down the taskmaster, i.e. frees all resources
that were set up by it. For example, a multi-threaded taskmaster
might terminate all threads that are currently associated with it.
This function is called by the acceptor's STOP method."))
(defgeneric create-request-handler-thread (taskmaster socket)
(:documentation
"Create a new thread in which to process the request.
This thread will call PROCESS-CONNECTION to process the request."))
(defgeneric too-many-taskmaster-requests (taskmaster socket)
(:documentation
"Signal a \"too many requests\" error, just prior to closing the connection."))
(defgeneric taskmaster-max-thread-count (taskmaster)
(:documentation
"The maximum number of request threads this taskmaster will simultaneously
run before refusing or queueing new connections requests. If the value
is null, then there is no limit.")
(:method ((taskmaster taskmaster))
"Default method -- no limit on the number of threads."
nil))
(defgeneric taskmaster-max-accept-count (taskmaster)
(:documentation
"The maximum number of connections this taskmaster will accept before refusing
new connections. If supplied, this must be greater than MAX-THREAD-COUNT.
The number of queued requests is the difference between MAX-ACCEPT-COUNT
and MAX-THREAD-COUNT.")
(:method ((taskmaster taskmaster))
"Default method -- no limit on the number of connections."
nil))
(defgeneric taskmaster-thread-count (taskmaster)
(:documentation
"Returns the current number of taskmaster requests.")
(:method ((taskmaster taskmaster))
"Default method -- claim there is one connection thread."
1))
(defgeneric increment-taskmaster-thread-count (taskmaster)
(:documentation
"Atomically increment the number of taskmaster requests.")
(:method ((taskmaster taskmaster))
"Default method -- do nothing."
nil))
(defgeneric decrement-taskmaster-thread-count (taskmaster)
(:documentation
"Atomically decrement the number of taskmaster requests")
(:method ((taskmaster taskmaster))
"Default method -- do nothing."
nil))
(defgeneric start-thread (taskmaster thunk &key name)
(:documentation
"Start a name thread in which to call the THUNK, in the context of the given TASKMASTER.
Keyword arguments provide TASKMASTER-dependent options.
Return a thread object.
Hunchentoot taskmaster methods will call it with the taskmaster as the context,
allowing hunchentoot extensions to define specialized methods that may e.g.
wrap the thunk within a proper set of bindings and condition handlers.")
(:method ((taskmaster t) thunk &key name)
#-lispworks
(bt:make-thread thunk :name name)
#+lispworks
(mp:process-run-function name nil thunk)))
(defclass single-threaded-taskmaster (taskmaster)
()
(:documentation "A taskmaster that runs synchronously in the thread
where the START function was invoked \(or in the case of LispWorks in
the thread started by COMM:START-UP-SERVER). This is the simplest
possible taskmaster implementation in that its methods do nothing but
calling their acceptor \"sister\" methods - EXECUTE-ACCEPTOR calls
ACCEPT-CONNECTIONS, HANDLE-INCOMING-CONNECTION calls
PROCESS-CONNECTION."))
(defmethod execute-acceptor ((taskmaster single-threaded-taskmaster))
;; in a single-threaded environment we just call ACCEPT-CONNECTIONS
(accept-connections (taskmaster-acceptor taskmaster)))
(defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) socket)
;; in a single-threaded environment we just call PROCESS-CONNECTION
(process-connection (taskmaster-acceptor taskmaster) socket))
(defvar *default-max-thread-count* 100)
(defvar *default-max-accept-count* (+ *default-max-thread-count* 20))
(defclass multi-threaded-taskmaster (taskmaster)
((acceptor-process
:accessor acceptor-process
:documentation
"A process that accepts incoming connections and hands them off to new processes
for request handling."))
(:documentation "An abstract class for taskmasters that use multiple threads.
For a concrete class to instantiate, use one-thread-per-connection-taskmaster."))
(defmethod execute-acceptor ((taskmaster multi-threaded-taskmaster))
(setf (acceptor-process taskmaster)
(start-thread
taskmaster
(lambda () (accept-connections (taskmaster-acceptor taskmaster)))
:name (format nil "hunchentoot-listener-~A:~A"
(or (acceptor-address (taskmaster-acceptor taskmaster)) "*")
(acceptor-port (taskmaster-acceptor taskmaster))))))
;; You might think it would be nice to provide a taskmaster that takes
;; threads out of a thread pool. There are two things to consider:
;; - On a 2010-ish Linux box, thread creation takes less than 250 microseconds.
;; - Bordeaux Threads doesn't provide a way to "reset" and restart a thread,
;; and it's not clear how many Lisp implementations can do this.
;; If you're still interested, use the quux-hunchentoot extension to hunchentoot.
(defclass one-thread-per-connection-taskmaster (multi-threaded-taskmaster)
(;; Support for bounding the number of threads we'll create
(max-thread-count
:type (or integer null)
:initarg :max-thread-count
:initform nil
:accessor taskmaster-max-thread-count
:documentation
"The maximum number of request threads this taskmaster will simultaneously
run before refusing or queueing new connections requests. If the value
is null, then there is no limit.")
(thread-count
:type integer
:initform 0
:accessor taskmaster-thread-count
:documentation
"The number of taskmaster processing threads currently running.")
(thread-count-lock
:initform (make-lock "taskmaster-thread-count")
:reader taskmaster-thread-count-lock
:documentation
"In the absence of 'atomic-incf', we need this to atomically
increment and decrement the request count.")
(max-accept-count
:type (or integer null)
:initarg :max-accept-count
:initform nil
:accessor taskmaster-max-accept-count
:documentation
"The maximum number of connections this taskmaster will accept before refusing
new connections. If supplied, this must be greater than MAX-THREAD-COUNT.
The number of queued requests is the difference between MAX-ACCEPT-COUNT
and MAX-THREAD-COUNT.")
(accept-count
:type integer
:initform 0
:accessor taskmaster-accept-count
:documentation
"The number of connection currently accepted by the taskmaster. These
connections are not ensured to be processed, thay may be waiting for an
empty processing slot or rejected because the load is too heavy.")
(accept-count-lock
:initform (make-lock "taskmaster-accept-count")
:reader taskmaster-accept-count-lock
:documentation
"In the absence of 'atomic-incf', we need this to atomically
increment and decrement the accept count.")
(wait-queue
:initform (make-condition-variable)
:reader taskmaster-wait-queue
:documentation
"A queue that we use to wait for a free connection.")
(wait-lock
:initform (make-lock "taskmaster-thread-lock")
:reader taskmaster-wait-lock
:documentation
"The lock for the connection wait queue.")
(worker-thread-name-format
:type (or string null)
:initarg :worker-thread-name-format
:initform "hunchentoot-worker-~A"
:accessor taskmaster-worker-thread-name-format))
(:default-initargs
:max-thread-count *default-max-thread-count*
:max-accept-count *default-max-accept-count*)
(:documentation "A taskmaster that starts one thread for listening
to incoming requests and one new thread for each incoming connection.
If MAX-THREAD-COUNT is null, a new thread will always be created for
each request.
If MAX-THREAD-COUNT is supplied, the number of request threads is
limited to that. Furthermore, if MAX-ACCEPT-COUNT is not supplied, an
HTTP 503 will be sent if the thread limit is exceeded. Otherwise, if
MAX-ACCEPT-COUNT is supplied, it must be greater than MAX-THREAD-COUNT;
in this case, requests are accepted up to MAX-ACCEPT-COUNT, and only
then is HTTP 503 sent.
It is important to note that MAX-ACCEPT-COUNT and the HTTP 503 behavior
described above is racing with the acceptor listen backlog. If we are receiving
requests faster than threads can be spawned and 503 sent, the requests will be
silently rejected by the kernel.
In a load-balanced environment with multiple Hunchentoot servers, it's
reasonable to provide MAX-THREAD-COUNT but leave MAX-ACCEPT-COUNT null.
This will immediately result in HTTP 503 when one server is out of
resources, so the load balancer can try to find another server.
In an environment with a single Hunchentoot server, it's reasonable
to provide both MAX-THREAD-COUNT and a somewhat larger value for
MAX-ACCEPT-COUNT. This will cause a server that's almost out of
resources to wait a bit; if the server is completely out of resources,
then the reply will be HTTP 503.
This is the default taskmaster implementation for multi-threaded Lisp
implementations."))
(defmethod initialize-instance :after ((taskmaster one-thread-per-connection-taskmaster) &rest init-args)
"Ensure the if MAX-ACCEPT-COUNT is supplied, that it is greater than MAX-THREAD-COUNT."
(declare (ignore init-args))
(when (taskmaster-max-accept-count taskmaster)
(unless (taskmaster-max-thread-count taskmaster)
(parameter-error "MAX-THREAD-COUNT must be supplied if MAX-ACCEPT-COUNT is supplied"))
(unless (> (taskmaster-max-accept-count taskmaster) (taskmaster-max-thread-count taskmaster))
(parameter-error "MAX-ACCEPT-COUNT must be greater than MAX-THREAD-COUNT"))))
(defmethod increment-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster))
(when (taskmaster-max-accept-count taskmaster)
(with-lock-held ((taskmaster-accept-count-lock taskmaster))
(incf (taskmaster-accept-count taskmaster)))))
(defmethod decrement-taskmaster-accept-count ((taskmaster one-thread-per-connection-taskmaster))
(when (taskmaster-max-accept-count taskmaster)
(with-lock-held ((taskmaster-accept-count-lock taskmaster))
(decf (taskmaster-accept-count taskmaster)))))
(defmethod increment-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster))
(when (taskmaster-max-thread-count taskmaster)
(with-lock-held ((taskmaster-thread-count-lock taskmaster))
(incf (taskmaster-thread-count taskmaster)))))
(defmethod decrement-taskmaster-thread-count ((taskmaster one-thread-per-connection-taskmaster))
(when (taskmaster-max-thread-count taskmaster)
(prog1
(with-lock-held ((taskmaster-thread-count-lock taskmaster))
(decf (taskmaster-thread-count taskmaster))
(decrement-taskmaster-accept-count taskmaster))
(when (and (taskmaster-max-accept-count taskmaster)
(< (taskmaster-thread-count taskmaster) (taskmaster-max-accept-count taskmaster)))
(note-free-connection taskmaster)))))
(defmethod note-free-connection ((taskmaster one-thread-per-connection-taskmaster))
"Note that a connection has been freed up"
(with-lock-held ((taskmaster-wait-lock taskmaster))
(condition-variable-signal (taskmaster-wait-queue taskmaster))))
(defmethod wait-for-free-connection ((taskmaster one-thread-per-connection-taskmaster))
"Wait for a connection to be freed up"
(with-lock-held ((taskmaster-wait-lock taskmaster))
(loop until (< (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster))
do (condition-variable-wait (taskmaster-wait-queue taskmaster) (taskmaster-wait-lock taskmaster)))))
(defmethod too-many-taskmaster-requests ((taskmaster one-thread-per-connection-taskmaster) socket)
(declare (ignore socket))
(acceptor-log-message (taskmaster-acceptor taskmaster)
:warning "Can't handle a new request, too many request threads already"))
(defmethod create-request-handler-thread ((taskmaster one-thread-per-connection-taskmaster) socket)
"Create a thread for handling a single request"
;; we are handling all conditions here as we want to make sure that
;; the acceptor process never crashes while trying to create a
;; worker thread; one such problem exists in
;; GET-PEER-ADDRESS-AND-PORT which can signal socket conditions on
;; some platforms in certain situations.
(handler-case*
(start-thread
taskmaster
(lambda () (handle-incoming-connection% taskmaster socket))
:name (format nil (taskmaster-worker-thread-name-format taskmaster) (client-as-string socket)))
(error (cond)
;; need to bind *ACCEPTOR* so that LOG-MESSAGE* can do its work.
(let ((*acceptor* (taskmaster-acceptor taskmaster)))
(ignore-errors
(close (make-socket-stream socket *acceptor*) :abort t))
(log-message* *lisp-errors-log-level*
"Error while creating worker thread for new incoming connection: ~A" cond)))))
;;; usocket implementation
#-:lispworks
(defmethod shutdown ((taskmaster taskmaster))
taskmaster)
#-:lispworks
(defmethod shutdown ((taskmaster one-thread-per-connection-taskmaster))
;; just wait until the acceptor process has finished, then return
(bt:join-thread (acceptor-process taskmaster))
taskmaster)
#-:lispworks
(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
(create-request-handler-thread taskmaster socket))
#-lispworks
(defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket)
;; Here's the idea, with the stipulations given in ONE-THREAD-PER-CONNECTION-TASKMASTER
;; - If MAX-THREAD-COUNT is null, just start a taskmaster
;; - If the connection count will exceed MAX-ACCEPT-COUNT or if MAX-ACCEPT-COUNT
;; is null and the connection count will exceed MAX-THREAD-COUNT,
;; return an HTTP 503 error to the client
;; - Otherwise if we're between MAX-THREAD-COUNT and MAX-ACCEPT-COUNT,
;; wait until the connection count drops, then handle the request
;; - Otherwise, increment THREAD-COUNT and start a taskmaster
(increment-taskmaster-accept-count taskmaster)
(flet ((process-connection% (acceptor socket)
(increment-taskmaster-thread-count taskmaster)
(unwind-protect
(process-connection acceptor socket)
(decrement-taskmaster-thread-count taskmaster))))
(cond ((null (taskmaster-max-thread-count taskmaster))
;; No limit on number of requests, just start a taskmaster
(process-connection (taskmaster-acceptor taskmaster) socket))
((if (taskmaster-max-accept-count taskmaster)
(>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster))
(>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
;; Send HTTP 503 to indicate that we can't handle the request right now
(too-many-taskmaster-requests taskmaster socket)
(send-service-unavailable-reply taskmaster socket))
((and (taskmaster-max-accept-count taskmaster)
(>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
;; Wait for a request to finish, then carry on
(wait-for-free-connection taskmaster)
(process-connection% (taskmaster-acceptor taskmaster) socket))
(t
;; We're within both limits, just start a taskmaster
(process-connection% (taskmaster-acceptor taskmaster) socket)))))
(defun send-service-unavailable-reply (taskmaster socket)
"A helper function to send out a quick error reply, before any state
is set up via PROCESS-REQUEST."
(let* ((acceptor (taskmaster-acceptor taskmaster))
(*acceptor* acceptor)
(*hunchentoot-stream* (make-socket-stream socket acceptor)))
(unwind-protect
(with-conditions-caught-and-logged ()
(with-mapped-conditions ()
(let* ((*hunchentoot-stream* (initialize-connection-stream acceptor *hunchentoot-stream*))
(*reply* (make-instance (acceptor-reply-class acceptor)))
(*request* (acceptor-make-request acceptor socket)))
(with-character-stream-semantics
(send-response acceptor
(flex:make-flexi-stream *hunchentoot-stream* :external-format :iso-8859-1)
+http-service-unavailable+
:content (acceptor-status-message acceptor +http-service-unavailable+))))))
(decrement-taskmaster-accept-count taskmaster)
(when *hunchentoot-stream*
(ignore-errors*
(finish-output *hunchentoot-stream*))
(ignore-errors*
(close *hunchentoot-stream* :abort t))))))
(defun client-as-string (socket)
"A helper function which returns the client's address and port as a
string and tries to act robustly in the presence of network problems."
#-:lispworks
(let ((address (usocket:get-peer-address socket))
(port (usocket:get-peer-port socket)))
(when (and address port)
(format nil "~A:~A"
(usocket:vector-quad-to-dotted-quad address)
port)))
#+:lispworks
(multiple-value-bind (address port)
(comm:get-socket-peer-address socket)
(when (and address port)
(format nil "~A:~A"
(comm:ip-address-string address)
port))))
;; LispWorks implementation
#+:lispworks
(defmethod shutdown ((taskmaster taskmaster))
(when-let (process (acceptor-process (taskmaster-acceptor taskmaster)))
;; kill the main acceptor process, see LW documentation for
;; COMM:START-UP-SERVER
(mp:process-kill process))
taskmaster)
#+:lispworks
(defmethod handle-incoming-connection ((taskmaster one-thread-per-connection-taskmaster) socket)
(incf *worker-counter*)
;; check if we need to perform a global GC
(when (and *cleanup-interval*
(zerop (mod *worker-counter* *cleanup-interval*)))
(when *cleanup-function*
(funcall *cleanup-function*)))
(create-request-handler-thread taskmaster socket))
#+:lispworks
(defmethod handle-incoming-connection% ((taskmaster one-thread-per-connection-taskmaster) socket)
(increment-taskmaster-accept-count taskmaster)
(flet ((process-connection% (acceptor socket)
(increment-taskmaster-thread-count taskmaster)
(unwind-protect
(process-connection acceptor socket)
(decrement-taskmaster-thread-count taskmaster))))
(cond ((null (taskmaster-max-thread-count taskmaster))
;; No limit on number of requests, just start a taskmaster
(process-connection (taskmaster-acceptor taskmaster) socket))
((if (taskmaster-max-accept-count taskmaster)
(>= (taskmaster-accept-count taskmaster) (taskmaster-max-accept-count taskmaster))
(>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
;; Send HTTP 503 to indicate that we can't handle the request right now
(too-many-taskmaster-requests taskmaster socket)
(send-service-unavailable-reply taskmaster socket))
((and (taskmaster-max-accept-count taskmaster)
(>= (taskmaster-thread-count taskmaster) (taskmaster-max-thread-count taskmaster)))
;; Lispworks doesn't have condition variables, so punt
(too-many-taskmaster-requests taskmaster socket)
(send-service-unavailable-reply taskmaster socket))
(t
;; We're within both limits, just start a taskmaster
(process-connection% (taskmaster-acceptor taskmaster) socket)))))
hunchentoot-v1.2.38/cookie.lisp 0000644 0000000 0000000 00000012263 13211004253 015164 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defclass cookie ()
((name :initarg :name
:reader cookie-name
:type string
:documentation "The name of the cookie - a string.")
(value :initarg :value
:accessor cookie-value
:initform ""
:documentation "The value of the cookie. Will be URL-encoded
when sent to the browser.")
(expires :initarg :expires
:initform nil
:accessor cookie-expires
:documentation "The time \(a universal time) when the
cookie expires \(or NIL).")
(max-age :initarg :max-age
:initform nil
:accessor cookie-max-age
:documentation "The time delta \(in seconds) after which the
cookie expires \(or NIL).")
(path :initarg :path
:initform nil
:accessor cookie-path
:documentation "The path this cookie is valid for \(or NIL).")
(domain :initarg :domain
:initform nil
:accessor cookie-domain
:documentation "The domain this cookie is valid for \(or NIL).")
(secure :initarg :secure
:initform nil
:accessor cookie-secure
:documentation "A generalized boolean denoting whether this
cookie is a secure cookie.")
(http-only :initarg :http-only
:initform nil
:accessor cookie-http-only
:documentation "A generalized boolean denoting whether
this cookie is a `HttpOnly' cookie.
This is a Microsoft extension that has been implemented in Firefox as
well. See ."))
(:documentation "Each COOKIE objects describes one outgoing cookie."))
(defmethod initialize-instance :around ((cookie cookie) &rest init-args)
"Ensure COOKIE has a correct slot-value for NAME."
(let ((name (getf init-args :name)))
(unless (http-token-p name)
(parameter-error "~S is not a legal name for a cookie." name)))
(call-next-method))
(defun set-cookie* (cookie &optional (reply *reply*))
"Adds the COOKIE object COOKIE to the outgoing cookies of the
REPLY object REPLY. If a cookie with the same name
\(case-sensitive) already exists, it is replaced."
(let* ((name (cookie-name cookie))
(place (assoc name (cookies-out reply) :test #'string=)))
(cond
(place
(setf (cdr place) cookie))
(t
(push (cons name cookie) (cookies-out reply))
cookie))))
(defun set-cookie (name &key (value "") expires max-age path domain secure http-only (reply *reply*))
"Creates a cookie object from the parameters provided and adds
it to the outgoing cookies of the REPLY object REPLY. If a cookie
with the name NAME \(case-sensitive) already exists, it is
replaced."
(set-cookie* (make-instance 'cookie
:name name
:value value
:expires expires
:max-age max-age
:path path
:domain domain
:secure secure
:http-only http-only)
reply))
(defun cookie-date (universal-time)
"Converts UNIVERSAL-TIME to cookie date format."
(and universal-time
(rfc-1123-date universal-time)))
(defmethod stringify-cookie ((cookie cookie))
"Converts the COOKIE object COOKIE to a string suitable for a
'Set-Cookie' header to be sent to the client."
(format nil
"~A=~A~@[; Expires=~A~]~@[; Max-Age=~A~]~@[; Domain=~A~]~@[; Path=~A~]~:[~;; Secure~]~:[~;; HttpOnly~]"
(cookie-name cookie)
(cookie-value cookie)
(cookie-date (cookie-expires cookie))
(cookie-max-age cookie)
(cookie-domain cookie)
(cookie-path cookie)
(cookie-secure cookie)
(cookie-http-only cookie)))
hunchentoot-v1.2.38/log.lisp 0000644 0000000 0000000 00000006431 13211004253 014474 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defmacro with-log-stream ((stream-var destination lock) &body body)
"Helper macro to write log entries. STREAM-VAR is a symbol that
will be bound to the logging stream during the execution of BODY.
DESTINATION is the logging destination, which can be either a pathname
designator of the log file, a symbol designating an open stream or NIL
if no logging should be done. LOCK refers to the lock that should be
held during the logging operation. If DESTINATION is a pathname, a
flexi stream with UTF-8 encoding will be created and bound to
STREAM-VAR. If an error occurs while writing to the log file, that
error will be logged to *ERROR-OUTPUT*.
Note that logging to a file involves opening and closing the log file
for every logging operation, which is overall costly. Web servers
with high throughput demands should make use of a specialized logging
function rather than relying on Hunchentoot's default logging
facility."
(with-unique-names (binary-stream)
(with-rebinding (destination)
(let ((body body))
`(when ,destination
(with-lock-held (,lock)
(etypecase ,destination
((or string pathname)
(with-open-file (,binary-stream ,destination
:direction :output
:element-type 'octet
:if-does-not-exist :create
:if-exists :append
#+:openmcl :sharing #+:openmcl :lock)
(let ((,stream-var (make-flexi-stream ,binary-stream :external-format +utf-8+)))
,@body)))
(stream
(let ((,stream-var ,destination))
(prog1 (progn ,@body)
(finish-output ,destination)))))))))))
hunchentoot-v1.2.38/test/ 0000755 0000000 0000000 00000000000 13211004253 013775 5 ustar root root hunchentoot-v1.2.38/test/test-key-no-password.key 0000644 0000000 0000000 00000001567 13211004253 020537 0 ustar root root -----BEGIN RSA PRIVATE KEY-----
MIICWwIBAAKBgQDGlRpAhJ8QPDdztVIWxb6gpBWJquMyZk0kvtlZpmWxtWBE4+iE
JGOqZtLXKNDQNlBZkrg8zLJepP3Q5QhdKiEYAH07cz960ykxhpGXCzrqjaY3H9Hx
tNmoYNBxddGDUaGyrYmdCzKGXidNBcyfwoz+Mt3qJP1cl347oC5Z86W2JwIDAQAB
AoGAJoJhneNaCUb0Je8ipSHhzrsjJhhKiMqH6TlNYvI+xFB9A78CpyV7Yl8gQfM7
UzVFLamjKr8zU+FBC1Ju5co2sl4u3fPgXwuo5X36IVa03WdClXp0PQ7RsOXqi0Rx
d1maRkxPok7AnSMCAWNeLCgxVmCKzIWLKcvB8idK7evjGUkCQQDyoewf7ey1eNy7
hv87E9E/gUQ/9A9rEhkKcRbwvEicB+OcxpZl6Br0Z6EJH39AlJe1ii81lSqfPd+h
6WE2uU+lAkEA0YXmYnCJdlcYAORLX3ewibVCikOJUIMt7smGVOK23ubmHh49+KUW
HT3xDPDRVmkmiYzqXZOY0pGUG37b4GAE2wJAXRPa1kDanp835kSaYtpuWjNHsFT7
GTL/Ii9SApXoMNsh6QGRrpREyt96Olq34VlffYf+JksL57y/rogt/+VE9QJAV+vV
YmeQ92zSsMUb7+K83PyIAJcYjwWNB8/fI83DKURBOlA8dxNndTvh5ClF3vne5weP
7VabYXkfam5QfBYu0wJANPeIsAd8yUdZViiMOH6tE8DUlMy/p1N9Rz0eMSc4uUch
EB59djdHmSknY0JgVZJFybWFWKtbxSvcnrJq/hAcMQ==
-----END RSA PRIVATE KEY-----
hunchentoot-v1.2.38/test/test-certificate.crt 0000644 0000000 0000000 00000001305 13211004253 017745 0 ustar root root -----BEGIN CERTIFICATE-----
MIIB3TCCAUYCCQCDg/PAAhv7kjANBgkqhkiG9w0BAQQFADAzMQswCQYDVQQGEwJE
RTEQMA4GA1UECBMHR2VybWFueTESMBAGA1UEAxMJbG9jYWxob3N0MB4XDTA5MDIx
NjEyMTgzMFoXDTEwMDIxNjEyMTgzMFowMzELMAkGA1UEBhMCREUxEDAOBgNVBAgT
B0dlcm1hbnkxEjAQBgNVBAMTCWxvY2FsaG9zdDCBnzANBgkqhkiG9w0BAQEFAAOB
jQAwgYkCgYEAxpUaQISfEDw3c7VSFsW+oKQViarjMmZNJL7ZWaZlsbVgROPohCRj
qmbS1yjQ0DZQWZK4PMyyXqT90OUIXSohGAB9O3M/etMpMYaRlws66o2mNx/R8bTZ
qGDQcXXRg1Ghsq2JnQsyhl4nTQXMn8KM/jLd6iT9XJd+O6AuWfOlticCAwEAATAN
BgkqhkiG9w0BAQQFAAOBgQCUW7a5BvL8Qoy5Mvd9cxUt8jnDm5KRiEgcmBIIlrVi
bLXmEQaRPQDoxGsrzi/LaUuMitT/kaGwhbdhfwZsjXI2QxuqpPYRhLnPBvn6q77u
e0/yXaPp6UnMnQNw2O8xLcUDeLbRrw9IBPeDUYYP0OaTkJvORwFJ4e6rdVyha4o7
1A==
-----END CERTIFICATE-----
hunchentoot-v1.2.38/test/packages.lisp 0000755 0000000 0000000 00000003146 13211004253 016453 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage #:hunchentoot-test
(:nicknames #:tbnl-test)
(:use :cl :cl-who :hunchentoot)
(:export #:test-hunchentoot))
(defpackage #:hunchentoot-test-user
(:use :cl :hunchentoot)) hunchentoot-v1.2.38/test/test-handlers.lisp 0000644 0000000 0000000 00000055224 13211004253 017453 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot-test)
(defvar *this-file* (load-time-value
(or #.*compile-file-pathname* *load-pathname*)))
(defmacro with-html (&body body)
`(with-html-output-to-string (*standard-output* nil :prologue t)
,@body))
(defun hunchentoot-link ()
(with-html-output (*standard-output*)
(:a :href "http://weitz.de/hunchentoot/" "Hunchentoot")))
(defun menu-link ()
(with-html-output (*standard-output*)
(:p (:hr
(:a :href "/hunchentoot/test" "Back to menu")))))
(defmacro with-lisp-output ((var) &body body)
`(let ((*package* (find-package :hunchentoot-test-user)))
(with-output-to-string (,var #+:lispworks nil
#+:lispworks :element-type
#+:lispworks 'lw:simple-char)
,@body)))
(defmacro info-table (&rest forms)
(let ((=value= (gensym))
(=first= (gensym)))
`(with-html-output (*standard-output*)
(:p (:table :border 1 :cellpadding 2 :cellspacing 0
(:tr (:td :colspan 2
"Some Information "
(hunchentoot-link)
" provides about this request:"))
,@(loop for form in forms
collect `(:tr (:td :valign "top"
(:pre :style "padding: 0px"
(esc (with-lisp-output (s) (pprint ',form s)))))
(:td :valign "top"
(:pre :style "padding: 0px"
(esc (with-lisp-output (s)
(loop for ,=value= in (multiple-value-list ,form)
for ,=first= = t then nil
unless ,=first=
do (princ ", " s)
do (pprint ,=value= s))))))))))
(menu-link))))
(defun authorization-page ()
(multiple-value-bind (user password)
(authorization)
(cond ((and (equal user "nanook")
(equal password "igloo"))
(with-html
(:html
(:head (:title "Hunchentoot page with Basic Authentication"))
(:body
(:h2 (hunchentoot-link)
" page with Basic Authentication")
(info-table (header-in* :authorization)
(authorization))))))
(t
(require-authorization)))))
(defparameter *test-image*
(load-time-value
(with-open-file (in (make-pathname :name "fz" :type "jpg" :version nil
:defaults *this-file*)
:element-type 'flex:octet)
(let ((image-data (make-array (file-length in)
:element-type 'flex:octet)))
(read-sequence image-data in)
image-data))))
(defun image-ram-page ()
(setf (content-type*) "image/jpeg")
*test-image*)
(let ((count 0))
(defun info ()
(with-html
(:html
(:head (:title "Hunchentoot Information"))
(:body
(:h2 (hunchentoot-link) " Information Page")
(:p "This page has been called "
(:b
(fmt "~[~;once~;twice~:;~:*~R times~]" (incf count)))
" since its handler was compiled.")
(info-table (host)
(acceptor-address *acceptor*)
(acceptor-port *acceptor*)
(remote-addr*)
(remote-port*)
(real-remote-addr)
(request-method*)
(script-name*)
(query-string*)
(get-parameters*)
(headers-in*)
(cookies-in*)
(user-agent)
(referer)
(request-uri*)
(server-protocol*)))))))
(defun oops ()
(with-html
(log-message* :error "Oops \(error log level).")
(log-message* :warning "Oops \(warning log level).")
(log-message* :info "Oops \(info log level).")
(error "Errors were triggered on purpose. Check your error log.")
(:html
(:body "You should never see this sentence..."))))
(defun redir ()
(redirect "/hunchentoot/test/info.html?redirected=1"))
(defun forbidden ()
(setf (return-code*) +http-forbidden+)
nil)
(defun cookie-test ()
(set-cookie "pumpkin" :value "barking")
(no-cache)
(with-html
(:html
(:head (:title "Hunchentoot cookie test"))
(:body
(:h2 (hunchentoot-link)
" cookie test")
(:p "You might have to reload this page to see the cookie value.")
(info-table (cookie-in "pumpkin")
(mapcar 'car (cookies-in*)))))))
(defun session-test ()
(let ((new-foo-value (post-parameter "new-foo-value")))
(when new-foo-value
(setf (session-value 'foo) new-foo-value)))
(let ((new-bar-value (post-parameter "new-bar-value")))
(when new-bar-value
(setf (session-value 'bar) new-bar-value)))
(no-cache)
(with-html
(:html
(:head (:title "Hunchentoot session test"))
(:body
(:h2 (hunchentoot-link)
" session test")
(:p "Use the forms below to set new values for "
(:code "FOO")
" or "
(:code "BAR")
". You can later return to this page to check if
they're still set. Also, try to use another browser at the same
time or try with cookies disabled.")
(:p (:form :method :post
"New value for "
(:code "FOO")
": "
(:input :type :text
:name "new-foo-value"
:value (or (session-value 'foo) ""))))
(:p (:form :method :post
"New value for "
(:code "BAR")
": "
(:input :type :text
:name "new-bar-value"
:value (or (session-value 'bar) ""))))
(info-table (session-cookie-name *acceptor*)
(cookie-in (session-cookie-name *acceptor*))
(mapcar 'car (cookies-in*))
(session-value 'foo)
(session-value 'bar))))))
(defun parameter-test (&key (method :get) (charset :iso-8859-1))
(no-cache)
(recompute-request-parameters :external-format
(flex:make-external-format charset :eol-style :lf))
(setf (content-type*)
(format nil "text/html; charset=~A" charset))
(with-html
(:html
(:head (:title (fmt "Hunchentoot ~A parameter test" method)))
(:body
(:h2 (hunchentoot-link)
(fmt " ~A parameter test with charset ~A" method charset))
(:p "Enter some non-ASCII characters in the input field below
and see what's happening.")
(:p (:form
:method method
"Enter a value: "
(:input :type :text
:name "foo")))
(case method
(:get (info-table (query-string*)
(map 'list 'char-code (get-parameter "foo"))
(get-parameter "foo")))
(:post (info-table (raw-post-data)
(map 'list 'char-code (post-parameter "foo"))
(post-parameter "foo"))))))))
(defun parameter-test-latin1-get ()
(parameter-test :method :get :charset :iso-8859-1))
(defun parameter-test-latin1-post ()
(parameter-test :method :post :charset :iso-8859-1))
(defun parameter-test-utf8-get ()
(parameter-test :method :get :charset :utf-8))
(defun parameter-test-utf8-post ()
(parameter-test :method :post :charset :utf-8))
;; this should not be the same directory as *TMP-DIRECTORY* and it
;; should be initially empty (or non-existent)
(defvar *tmp-test-directory*
#+(or :win32 :mswindows) #p"c:\\hunchentoot-temp\\test\\"
#-(or :win32 :mswindows) #p"/tmp/hunchentoot/test/")
(defvar *tmp-test-files* nil)
(let ((counter 0))
(defun handle-file (post-parameter)
(when (and post-parameter
(listp post-parameter))
(destructuring-bind (path file-name content-type)
post-parameter
(let ((new-path (make-pathname :name (format nil "hunchentoot-test-~A"
(incf counter))
:type nil
:defaults *tmp-test-directory*)))
;; strip directory info sent by Windows browsers
(when (search "Windows" (user-agent) :test 'char-equal)
(setq file-name (cl-ppcre:regex-replace ".*\\\\" file-name "")))
(rename-file path (ensure-directories-exist new-path))
(push (list new-path file-name content-type) *tmp-test-files*))))))
(defun clean-tmp-dir ()
(loop for (path . nil) in *tmp-test-files*
when (probe-file path)
do (ignore-errors (delete-file path)))
(setq *tmp-test-files* nil))
(defun upload-test ()
(let (post-parameter-p)
(when (post-parameter "file1")
(handle-file (post-parameter "file1"))
(setq post-parameter-p t))
(when (post-parameter "file2")
(handle-file (post-parameter "file2"))
(setq post-parameter-p t))
(when (post-parameter "clean")
(clean-tmp-dir)
(setq post-parameter-p t)))
(no-cache)
(with-html
(:html
(:head (:title "Hunchentoot file upload test"))
(:body
(:h2 (hunchentoot-link)
" file upload test")
(:form :method :post :enctype "multipart/form-data"
(:p "First file: "
(:input :type :file
:name "file1"))
(:p "Second file: "
(:input :type :file
:name "file2"))
(:p (:input :type :submit)))
(when *tmp-test-files*
(htm
(:p
(:table :border 1 :cellpadding 2 :cellspacing 0
(:tr (:td :colspan 3 (:b "Uploaded files")))
(loop for (path file-name nil) in *tmp-test-files*
for counter from 1
do (htm
(:tr (:td :align "right" (str counter))
(:td (:a :href (format nil "files/~A?path=~A"
(url-encode file-name)
(url-encode (namestring path)))
(esc file-name)))
(:td :align "right"
(str (ignore-errors
(with-open-file (in path)
(file-length in))))
" Bytes"))))))
(:form :method :post
(:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
(menu-link)))))
(defun send-file ()
(let* ((path (get-parameter "path"))
(file-info (and path
(find path *tmp-test-files*
:key 'first :test (lambda (a b) (equal a (namestring b)))))))
(unless file-info
(setf (return-code*) +http-not-found+)
(return-from send-file))
(handle-static-file (first file-info) (third file-info))))
(defparameter *headline*
(load-time-value
(format nil "Hunchentoot test menu (see file ~A)"
(truename (merge-pathnames (make-pathname :type "lisp") *this-file*)))))
(defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf))
(defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*)
"Demo file stolen from .")
(defun stream-direct ()
(setf (content-type*) "text/html; charset=utf-8")
(let ((stream (send-headers))
(buffer (make-array 1024 :element-type 'flex:octet)))
(with-open-file (in *utf-8-file* :element-type 'flex:octet)
(loop for pos = (read-sequence buffer in)
until (zerop pos)
do (write-sequence buffer stream :end pos)))))
(defun stream-direct-utf-8 ()
(setf (content-type*) "text/html; charset=utf-8")
(let ((stream (flex:make-flexi-stream (send-headers) :external-format *utf-8*)))
(with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
:element-type 'flex:octet)
(setq in (flex:make-flexi-stream in :external-format *utf-8*))
(loop for line = (read-line in nil nil)
while line
do (write-line line stream)))))
(defun stream-direct-utf-8-string ()
(setf (content-type*) "text/html; charset=utf-8"
(reply-external-format*) *utf-8*)
(with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
:element-type 'flex:octet)
(let ((string (make-array (file-length in)
:element-type #-:lispworks 'character #+:lispworks 'lw:simple-char
:fill-pointer t)))
(setf in (flex:make-flexi-stream in :external-format *utf-8*)
(fill-pointer string) (read-sequence string in))
string)))
(define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html"
:default-request-type :post)
(first-name last-name
(age :parameter-type 'integer)
(implementation :parameter-type 'keyword)
(meal :parameter-type '(hash-table boolean))
(team :parameter-type 'list))
(with-html
(:html
(:head (:title "Hunchentoot \"easy\" handler example"))
(:body
(:h2 (hunchentoot-link)
" \"Easy\" handler example")
(:p (:form :method :post
(:table :border 1 :cellpadding 2 :cellspacing 0
(:tr
(:td "First Name:")
(:td (:input :type :text
:name "first-name"
:value (or first-name "Donald"))))
(:tr
(:td "Last name:")
(:td (:input :type :text
:name "last-name"
:value (or last-name "Duck"))))
(:tr
(:td "Age:")
(:td (:input :type :text
:name "age"
:value (or age 42))))
(:tr
(:td "Implementation:")
(:td (:select :name "implementation"
(loop for (value option) in '((:lispworks "LispWorks")
(:allegro "AllegroCL")
(:cmu "CMUCL")
(:sbcl "SBCL")
(:openmcl "OpenMCL"))
do (htm
(:option :value value
:selected (eq value implementation)
(str option)))))))
(:tr
(:td :valign :top "Meal:")
(:td (loop for choice in '("Burnt weeny sandwich"
"Canard du jour"
"Easy meat"
"Muffin"
"Twenty small cigars"
"Yellow snow")
do (htm
(:input :type "checkbox"
:name (format nil "meal{~A}" choice)
:checked (gethash choice meal)
(esc choice))
(:br)))))
(:tr
(:td :valign :top "Team:")
(:td (loop for player in '("Beckenbauer"
"Cruyff"
"Maradona"
;; without accent (for SBCL)
"Pele"
"Zidane")
do (htm
(:input :type "checkbox"
:name "team"
:value player
:checked (member player team :test 'string=)
(esc player))
(:br)))))
(:tr
(:td :colspan 2
(:input :type "submit"))))))
(info-table first-name
last-name
age
implementation
(loop :for choice :being :the :hash-keys :of meal :collect choice)
(gethash "Yellow snow" meal)
team)))))
(defun menu ()
(with-html
(:html
(:head
(:link :rel "shortcut icon"
:href "/hunchentoot/test/favicon.ico" :type "image/x-icon")
(:title "Hunchentoot test menu"))
(:body
(:h2 (str *headline*))
(:table :border 0 :cellspacing 4 :cellpadding 4
(:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar"
"Info provided by Hunchentoot")))
(:tr (:td (:a :href "/hunchentoot/test/cookie.html"
"Cookie test")))
(:tr (:td (:a :href "/hunchentoot/test/session.html"
"Session test")))
(:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html"
"GET parameter handling with LATIN-1 charset")))
(:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html"
"POST parameter handling with LATIN-1 charset")))
(:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html"
"GET parameter handling with UTF-8 charset")))
(:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html"
"POST parameter handling with UTF-8 charset")))
(:tr (:td (:a :href "/hunchentoot/test/redir.html"
"Redirect \(302) to info page above")))
(:tr (:td (:a :href "/hunchentoot/test/authorization.html"
"Authorization")
" (user 'nanook', password 'igloo')"))
(:tr (:td (:a :href "/hunchentoot/code/test-handlers.lisp"
"The source code of this test")))
(:tr (:td (:a :href "/hunchentoot/test/image.jpg"
"Binary data, delivered from file")
" \(a picture)"))
(:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg"
"Binary data, delivered from RAM")
" \(same picture)"))
(:tr (:td (:a :href "/hunchentoot/test/easy-demo.html"
"\"Easy\" handler example")))
(:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt"
"UTF-8 demo")
" \(writing octets directly to the stream)"))
(:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt"
"UTF-8 demo")
" \(writing UTF-8 characters directly to the stream)"))
(:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt"
"UTF-8 demo")
" \(returning a string)"))
(:tr (:td (:a :href "/hunchentoot/test/upload.html"
"File uploads")))
(:tr (:td (:a :href "/hunchentoot/test/forbidden.html"
"Forbidden \(403) page")))
(:tr (:td (:a :href "/hunchentoot/test/oops.html"
"Error handling")
" \(output depends on "
(:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*"
(:code "*SHOW-LISP-ERRORS-P*"))
(fmt " \(currently ~S))" *show-lisp-errors-p*)))
(:tr (:td (:a :href "/hunchentoot/foo"
"URI handled by")
" "
(:a :href "http://weitz.de/hunchentoot/#*default-handler*"
(:code "*DEFAULT-HANDLER*")))))))))
(setq *dispatch-table*
(nconc
(list 'dispatch-easy-handlers
(create-static-file-dispatcher-and-handler
"/hunchentoot/test/image.jpg"
(make-pathname :name "fz" :type "jpg" :version nil
:defaults *this-file*)
"image/jpeg")
(create-static-file-dispatcher-and-handler
"/hunchentoot/test/favicon.ico"
(make-pathname :name "favicon" :type "ico" :version nil
:defaults *this-file*))
(create-folder-dispatcher-and-handler
"/hunchentoot/code/"
(make-pathname :name nil :type nil :version nil
:defaults *this-file*)
"text/plain"))
(mapcar (lambda (args)
(apply 'create-prefix-dispatcher args))
'(("/hunchentoot/test/form-test.html" form-test)
("/hunchentoot/test/forbidden.html" forbidden)
("/hunchentoot/test/info.html" info)
("/hunchentoot/test/authorization.html" authorization-page)
("/hunchentoot/test/image-ram.jpg" image-ram-page)
("/hunchentoot/test/cookie.html" cookie-test)
("/hunchentoot/test/session.html" session-test)
("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get)
("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post)
("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get)
("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post)
("/hunchentoot/test/upload.html" upload-test)
("/hunchentoot/test/redir.html" redir)
("/hunchentoot/test/oops.html" oops)
("/hunchentoot/test/utf8-binary.txt" stream-direct)
("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8)
("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string)
("/hunchentoot/test/files/" send-file)
("/hunchentoot/test" menu)))))
hunchentoot-v1.2.38/test/script-engine.lisp 0000644 0000000 0000000 00000016101 13211004253 017434 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot-test)
(defun file-contents (pathname &key (element-type '(unsigned-byte 8)))
(with-open-file (s pathname :element-type element-type)
(let ((result (make-array (file-length s) :element-type element-type)))
(read-sequence result s)
result)))
(defclass script-context ()
((base-url :initarg :base-url
:reader script-context-base-url
:documentation "Base URL to be used for all HTTP requests in this script context")))
(defmethod initialize-instance :before ((script-context script-context) &key context-class-name)
;; just ignore the context-class-name so that we can use &args in the WITH-SCRIPT-CONTEXT macro below.
(declare (ignore context-class-name)))
(defvar *script-context* nil
"Current script context")
(defmacro with-script-context ((&rest args &key (context-class-name 'script-context) &allow-other-keys)
&body body)
`(let ((*script-context* (make-instance ',context-class-name ,@args))
(*default-pathname-defaults* *this-file*)
failed)
(handler-bind
((assertion-failed (lambda (condition)
(push condition failed)
(format t "Assertion failed:~%~A~%" condition))))
(prog1
(progn ,@body
(values))
(if failed
(format t ";; ~A assertion~:P FAILED~%" (length failed))
(format t ";; all tests PASSED~%"))))))
(defclass http-reply ()
((body :initarg :body)
(status-code :initarg :status-code)
(headers :initarg :headers)
(uri :initarg :uri)
(stream :initarg :stream)
(close :initarg :close)
(reason-phrase :initarg :reason-phrase)))
(defvar *last-reply* nil
"Contains the last HTTP reply received")
(define-condition assertion-failed (simple-condition)
((assertion :initarg :assertion
:accessor condition-assertion
:initform nil)
(reply-slot-name :initarg :reply-slot-name
:reader condition-reply-slot-name)
(reply-value :initarg :reply-value
:reader condition-reply-value)
(operator :initarg :operator
:reader condition-operator)
(args :initarg :args
:reader condition-args)
(reply :initarg :reply
:reader condition-reply))
(:report print-assertion))
(defun print-assertion (condition stream)
(format stream " (~A "
(condition-operator condition))
(loop
for rest on (cons (condition-reply-value condition)
(condition-args condition))
for value = (car rest)
for more-p = (cdr rest)
do (if (and (arrayp value) (not (stringp value)))
(format stream "")
(format stream "~S" value))
when more-p
do (princ #\Space stream))
(format stream ")~%"))
(defun function-designator-p (thing)
"Return true value if THING is a function or a symbol that has a function definition."
(or (functionp thing)
(and (symbolp thing)
(fboundp thing))))
(defmacro with-operator-defaulting ((default-operator) &body body)
"If OPERATOR is not a function designator, prepend it to ARGS and
bind OPERATOR to DEFAULT-OPERATOR. OPERATOR and ARGS are captured
from the expansion environment."
`(if (function-designator-p operator)
(progn ,@body)
(let ((operator ',default-operator)
(args (cons operator args)))
,@body)))
(defun http-assert (reply-slot-name operator &rest args)
(let ((reply-value (slot-value *last-reply* reply-slot-name)))
(with-operator-defaulting (equal)
(unless (apply operator reply-value args)
(signal 'assertion-failed
:reply-slot-name reply-slot-name
:reply-value reply-value
:operator operator
:args args
:reply *last-reply*)))))
(define-condition header-assertion-failed (assertion-failed)
((header-name :initarg :header-name :reader condition-header-name)))
(defun http-assert-header (header-name operator &rest args)
(let ((header-value (cdr (assoc header-name (slot-value *last-reply* 'headers) :test #'string-equal))))
(with-operator-defaulting (matches)
(unless (apply operator header-value args)
(signal 'header-assertion-failed
:reply-slot-name 'headers
:header-name header-name
:reply-value header-value
:operator operator
:args args
:reply *last-reply*)))))
(defun http-assert-body (regex)
(http-assert 'body 'matches regex))
(defun matches (string regex)
(cl-ppcre:scan regex string))
(defun integer-equal (string integer)
(eql (parse-integer string) integer))
(defun http-request (url
&rest args
&key (protocol :http/1.1)
(method :get)
content
content-type
content-length
range
cookie-jar
basic-authorization
parameters
external-format-out
additional-headers)
(declare (ignore protocol method content content-type content-length cookie-jar basic-authorization
range parameters external-format-out additional-headers))
(setf *last-reply* (make-instance 'http-reply))
(with-slots (body status-code headers uri stream close) *last-reply*
(setf (values body status-code headers uri stream close)
(apply 'drakma:http-request
(format nil "~A~A" (script-context-base-url *script-context*) url)
args)))
(values))
hunchentoot-v1.2.38/test/script.lisp 0000644 0000000 0000000 00000022064 13211004253 016176 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot-test)
(defun file-length-string (pathname)
(with-open-file (f pathname)
(princ-to-string (file-length f))))
(defun say (fmt &rest args)
(format t "; ")
(apply #'format t fmt args)
(terpri))
(defun test-hunchentoot (base-url &key (make-cookie-jar
(lambda ()
(make-instance 'drakma:cookie-jar))))
"Runs the built-in confidence test. BASE-URL is the base URL to use
for testing, it should not have a trailing slash. The keyword
arguments accepted are for future extension and should not currently
be used.
The script expects the Hunchentoot example test server to be running
at the given BASE-URL and retrieves various pages from that server,
expecting certain responses."
(with-script-context (:base-url (format nil "~A/hunchentoot/test/" base-url))
(say "Request home page")
(http-request "")
(http-assert 'status-code 200)
(http-assert-header :content-type "^text/html")
(say "Test cookies")
(let ((cookie-jar (funcall make-cookie-jar)))
(http-request "cookie.html" :cookie-jar cookie-jar)
(http-request "cookie.html" :cookie-jar cookie-jar)
(http-assert-body "(?msi)COOKIE-IN "pumpkin".*"barking""))
(say "Test session variables")
(let ((cookie-jar (funcall make-cookie-jar)))
(http-request "session.html" :cookie-jar cookie-jar
:method :post :parameters '(("new-foo-value" . "ABC") ("new-bar-value" . "DEF")))
(http-request "session.html" :cookie-jar cookie-jar)
;; These assertions assume that SESSION-VALUE returns the found alist value as second value
(http-assert-body "(?i)\(HUNCHENTOOT-TEST::FOO . "ABC"\)")
(http-assert-body "(?i)\(HUNCHENTOOT-TEST::BAR . "DEF"\)"))
(say "Test malformed session cookie validation")
(dolist (session-id '("" "invalid-session-id" ":invalid-session-id" "invalid:session-id"))
(http-request "session.html"
:additional-headers (acons "Cookie" (format nil "hunchentoot-session=~A" session-id) nil))
(http-assert 'status-code 200)
;; session is empty
(http-assert-body "(?i)\(HUNCHENTOOT-TEST::FOO\)"))
(say "Test GET parameters with foreign characters (Latin-1)")
(http-request "parameter_latin1_get.html"
:external-format-out :iso-8859-1
:parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252))))
:additional-headers '(("Content-Type" . "text/plain; charset=iso-8859-1")))
(http-assert-header :content-type "(?i)text/html; charset=ISO-8859-1")
(http-assert-body "(72 252 104 110 101 114)")
(http-assert-body "(?i)"Hühner"")
(say "Test POST parameters with foreign characters (Latin-1)")
(http-request "parameter_latin1_post.html"
:external-format-out :iso-8859-1
:method :post :parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252)))))
(http-assert-header :content-type "(?i)text/html; charset=ISO-8859-1")
(http-assert-body "(72 252 104 110 101 114)")
(http-assert-body "(?i)"Hühner"")
(say "Test GET parameters with foreign characters (UTF-8)")
(http-request "parameter_utf8_get.html"
:external-format-out :utf-8
:parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252)))))
(http-assert-header :content-type "(?i)text/html; charset=UTF-8")
(http-assert-body "(72 252 104 110 101 114)")
(http-assert-body "(?i)"Hühner"")
(say "Test POST parameters with foreign characters (UTF-8)")
(http-request "parameter_utf8_post.html"
:method :post
:external-format-out :utf-8
:parameters (list (cons "foo" (format nil "H~Chner" #.(code-char 252)))))
(http-assert-header :content-type "(?i)text/html; charset=UTF-8")
(http-assert-body "(72 252 104 110 101 114)")
(http-assert-body "(?i)"Hühner"")
(say "Test redirection")
(http-request "redir.html")
(http-assert 'uri (lambda (uri)
(matches (princ-to-string uri) "info.html\\?redirected=1")))
(say "Test authorization")
(http-request "authorization.html")
(http-assert 'status-code 401)
(http-request "authorization.html"
:basic-authorization '("nanook" "igloo"))
(http-assert 'status-code 200)
(say "Request the Zappa image")
(http-request "image.jpg")
(http-assert-header :content-length (file-length-string #P"fz.jpg"))
(http-assert-header :content-type "image/jpeg")
(http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg"))
(say "Request the Zappa image from RAM")
(http-request "image-ram.jpg")
(http-assert-header :content-length (file-length-string #P"fz.jpg"))
(http-assert-header :content-type "image/jpeg")
(http-assert 'body (complement #'mismatch) (file-contents #P"fz.jpg"))
(say "Upload a file")
(http-request "upload.html"
:method :post :parameters '(("clean" . "doit")))
(http-request "upload.html"
:method :post :parameters '(("file1" #P"fz.jpg")))
(http-request "upload.html")
(http-assert-body (format nil "fz.jpg.*>~A Bytes" (file-length-string #P"fz.jpg")))
(say "Range tests")
(say " Upload file")
(let* ((range-test-file-size (* 256 1024)) ; large enough to have hunchentoot use multiple buffers when reading back data, should be aligned to 1024
(range-test-buffer (make-array range-test-file-size :element-type '(unsigned-byte 8)))
(uploaded-file-url "files/?path=user-stream")) ; The uploaded file will appear under the name "user-stream" in hunchentoot
(dotimes (i range-test-file-size)
(setf (aref range-test-buffer i) (random 256)))
(flex:with-input-from-sequence (upload-stream range-test-buffer)
(http-request "upload.html"
:method :post :parameters `(("file1" ,upload-stream))))
(say " Request the uploaded file, verify contents")
(http-request uploaded-file-url)
(http-assert-header :content-length (princ-to-string range-test-file-size))
(http-assert 'body (complement #'mismatch) range-test-buffer)
(say " Verify responses to partial requests")
(say " Request just one byte")
(http-request uploaded-file-url :range '(0 0))
(http-assert 'status-code 206)
(http-assert 'body 'equalp (subseq range-test-buffer 0 1))
(http-assert-header :content-range (format nil "bytes 0-0/~D" range-test-file-size))
(say " End out of range")
(http-request uploaded-file-url :range (list 0 range-test-file-size))
(http-assert 'status-code 416)
(http-assert-header :content-range (format nil "bytes 0-~D/~A" (1- range-test-file-size) range-test-file-size))
(say " Request whole file as partial")
(http-request uploaded-file-url :range (list 0 (1- range-test-file-size)))
(http-assert 'status-code 206)
(http-assert 'body 'equalp range-test-buffer)
(http-assert-header :content-range (format nil "bytes 0-~D/~D" (1- range-test-file-size) range-test-file-size))
(say " Request something in the middle")
(let ((start-offset (/ range-test-file-size 4))
(length (/ range-test-file-size 2)))
(http-request uploaded-file-url :range (list start-offset (1- length)))
(http-assert 'status-code 206)
(http-assert 'body 'equalp (subseq range-test-buffer start-offset length))
(http-assert-header :content-range (format nil "bytes ~D-~D/~D" start-offset (1- length) range-test-file-size))))
(values)))
hunchentoot-v1.2.38/test/UTF-8-demo.html 0000644 0000000 0000000 00000032651 13211004253 016417 0 ustar root root
UTF-8 test file
Original by Markus Kuhn, adapted for HTML by Martin Dürst.
UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Markus Kuhn [ˈmaʳkʊs kuːn] <mkuhn@acm.org> — 1999-08-20
The ASCII compatible UTF-8 encoding of ISO 10646 and Unicode
plain-text files is defined in RFC 2279 and in ISO 10646-1 Annex R.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and Sciences:
∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β),
ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (A ⇔ B),
2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm
Linguistics and dictionaries:
ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
APL:
((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
Nicer typography in plain text files:
╔══════════════════════════════════════════╗
║ ║
║ • ‘single’ and “double” quotes ║
║ ║
║ • Curly apostrophes: “We’ve been here” ║
║ ║
║ • Latin-1 apostrophe and accents: '´` ║
║ ║
║ • ‚deutsche‘ „Anführungszeichen“ ║
║ ║
║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
║ ║
║ • ASCII safety test: 1lI|, 0OD, 8B ║
║ ╭─────────╮ ║
║ • the euro symbol: │ 14.95 € │ ║
║ ╰─────────╯ ║
╚══════════════════════════════════════════╝
Greek (in Polytonic):
The Greek anthem:
Σὲ γνωρίζω ἀπὸ τὴν κόψη
τοῦ σπαθιοῦ τὴν τρομερή,
σὲ γνωρίζω ἀπὸ τὴν ὄψη
ποὺ μὲ βία μετράει τὴ γῆ.
᾿Απ᾿ τὰ κόκκαλα βγαλμένη
τῶν ῾Ελλήνων τὰ ἱερά
καὶ σὰν πρῶτα ἀνδρειωμένη
χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
From a speech of Demosthenes in the 4th century BC:
Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
Georgian:
From a Unicode conference invitation:
გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
Russian:
From a Unicode conference invitation:
Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
Конференция соберет широкий круг экспертов по вопросам глобального
Интернета и Unicode, локализации и интернационализации, воплощению и
применению Unicode в различных операционных системах и программных
приложениях, шрифтах, верстке и многоязычных компьютерных системах.
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
ሰማይ አይታረስ ንጉሥ አይከሰስ።
ብላ ካለኝ እንደአባቴ በቆመጠኝ።
ጌጥ ያለቤቱ ቁምጥና ነው።
ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
የአፍ ወለምታ በቅቤ አይታሽም።
አይጥ በበላ ዳዋ ተመታ።
ሲተረጉሙ ይደረግሙ።
ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
ድር ቢያብር አንበሳ ያስር።
ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
ሥራ ከመፍታት ልጄን ላፋታት።
ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
ተንጋሎ ቢተፉ ተመልሶ ባፉ።
ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
እግርህን በፍራሽህ ልክ ዘርጋ።
Runes:
ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
–—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა
Greetings in various languages:
Hello world, Καλημέρα κόσμε, コンニチハ
Box drawing alignment tests: █
▉
╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
hunchentoot-v1.2.38/test/favicon.ico 0000755 0000000 0000000 00000000476 13211004253 016130 0 ustar root root ( ( fff 2B0 !! BB@ g $ hunchentoot-v1.2.38/test/fz.jpg 0000644 0000000 0000000 00000051011 13211004253 015114 0 ustar root root JFIF H H C
% # , #&')*) -0-(0%()( C
((((((((((((((((((((((((((((((((((((((((((((((((((( " ~.4#3:4
3(
!-!hfFR3eliA= 3cHfeS>SQlpy) PwRdE j7x [.F$ %`A<E:t\N\; ۊBtԖ ^;:yAK]*2$OͧB WJ@ e(lZ?R9 D@JbRF!7NAK AШ٤&1V5$$Qq4
*ͤ
l ,> Yۑ苴F% HYj]D-H6ɜ186ae#؛K#ʄL16Yr÷ ,`>כ79 Qӆ͉'%!'7$E3&/֊@x { uv,EƮǢ'gr|_O)\6YV <{(4 O㥙9hJZ nA0eH?' //} jO}ؾy389tW Q #}g# xoOɑ:R떐iR˞բӛ[tX陦 9dm)[LQ_13pzbxxrg! x~yyw<4,2#wuWbs2Z/Rxw߉^mW*r;wvr,>8)[ I?קi12V02r~ -xlN=p<;rn9g֩y(% xs)M&ȶ rw_K4 x{&<_Kں[Y.'l[{*4[]kmw6Ojsh\_T4@Mb:g"zqFhŖ[S:xgۊߤ~)w]B
$i [`ݑ|:dfRGLpKL.;*..98cZrjZV G-7mV%d"lPeɴ%fxԖ7Љ;i$ eHeܷrזUj_-Pd|:JuWv/DQ-ZBfD#&beKoSܷ-r? [7"&/ZHͪZ#( 6=K,s0J/oZ("wy=ݔl扟i2؇ sClγp ?+~
j{~SO
-ǑiS=* /,G#L,46;s&eNw-fA:jU-wN]#I3[ip ^-OѹH1Ju+k,y+5} ?O o
LZ cc/ VZ-:6Ax G5j`-Hr[%{^ FPUF5ecfKUe˸Im~${ڎVnuFQ(QCVGhL36`nJҹ>hkǎȌ7ao >{[C( G+Y}` 23*r7*/9"k/:/:+ 1 ; Eyd<@d VUٴ.NXH 8 Ev9qwD%M1A^-ֺ[{cY nzjZyj~8:;Z.%tr>FIJ9nDErѮ&d˺q`qu7,yS]ך4:#L`2ק- ÿQ C ɗ 6*IZpݩ#
~x$+] jp)# tb Lvnsf} Cf疮uiJLFus!|}NG~Yc x)
*`,2Ual X%0M5S).Ayg-_1-EotdˈfJG^噀 cI7ϐ!Ml<36c-V!nrQ& +P. M ˦\9MWBC 6 O ؈ _1;6?י lQO( MLsߗgx(Ny"3Ua7h<7maL^ܞ$lrܵZ (Y-Y )+yePMݓstEgr^ P&CJff[g 㫷5i BQx_W c^Nῥ̦Ẇ ȽhJ6YV%KoӾqx"tp'&| N7z7vLzx YJf sClI Ѭhԍ $|9Ud4. ZdXtQQvfOZ'bҧQ炫 ~"kU|=Yxjl̴ іO^'Rc)炢HnWWqGn^߸ 3!> \h;gƈ5Y5 NUg-9IHjFV1eV
fjѲhZ2ڸ
* Ղ$+Ux!F&SνJ6 ը8ye9SGjn\Jv![~x nPxǚΔ.@vXjNxy3s
ĉ)V b Dĉ'HeU~'+ Yb0
y.;juIXk3|t36%f89bm.wRgU
)xB `'4Uk{]
YNSpj ${y*atJjƹ:LN!
ߏmDNyNsm!":^ :e)j#"<#FdQ9@6c[;gTx.V/qCױ2#[nAe $l8-V1D
ΫkbCR,7'
SkpI]zG{kE]`l ZY PbI99õ X
K& A4LZ$e-Ĭrs1>/q]f:EV|U
Ղ)~gQ˄hvG
fK9չF_=5h.vP2'յdX+Ze2,\#n;mɭ4*-N1-.k89$X Z&uF٭ D W$ s*7+.S8AkYCÉ
vz /q|Y[XԡiMʹoZS)̡ߵg1@hVr2lWY$+iW 7+%b=rP<^'*)yIm dNxkrD% 9Bw0*D"\vc݂ [
Pŭ'%a\ -ڌ_Tb|8OaeՃ )vj%d:|#
p ļܫr o:Ԏ`S
&GZ\ > u`-hb ,YuktksA .b£<>C*ZpWb+4;e
P%6dXr R-9Znni݊`K@v6!?)\53SMd9ؽުp 4f봩ar+pU\J_B=h
Mh?jk"NfeIg,垳 8+z /qţ f
I@UC~ҫuZ_[;1en
NJB{|l֬Laɶxf- oW+<~C"q& L1X6NN85%|pAHYHwj1(瓏+ҝ
3K^XAjD z.7lUg3=MӵVk"rZС25P_NIÝ8g>;'Ȑڀ=]X%)'!yVGDs \.ڲ"4*#[hk7+煕
5%%֫;ʪZcB-ȕҋZ{!|]HsdJ0ٷ {`wbQH( D j,bަV@"ǖj @(
!of4 -Yfg
-U*g]ʷοoTrQ\j) ݨmmeqo 1F$ q,R-k $"|#n*=hj 8V2JD IT*3ʅL"F1|B.m 167b6ۿ_Y1 /qF
:ȵXFζVdoڬYw'hjP-l ʹ6= m!jSR- +~ D)O'
8u>sj (khp/qEj;.Sm P9V zUA3I֍Bnښ+R"hδhKD IO:ͣ9TV78eIBctgĞՍG{|6j)2ZT8Ԛmwbr~Oū `CHs
6Rb R֎:eZ-VBi*+a֨ Zbl8Z _d daRM,6 VjWdLmMGy!s#)}*/Fwz P24WkZGScRۙ@x+UZե %Vrܲr5XY5zɊVLaX敘z Y> rVpJ_(Ջrjx` ZE
\GbLj 'D$2+bIYq %[
hجtA#=ttnYwS'Pq,l͕lCJ&j =NC8W"))Sif GlHp BuV1ەh\.Vr Y\@k˾%Q0
TxMZ mZlHqɗ {vG Cd\ VZ:>hhhhhhhZ8Z8hn9,Փ/˗zo ~S+G'T[3/w L"uN1
d3[8 8BpCVb8y+̸
% K!n#A x`=2GV|ttYt2Vs/E˞Xt.21 eRV#mW/S
1S(j
0!qs' fA 73P6Y91m7Rt& V d%뵵3g]({X GqqG-1 UkyEi@QC` \; <=vۦφsQ(a/DbC1h豎6F!_igQ
"̍S x* ҈,lib;Q^e6<7Qd ]c+ #x(#A\2y0l[iC]^ވN :V|"νF D9,:4 b} > w]z6P
#"C!%H)#0lȂfË"00H xvnĴ샙"$ǡF0yHO0b ݂U{`xwcsh;$Z%Y4oP.[/"b
agR7ߡuYEtqp; ?vsRs k1_ʬf ,oܨ Mef0Rog)q 9X] ܍j"G-{u
p\ PHfԄwֺ{7i( Z LBKjeezU>D1v/=F+ qeq;\괉 _ŷ1UU UQ2]+y+0P(P 'Ш}ǧYI LLfGѣqnx#.Fo[pm9 /} oGt756 t6F0&tr;Ɏb^µUTK %Y &[j2{:
!a$^ NL,W O"}N-F.Nb<\B(v!rn0lԽUWS vq^Ua1;aL0|x\\[[Jf
@M!(LDt0a4AtvGڂ71Az;E$e̢"N s!e cli.8 6f,Jx辄FG\שu+ظ&T YBi$0=WKrxJY(-
/*x \k*%/,ff؏#ߣ]0l F.`TRRh;M\m^.=؈jvI* APg 7d+Rծ:;'.$%m BMW%2Ǹ 4}逶:Z3-LmutQQSBG1Z y(x/ 0k+ JUot"ڥe LCXu ^6}` v߸p߿ip7 ܥ-4({
! Bڢ
orƮY(0bQ/a2l*Q2 j #U 3 (\`a+$+Dw!+]/ ]h:UWtu ձ@;J a¯dj]&|Gu)*U%l^p[ f_#X `&'bMY
#NQI-e6f9u,ԥqW{S ?pfEQ-.9e(jM@ dcPXxԵ¥$;!iA
IDlDr:7!g)t~
6wp)z|]lVUZw.c'Da*笡78?Gf>;cq=̧f9#ū' (n&1"x(sʨp "o
|Ų7Ne(s"V'2RK $_ޮ6w<
Bf}Soqx.:tI55<ŗ(,E;!CN<嗄_ ;anQ?f'M5VxoHzM rJg oEc&TWXI^
eaA`Qi2h&f{|n[ҲdV/
^5{D pyb3!\9`T+ y +aD+ >m0̳y%+% I فO4ڟ}*W-0Up"B .]j5"[m'[P˞3K
>:
WnA2P_ߍqHnJwQd?Sr "*a;6p{ GsWN}$2iwUAE`Y; <7a7ƾE _nϱ-IZ~x_} y"G8!JVa?>I[Q1U
fu=F^h? H:K4o(CpLq]uzrԿ KE)٩DrmUؐRO2J{!ԥ
hZ'c3O3{/ЍBݞ@m>aң Z=^,q= زW/ GbŻ"ٱjիXaëY,XlqbçNZݧN\r]p L)+/ˡ,j;;<}O6߯ yvaB,I~=!! 3 }O8(Q {9 !Hb8\9
8<~ QM뜲ݹ:>t S~ /O ?M l |8 rm7],?;^c?<.y,M?~ 7
RO8`H,=7̒7 p4$ԇ=ߐ p5ݲE C<$7h 0 1):opӮ=7Ǯso .-m{횚'
1@aq !0 ?HZZZZZZZZZZZZZ)WwcGv:xtwa/;?wGvK%K% twd% wGw߇ 8pwET%? a1@!0 ?{ 8pÇ 8pÇ 8pÇ'3]Qv)|QvEڋj.]Qvc. <9' ' !1AQaq ?0
Ja( N ^U&b1ʫyїq*˪AQK]Y?"8`ŏk9:o&jK Lؘ9%{ɉpDn*Rp !'M "' ȟ#/'Y <6E&KP%4"k/JTy $3 h}AʆjZ {WB :2j\-vW %cuX
fzƂ&u O2-ݨm+PE)Ϩ0QˬGrn4kim=7Vе.٢ %7Q
;r{l>jYL%p!sxv 'lUcvŚh|A_6SnN1[{o*!|xGVX*`JkK1EPp [ 凓qWN2z Faj1e H{fij,ȝm -q⥮-~Mѫ2rɿVԣA+|̃DֆFcC:V|A AܿYϱ^_kV Hac RW1C /GD{G4T4gcEv>a
KC4? 3%)ʪW}`IQj(ı(E^K3h/c
MLQqԨ 'eFk/'b (3 s7XM boyU-Ϋu^:J~#^W#]F^D,@(*v
#,4Tm* !|*g':tFlq'v9@ 9k\a#z"c-1he +p-ԲLM
Pr] :%oqRPЈ! \ 2(_~hP*!0}ub֡ 04RYx4]*F Rt_CVn'Uĭ[
OHɣil\t7qJϑhrӿp"Ɔcpytk@3\B 22q_
Y|DGV}YwPܡvolR/ēwEYs_Zs
ا(B:@l=}A6ls
ަ;k7Gl0uJc//3mj[7jXaB&1*#/bojXH!֣U `uoT?pZZ7> .xj<ƝC^b!MuXTo:=Nk 0/ R4zv8qUYa\%3 Kq[Qlkx|M+3 @Զ bJ*b'R@{mT0lǾyCI
"P?T=T9D|-|KO0'ESReMNj7D0(-u-Ȃw]OZq)SwxAӃM LgE4w ʢm8>@蘕ү;#jkA* Ja [TbMNjMgrG8$5lp/ds"j7U4髌YbO'g
ԀL-{Y މu:sEjX8=wܹ)nW!m2WvjY+ E-Wu)bc$TaB;urp@MVL(%J KJa8% F>9]g5Ӌk\N'Tտ=JFUop*thnA9a-`:G.L2:biz. g*2$!zuҗc ҝ|o.!i ]Q9^zgc" j_qH 3d5xAU1Fl#Z eAIJ႟'0d3grѮpaumj
B~#3 >s
"hUk#_I1jVe2 > E`aU5)JwZSp&[ǘL FY1P}11YY"- -L>v BO1Bֳ6Zb0hqߑ6 vEҧ ]P j2!'B,/ܩIQ|C *Yfx U)mW%D}Nߝ:D(J
z8Gя07菪TJ`,$AhYMA.Q.[{k
c 7.ՐƇlk `{/0@O,a|Ayj?Y T[\9H \*9N 9 jshǀg[~竫TI)Y>ŮV\$:Kmg[>\օ/qhih\.ZPy22R0&rFƲbqF~ahF q|x[8#<xDmOAgo 0r3bf}\p "rv3FM;${ʈ Ġ \v1
g*\ǰ X T 6V!֪*ׇNFbZ [w1~'haiE=x 5jmz.j! !lŸu\,W [5i8Ttvb_I, R0/OBpZ/p (B\wFU/-D _@lac@qgQO@|y̨=E*0 7(u ~+'Xc8\W
*e 2j@3UdQ} P&Cit;A6
& BʴtU5F.:V?pU4KppQ^@ۜ%ְ
8IJ QE"h#`glmAS;rXcSғؠS6"*`*gGb^n*WPZc ; |tCU>3Y(*`0%S6cS+U3ܢ ? Lu=\̯X$70
7lO`ќJ<^ )^J}C6xc6OESCɡLs;s;n,5vW} 9gTcosUo&]A@)r-+ U okBfuM\.t+K9aT+p Qsv!s!sWơc$t4zo ȴWQƢ=sQ)Շ!"o U@
><İAݾÝ +0(≞i,H(5y9S U
del[ J,'K9@47G+_P5!\jiWnNZ#.z#2Cd 268 |A{yOXq jZz~:SpVP Vzʯ^ 7r"FR=
L~O5:\B-.tn_k`=T0 A8v>O )
kgdiҝ뙊`$ Q9 ܸ+ζ ^éR̀X+ql+z{\XQly ט@NkP AX ["ti+dJmX֪3M| 6 QD\OWÚnp8Q5~)wr젬E
j(h(
:m"qptEQjt,_]GDA_˹EZYA-Q0eT|gLNEOTu#驃X6˽z=!zq0~Ro *ڰ_@`oϪN1P庫XK8* c@e+JRs5 /a{@ȥ}Ae
1 竩\8c d>2d2 R L_ `x:t4Տ$
9*]A~Z@Sŧ ee
7pzmP6K}5 xxhvxڥ8o
& .ug+Uā
/IaHi3 9
!:c~ S[> f鱦٩r,KjQ-Q in.69yt;|!*pj(
mmPm$O'b-cd(}G/wiZ ޝ 8UyL>,'[ߏDZXO>)_ ZыEm Dݜfp5K8 `GONH}NB,cePi?"(\: q__d3P^P(؇?-ʮcĕC/_ PȬmEDs9 XQ"\(Ap2uW>N[qw
--MD\/e5>Hk!tY07 )5@&w',-RfsN}K
*4KwqۨP-8ԭT쀸`^U SaQ> c) ?QM1 jõ-<8Yȴu
S-% F߇
-U!=PM}ԯ(ѼDCUN*TRXhB~bz9Dx̬ʕ*$\Q^qz9jӞ [۸p1СZ_PrzEQ2
3+l@\w>&w O1N2!{0ҿPpC 9<5RPA_w T
n}B(x^Rr5 <|x~~
"B H{T)?S9TyJ-̩RJ+s,/A8A/. k@|B)Ė=|3N_kX
ςrN Έ_eJTq ԾW* p@ @|G&o SL)q0G1r bUղ'3] /F]$]DǺı|z%a\7%5GE aK
X}>% B l<±2rzvraÉ< \ Lqq}ՍÄ֛͇^Jq;MA=PY^7P#jo7 k}\80ɿˢ^|E_UR2Ժ@ X]ѿ8O0x8g~&~5DfjX[O/#rsgb m~vd
3U(Z&K3%^1K89P ޏM content-length already-read))
(decf content-length already-read)
(when (input-chunking-p)
;; see RFC 2616, section 4.4
(log-message* :warning "Got Content-Length header although input chunking is on."))
(let ((content (make-array content-length :element-type 'octet)))
(read-sequence content content-stream)
content))
((input-chunking-p)
(loop with buffer = (make-array +buffer-length+ :element-type 'octet)
with content = (make-array 0 :element-type 'octet :adjustable t)
for index = 0 then (+ index pos)
for pos = (read-sequence buffer content-stream)
do (adjust-array content (+ index pos))
(replace content buffer :start1 index :end2 pos)
while (= pos +buffer-length+)
finally (return content)))))))
(defmethod initialize-instance :after ((request request) &rest init-args)
"The only initarg for a REQUEST object is :HEADERS-IN. All other
slot values are computed in this :AFTER method."
(declare (ignore init-args))
(with-slots (headers-in cookies-in get-parameters script-name query-string session)
request
(handler-case*
(let* ((uri (request-uri request))
(match-start (position #\? uri))
(external-format (or (external-format-from-content-type (cdr (assoc* :content-type headers-in)))
+utf-8+)))
(cond
(match-start
(setq script-name (url-decode (subseq uri 0 match-start) external-format)
query-string (subseq uri (1+ match-start))))
(t (setq script-name (url-decode uri external-format))))
;; some clients (e.g. ASDF-INSTALL) send requests like
;; "GET http://server/foo.html HTTP/1.0"...
(setq script-name (regex-replace "^https?://[^/]+" script-name ""))
;; compute GET parameters from query string and cookies from
;; the incoming 'Cookie' header
(setq get-parameters
(let ((*substitution-char* #\?))
(form-url-encoded-list-to-alist (split "&" query-string) external-format))
cookies-in
(cookies-to-alist (split "\\s*[,;]\\s*" (cdr (assoc :cookie headers-in
:test #'eq))))
session (session-verify request)
*session* session))
(error (condition)
(log-message* :error "Error when creating REQUEST object: ~A" condition)
;; we assume it's not our fault...
(setf (return-code*) +http-bad-request+)))))
(defmethod process-request (request)
"Standard implementation for processing a request."
(catch 'request-processed ; used by HTTP HEAD handling to end request processing in a HEAD request (see START-OUTPUT)
(let (*tmp-files*
*headers-sent*
(*request* request))
(unwind-protect
(with-mapped-conditions ()
(labels
((report-error-to-client (error &optional backtrace)
(when *log-lisp-errors-p*
(log-message* *lisp-errors-log-level* "~A~@[~%~A~]" error (when *log-lisp-backtraces-p*
backtrace)))
(start-output +http-internal-server-error+
(acceptor-status-message *acceptor*
+http-internal-server-error+
:error (princ-to-string error)
:backtrace (princ-to-string backtrace)))))
(multiple-value-bind (contents error backtrace)
;; skip dispatch if bad request
(when (eql (return-code *reply*) +http-ok+)
(catch 'handler-done
(handle-request *acceptor* *request*)))
(when error
;; error occurred in request handler
(report-error-to-client error backtrace))
(unless *headers-sent*
(handler-case
(with-debugger
(start-output (return-code *reply*)
(or contents
(acceptor-status-message *acceptor*
(return-code *reply*)))))
(error (e)
;; error occurred while writing to the client. attempt to report.
(report-error-to-client e)))))))
(dolist (path *tmp-files*)
(when (and (pathnamep path) (probe-file path))
;; the handler may have chosen to (re)move the uploaded
;; file, so ignore errors that happen during deletion
(ignore-errors*
(delete-file path))))))))
(defun within-request-p ()
"True if we're in the context of a request, otherwise nil."
(and (boundp '*request*) *request*))
(defun parse-multipart-form-data (request external-format)
"Parse the REQUEST body as multipart/form-data, assuming that its
content type has already been verified. Returns the form data as
alist or NIL if there was no data or the data could not be parsed."
(handler-case*
(let ((content-stream (make-flexi-stream (content-stream request) :external-format +latin-1+)))
(prog1
(parse-rfc2388-form-data content-stream (header-in :content-type request) external-format)
(let ((stray-data (get-post-data :already-read (flexi-stream-position content-stream))))
(when (and stray-data (plusp (length stray-data)))
(hunchentoot-warn "~A octets of stray data after form-data sent by client."
(length stray-data))))))
(error (condition)
(log-message* :error "While parsing multipart/form-data parameters: ~A" condition)
nil)))
(defun maybe-read-post-parameters (&key (request *request*) force external-format)
"Make surce that any POST parameters in the REQUEST are parsed. The
body of the request must be either application/x-www-form-urlencoded
or multipart/form-data to be considered as containing POST parameters.
If FORCE is true, parsing is done unconditionally. Otherwise, parsing
will only be done if the RAW-POST-DATA slot in the REQUEST is false.
EXTERNAL-FORMAT specifies the external format of the data in the
request body. By default, the encoding is determined from the
Content-Type header of the request or from
*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* if none is found."
(when (and (header-in :content-type request)
(member (request-method request) *methods-for-post-parameters* :test #'eq)
(or force
(not (slot-value request 'raw-post-data)))
;; can't reparse multipart posts, even when FORCEd
(not (eq t (slot-value request 'raw-post-data))))
(unless (or (header-in :content-length request)
(input-chunking-p))
(log-message* :warning "Can't read request body because there's ~
no Content-Length header and input chunking is off.")
(return-from maybe-read-post-parameters nil))
(handler-case*
(multiple-value-bind (type subtype charset)
(parse-content-type (header-in :content-type request))
(let ((external-format (or external-format
(when charset
(handler-case
(make-external-format charset :eol-style :lf)
(error ()
(hunchentoot-warn "Ignoring ~
unknown character set ~A in request content type."
charset))))
*hunchentoot-default-external-format*)))
(setf (slot-value request 'post-parameters)
(cond ((and (string-equal type "application")
(string-equal subtype "x-www-form-urlencoded"))
(form-url-encoded-list-to-alist
(split "&" (raw-post-data :request request :external-format +latin-1+))
external-format))
((and (string-equal type "multipart")
(string-equal subtype "form-data"))
(prog1 (parse-multipart-form-data request external-format)
(setf (slot-value request 'raw-post-data) t)))))))
(error (condition)
(log-message* :error "Error when reading POST parameters from body: ~A" condition)
;; this is not the right thing to do because it could happen
;; that we aren't finished reading from the request stream and
;; can't send a reply - to be revisited
(setf (return-code*) +http-bad-request+
*finish-processing-socket* t)
(abort-request-handler)))))
(defun recompute-request-parameters (&key (request *request*)
(external-format *hunchentoot-default-external-format*))
"Recomputes the GET and POST parameters for the REQUEST object
REQUEST. This only makes sense if you're switching external formats
during the request."
(maybe-read-post-parameters :request request :force t :external-format external-format)
(setf (slot-value request 'get-parameters)
(form-url-encoded-list-to-alist (split "&" (query-string request)) external-format))
(values))
(defun script-name* (&optional (request *request*))
"Returns the file name of the REQUEST object REQUEST. That's the
requested URI without the query string \(i.e the GET parameters)."
(script-name request))
(defun query-string* (&optional (request *request*))
"Returns the query string of the REQUEST object REQUEST. That's
the part behind the question mark \(i.e. the GET parameters)."
(query-string request))
(defun get-parameters* (&optional (request *request*))
"Returns an alist of the GET parameters associated with the REQUEST
object REQUEST."
(get-parameters request))
(defmethod post-parameters :before ((request request))
;; Force here because if someone calls POST-PARAMETERS they actually
;; want them, regardless of why the RAW-POST-DATA has been filled
;; in. (For instance, if SEND-HEADERS has been called, filling in
;; RAW-POST-DATA, and then subsequent code calls POST-PARAMETERS,
;; without the :FORCE flag POST-PARAMETERS would return NIL.)
(maybe-read-post-parameters
:request request :force (not (slot-value request 'post-parameters))))
(defun post-parameters* (&optional (request *request*))
"Returns an alist of the POST parameters associated with the REQUEST
object REQUEST."
(post-parameters request))
(defun headers-in* (&optional (request *request*))
"Returns an alist of the incoming headers associated with the
REQUEST object REQUEST."
(headers-in request))
(defun cookies-in* (&optional (request *request*))
"Returns an alist of all cookies associated with the REQUEST object
REQUEST."
(cookies-in request))
(defgeneric header-in (name request)
(:documentation "Returns the incoming header with name NAME. NAME
can be a keyword \(recommended) or a string.")
(:method (name request)
(cdr (assoc* name (headers-in request)))))
(defun header-in* (name &optional (request *request*))
"Returns the incoming header with name NAME. NAME can be a keyword
\(recommended) or a string."
(header-in name request))
(defun authorization (&optional (request *request*))
"Returns as two values the user and password \(if any) as encoded in
the 'AUTHORIZATION' header. Returns NIL if there is no such header."
(let* ((authorization (header-in :authorization request))
(start (and authorization
(> (length authorization) 5)
(string-equal "Basic" authorization :end2 5)
(scan "\\S" authorization :start 5))))
(when start
(destructuring-bind (&optional user password)
(split ":" (base64:base64-string-to-string (subseq authorization start)) :limit 2)
(values user password)))))
(defun remote-addr* (&optional (request *request*))
"Returns the address the current request originated from."
(remote-addr request))
(defun remote-port* (&optional (request *request*))
"Returns the port the current request originated from."
(remote-port request))
(defun local-addr* (&optional (request *request*))
"Returns the address the current request connected to."
(local-addr request))
(defun local-port* (&optional (request *request*))
"Returns the port the current request connected to."
(local-port request))
(defun real-remote-addr (&optional (request *request*))
"Returns the 'X-Forwarded-For' incoming http header as the
second value in the form of a list of IP addresses and the first
element of this list as the first value if this header exists.
Otherwise returns the value of REMOTE-ADDR as the only value."
(let ((x-forwarded-for (header-in :x-forwarded-for request)))
(cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for)))
(values (first addresses) addresses)))
(t (remote-addr request)))))
(defun host (&optional (request *request*))
"Returns the 'Host' incoming http header value."
(header-in :host request))
(defun request-uri* (&optional (request *request*))
"Returns the request URI."
(request-uri request))
(defun request-method* (&optional (request *request*))
"Returns the request method as a Lisp keyword."
(request-method request))
(defun server-protocol* (&optional (request *request*))
"Returns the request protocol as a Lisp keyword."
(server-protocol request))
(defun user-agent (&optional (request *request*))
"Returns the 'User-Agent' http header."
(header-in :user-agent request))
(defun cookie-in (name &optional (request *request*))
"Returns the cookie with the name NAME \(a string) as sent by the
browser - or NIL if there is none."
(cdr (assoc name (cookies-in request) :test #'string=)))
(defun referer (&optional (request *request*))
"Returns the 'Referer' \(sic!) http header."
(header-in :referer request))
(defun get-parameter (name &optional (request *request*))
"Returns the GET parameter with name NAME \(a string) - or NIL if
there is none. Search is case-sensitive."
(cdr (assoc name (get-parameters request) :test #'string=)))
(defun post-parameter (name &optional (request *request*))
"Returns the POST parameter with name NAME \(a string) - or NIL if
there is none. Search is case-sensitive."
(cdr (assoc name (post-parameters request) :test #'string=)))
(defun parameter (name &optional (request *request*))
"Returns the GET or the POST parameter with name NAME \(a string) -
or NIL if there is none. If both a GET and a POST parameter with the
same name exist the GET parameter is returned. Search is
case-sensitive."
(or (get-parameter name request)
(post-parameter name request)))
(defun handle-if-modified-since (time &optional (request *request*))
"Handles the 'If-Modified-Since' header of REQUEST. The date string
is compared to the one generated from the supplied universal time
TIME."
(let ((if-modified-since (header-in :if-modified-since request))
(time-string (rfc-1123-date time)))
;; simple string comparison is sufficient; see RFC 2616 14.25
(when (and if-modified-since
(equal if-modified-since time-string))
(setf (slot-value *reply* 'content-length) nil
(slot-value *reply* 'headers-out) (remove :content-length (headers-out*) :key #'car)
(return-code*) +http-not-modified+)
(abort-request-handler))
(values)))
(defun external-format-from-content-type (content-type)
"Creates and returns an external format corresponding to the value
of the content type header provided in CONTENT-TYPE. If the content
type was not set or if the character set specified was invalid, NIL is
returned."
(when content-type
(when-let (charset (nth-value 2 (parse-content-type content-type)))
(handler-case
(make-external-format (as-keyword charset) :eol-style :lf)
(error ()
(hunchentoot-warn "Invalid character set ~S in request has been ignored."
charset))))))
(defun raw-post-data (&key (request *request*) external-format force-text force-binary want-stream)
"Returns the content sent by the client if there was any \(unless
the content type was \"multipart/form-data\"). By default, the result
is a string if the type of the `Content-Type' media type is \"text\",
and a vector of octets otherwise. In the case of a string, the
external format to be used to decode the content will be determined
from the `charset' parameter sent by the client \(or otherwise
*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used).
You can also provide an external format explicitly \(through
EXTERNAL-FORMAT) in which case the result will unconditionally be a
string. Likewise, you can provide a true value for FORCE-TEXT which
will force Hunchentoot to act as if the type of the media type had
been \"text\". Or you can provide a true value for FORCE-BINARY which
means that you want a vector of octets at any rate.
If, however, you provide a true value for WANT-STREAM, the other
parameters are ignored and you'll get the content \(flexi) stream to
read from it yourself. It is then your responsibility to read the
correct amount of data, because otherwise you won't be able to return
a response to the client. If the content type of the request was
`multipart/form-data' or `application/x-www-form-urlencoded', the
content has been read by Hunchentoot already and you can't read from
the stream anymore.
You can call RAW-POST-DATA more than once per request, but you can't
mix calls which have different values for WANT-STREAM.
Note that this function is slightly misnamed because a client can send
content even if the request method is not POST."
(when (and force-binary force-text)
(parameter-error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value."))
(unless (or external-format force-binary)
(setq external-format (or (external-format-from-content-type (header-in :content-type request))
(when force-text
*hunchentoot-default-external-format*))))
(let ((raw-post-data (or (slot-value request 'raw-post-data)
(get-post-data :request request :want-stream want-stream))))
(cond ((typep raw-post-data 'stream) raw-post-data)
((member raw-post-data '(t nil)) nil)
(external-format (octets-to-string raw-post-data :external-format external-format))
(t raw-post-data))))
(defun aux-request-value (symbol &optional (request *request*))
"Returns the value associated with SYMBOL from the request object
REQUEST \(the default is the current request) if it exists. The
second return value is true if such a value was found."
(when request
(let ((found (assoc symbol (aux-data request) :test #'eq)))
(values (cdr found) found))))
(defsetf aux-request-value (symbol &optional request)
(new-value)
"Sets the value associated with SYMBOL from the request object
REQUEST \(default is *REQUEST*). If there is already a value
associated with SYMBOL it will be replaced."
(with-rebinding (symbol)
(with-unique-names (place %request)
`(let* ((,%request (or ,request *request*))
(,place (assoc ,symbol (aux-data ,%request) :test #'eq)))
(cond
(,place
(setf (cdr ,place) ,new-value))
(t
(push (cons ,symbol ,new-value)
(aux-data ,%request))
,new-value))))))
(defun delete-aux-request-value (symbol &optional (request *request*))
"Removes the value associated with SYMBOL from the request object
REQUEST."
(when request
(setf (aux-data request)
(delete symbol (aux-data request)
:key #'car :test #'eq)))
(values))
(defun parse-path (path)
"Return a relative pathname that has been verified to not contain
any directory traversals or explicit device or host fields. Returns
NIL if the path is not acceptable."
(when (every #'graphic-char-p path)
(let* ((pathname (#+sbcl sb-ext:parse-native-namestring
#+ccl ccl:native-to-pathname
;; Just disallow anything with :wild components later.
#-(or ccl sbcl) parse-namestring
(remove #\\ (regex-replace "^/*" path ""))))
(directory (pathname-directory pathname)))
(when (and (or (null (pathname-host pathname))
(equal (pathname-host pathname)
(pathname-host *default-pathname-defaults*)))
(or (null (pathname-device pathname))
(equal (pathname-device pathname)
(pathname-device *default-pathname-defaults*)))
(or (null directory)
(and (eql (first directory) :relative)
;; only string components, no :UP traversals or :WILD
(every #'stringp (rest directory))))
#-(or sbcl ccl) ;; parse-native-namestring should handle this
(and
(typep (pathname-name pathname) '(or null string)) ; no :WILD
(typep (pathname-type pathname) '(or null string)))
(not (equal (file-namestring pathname) "..")))
pathname))))
(defun request-pathname (&optional (request *request*) drop-prefix)
"Construct a relative pathname from the request's SCRIPT-NAME.
If DROP-PREFIX is given, pathname construction starts at the first path
segment after the prefix.
"
(let ((path (script-name request)))
(if drop-prefix
(when (starts-with-p path drop-prefix)
(parse-path (subseq path (length drop-prefix))))
(parse-path path))))
hunchentoot-v1.2.38/release-checklist.txt 0000644 0000000 0000000 00000000236 13211004253 017147 0 ustar root root What do do for a release:
Update version number in hunchentoot.asd and doc/index.xml
Update CHANGELOG (keep format)
Create html documentation (cd doc; make)
hunchentoot-v1.2.38/compat.lisp 0000644 0000000 0000000 00000013473 13211004253 015202 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defmacro when-let ((var form) &body body)
"Evaluates FORM and binds VAR to the result, then executes BODY
if VAR has a true value."
`(let ((,var ,form))
(when ,var ,@body)))
(defmacro with-unique-names ((&rest bindings) &body body)
"Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
Executes a series of forms with each VAR bound to a fresh,
uninterned symbol. The uninterned symbol is as if returned by a call
to GENSYM with the string denoted by X - or, if X is not supplied, the
string denoted by VAR - as argument.
The variable bindings created are lexical unless special declarations
are specified. The scopes of the name bindings and declarations do not
include the Xs.
The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
;; reference implementation posted to comp.lang.lisp as
;; by Vebjorn Ljosa - see also
;;
`(let ,(mapcar #'(lambda (binding)
(check-type binding (or cons symbol))
(if (consp binding)
(destructuring-bind (var x) binding
(check-type var symbol)
`(,var (gensym ,(etypecase x
(symbol (symbol-name x))
(character (string x))
(string x)))))
`(,binding (gensym ,(symbol-name binding)))))
bindings)
,@body))
(defmacro with-rebinding (bindings &body body)
"Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form*
Evaluates a series of forms in the lexical environment that is
formed by adding the binding of each VAR to a fresh, uninterned
symbol, and the binding of that fresh, uninterned symbol to VAR's
original value, i.e., its value in the current lexical environment.
The uninterned symbol is created as if by a call to GENSYM with the
string denoted by PREFIX - or, if PREFIX is not supplied, the string
denoted by VAR - as argument.
The forms are evaluated in order, and the values of all but the last
are discarded \(that is, the body is an implicit PROGN)."
;; reference implementation posted to comp.lang.lisp as
;; by Vebjorn Ljosa - see also
;;
(loop for binding in bindings
for var = (if (consp binding) (car binding) binding)
for name = (gensym)
collect `(,name ,var) into renames
collect ``(,,var ,,name) into temps
finally (return `(let ,renames
(with-unique-names ,bindings
`(let (,,@temps)
,,@body))))))
(defun get-peer-address-and-port (socket)
"Returns the peer address and port of the socket SOCKET as two
values. The address is returned as a string in dotted IP address
notation."
(multiple-value-bind (address port) (usocket:get-peer-name socket)
(values (ecase (length address)
(4 (usocket:vector-quad-to-dotted-quad address))
#+(or) (16 (usocket:vector-to-ipv6-host address)))
port)))
(defun get-local-address-and-port (socket)
"Returns the local address and port of the socket SOCKET as two
values. The address is returned as a string in dotted IP address
notation."
(multiple-value-bind (address port) (usocket:get-local-name socket)
(values (ecase (length address)
(4 (usocket:vector-quad-to-dotted-quad address))
#+(or) (16 (usocket:vector-to-ipv6-host address)))
port)))
(defun make-socket-stream (socket acceptor)
"Returns a stream for the socket SOCKET. The ACCEPTOR argument is
ignored."
(declare (ignore acceptor))
(usocket:socket-stream socket))
(defun make-lock (name)
"Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
(bt:make-lock name))
(defmacro with-lock-held ((lock) &body body)
"Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
`(bt:with-lock-held (,lock) ,@body))
(defun make-condition-variable (&key name)
(declare (ignore name))
(bt:make-condition-variable))
(defun condition-variable-signal (condition-variable)
(bt:condition-notify condition-variable))
(defun condition-variable-wait (condition-variable lock)
(bt:condition-wait condition-variable lock))
hunchentoot-v1.2.38/README 0000644 0000000 0000000 00000000254 13211004253 013677 0 ustar root root Complete documentation for Hunchentoot including details about how to
install it can be found in the 'doc' directory.
Join the chat at https://gitter.im/edicl/hunchentoot
hunchentoot-v1.2.38/ssl.lisp 0000644 0000000 0000000 00000013467 13211004253 014523 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defclass ssl-acceptor (acceptor)
((ssl-certificate-file :initarg :ssl-certificate-file
:reader acceptor-ssl-certificate-file
:documentation "A pathname designator for a
certificate file in PEM format.")
(ssl-privatekey-file :initarg :ssl-privatekey-file
:reader acceptor-ssl-privatekey-file
:documentation "A pathname designator for a
private key file in PEM format, or \(only on LispWorks) NIL if the
certificate file contains the private key.")
(ssl-privatekey-password :initform nil
:initarg :ssl-privatekey-password
:reader acceptor-ssl-privatekey-password
:documentation "The password for the
private key file or NIL for no password."))
(:default-initargs
:port 443)
(:documentation "Create and START an instance of this class
\(instead of ACCEPTOR) if you want an https server. There are two
required initargs, :SSL-CERTIFICATE-FILE and :SSL-PRIVATEKEY-FILE, for
pathname designators denoting the certificate file and the key file in
PEM format. On LispWorks, you can have both in one file in which case
the second initarg is optional. You can also use the
:SSL-PRIVATEKEY-PASSWORD initarg to provide a password \(as a string)
for the key file \(or NIL, the default, for no password).
The default port for SSL-ACCEPTOR instances is 443 instead of 80"))
;; general implementation
(defmethod acceptor-ssl-p ((acceptor ssl-acceptor))
t)
(defmethod initialize-instance :after ((acceptor ssl-acceptor) &rest initargs)
(declare (ignore initargs))
;; LispWorks can read both from the same file, so we can default one
#+:lispworks
(unless (slot-boundp acceptor 'ssl-privatekey-file)
(setf (slot-value acceptor 'ssl-privatekey-file)
(acceptor-ssl-certificate-file acceptor)))
;; OpenSSL doesn't know much about Lisp pathnames...
(setf (slot-value acceptor 'ssl-privatekey-file)
(namestring (truename (acceptor-ssl-privatekey-file acceptor)))
(slot-value acceptor 'ssl-certificate-file)
(namestring (truename (acceptor-ssl-certificate-file acceptor)))))
;; usocket implementation
#-:lispworks
(defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream)
;; attach SSL to the stream if necessary
(call-next-method acceptor
(cl+ssl:make-ssl-server-stream stream
:certificate (acceptor-ssl-certificate-file acceptor)
:key (acceptor-ssl-privatekey-file acceptor)
:password (acceptor-ssl-privatekey-password acceptor))))
;; LispWorks implementation
#+:lispworks
(defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password)
"Given the acceptor socket stream SOCKET-STREAM attaches SSL to the
stream using the certificate file CERTIFICATE-FILE and the private key
file PRIVATEKEY-FILE. Both of these values must be namestrings
denoting the location of the files and will be fed directly to
OpenSSL. If PRIVATEKEY-PASSWORD is not NIL then it should be the
password for the private key file \(if necessary). Returns the
stream."
(flet ((ctx-configure-callback (ctx)
(when privatekey-password
(comm:set-ssl-ctx-password-callback ctx :password privatekey-password))
(comm:ssl-ctx-use-certificate-file ctx
certificate-file
comm:ssl_filetype_pem)
(comm:ssl-ctx-use-privatekey-file ctx
privatekey-file
comm:ssl_filetype_pem)))
(comm:attach-ssl socket-stream
:ctx-configure-callback #'ctx-configure-callback)
socket-stream))
#+:lispworks
(defmethod initialize-connection-stream ((acceptor ssl-acceptor) stream)
;; attach SSL to the stream if necessary
(call-next-method acceptor
(make-ssl-server-stream stream
:certificate-file (acceptor-ssl-certificate-file acceptor)
:privatekey-file (acceptor-ssl-privatekey-file acceptor)
:privatekey-password (acceptor-ssl-privatekey-password acceptor))))
hunchentoot-v1.2.38/specials.lisp 0000644 0000000 0000000 00000032607 13211004253 015522 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defmacro defconstant (name value &optional doc)
"Make sure VALUE is evaluated only once \(to appease SBCL)."
`(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when doc (list doc))))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defmacro defvar-unbound (name &optional (doc-string ""))
"Convenience macro to declare unbound special variables with a
documentation string."
`(progn
(defvar ,name)
(setf (documentation ',name 'variable) ,doc-string)
',name))
(defvar *http-reason-phrase-map* (make-hash-table)
"Used to map numerical return codes to reason phrases.")
(defmacro def-http-return-code (name value reason-phrase)
"Shortcut to define constants for return codes. NAME is a
Lisp symbol, VALUE is the numerical value of the return code, and
REASON-PHRASE is the phrase \(a string) to be shown in the
server's status line."
`(eval-when (:compile-toplevel :execute :load-toplevel)
(defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'."
value reason-phrase))
(setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase))))
(defconstant +crlf+
(make-array 2 :element-type '(unsigned-byte 8)
:initial-contents (mapcar 'char-code '(#\Return #\Linefeed)))
"A 2-element array consisting of the character codes for a CRLF
sequence.")
(def-http-return-code +http-continue+ 100 "Continue")
(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols")
(def-http-return-code +http-ok+ 200 "OK")
(def-http-return-code +http-created+ 201 "Created")
(def-http-return-code +http-accepted+ 202 "Accepted")
(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information")
(def-http-return-code +http-no-content+ 204 "No Content")
(def-http-return-code +http-reset-content+ 205 "Reset Content")
(def-http-return-code +http-partial-content+ 206 "Partial Content")
(def-http-return-code +http-multi-status+ 207 "Multi-Status")
(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices")
(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently")
(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily")
(def-http-return-code +http-see-other+ 303 "See Other")
(def-http-return-code +http-not-modified+ 304 "Not Modified")
(def-http-return-code +http-use-proxy+ 305 "Use Proxy")
(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect")
(def-http-return-code +http-bad-request+ 400 "Bad Request")
(def-http-return-code +http-authorization-required+ 401 "Authorization Required")
(def-http-return-code +http-payment-required+ 402 "Payment Required")
(def-http-return-code +http-forbidden+ 403 "Forbidden")
(def-http-return-code +http-not-found+ 404 "Not Found")
(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed")
(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable")
(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required")
(def-http-return-code +http-request-time-out+ 408 "Request Time-out")
(def-http-return-code +http-conflict+ 409 "Conflict")
(def-http-return-code +http-gone+ 410 "Gone")
(def-http-return-code +http-length-required+ 411 "Length Required")
(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed")
(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large")
(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large")
(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type")
(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable")
(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed")
(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency")
(def-http-return-code +http-precondition-required+ 428 "Precondition Required")
(def-http-return-code +http-too-many-requests+ 429 "Too Many Requests")
(def-http-return-code +http-request-header-fields-too-large+ 431 "Request Header Fields Too Large")
(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error")
(def-http-return-code +http-not-implemented+ 501 "Not Implemented")
(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway")
(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable")
(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out")
(def-http-return-code +http-version-not-supported+ 505 "Version not supported")
(def-http-return-code +http-network-authentication-required+ 511 "Network Authentication Required")
(defconstant +day-names+
#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
"The three-character names of the seven days of the week - needed
for cookie date format.")
(defconstant +month-names+
#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
"The three-character names of the twelve months - needed for cookie
date format.")
(defvar *rewrite-for-session-urls* t
"Whether HTML pages should possibly be rewritten for cookie-less
session-management.")
(defvar *content-types-for-url-rewrite*
'("text/html" "application/xhtml+xml")
"The content types for which url-rewriting is OK. See
*REWRITE-FOR-SESSION-URLS*.")
(defvar *the-random-state* (make-random-state t)
"A fresh random state.")
(defvar-unbound *session-secret*
"A random ASCII string that's used to encode the public session
data. This variable is initially unbound and will be set \(using
RESET-SESSION-SECRET) the first time a session is created, if
necessary. You can prevent this from happening if you set the value
yourself before starting acceptors.")
(defvar-unbound *hunchentoot-stream*
"The stream representing the socket Hunchentoot is listening on.")
(defvar-unbound *finish-processing-socket*
"Will be set to T if PROCESS-CONNECTION is to stop processing more
requests on the current socket connection.")
(defvar-unbound *close-hunchentoot-stream*
"This variable is set to NIL during the processing of a handler to
tell the acceptor not to close the connection after it is done.")
(defvar *headers-sent* nil
"Used internally to check whether the reply headers have
already been sent for this request.")
(defvar *file-upload-hook* nil
"If this is not NIL, it should be a unary function which will
be called with a pathname for each file which is uploaded to
Hunchentoot. The pathname denotes the temporary file to which
the uploaded file is written. The hook is called directly before
the file is created.")
(defvar *session-db* nil
"The default \(global) session database.")
(defvar *session-max-time* #.(* 30 60)
"The default time \(in seconds) after which a session times out.")
(defvar *session-gc-frequency* 50
"A session GC \(see function SESSION-GC) will happen every
*SESSION-GC-FREQUENCY* requests \(counting only requests which create
a new session) if this variable is not NIL. See SESSION-CREATED.")
(defvar *use-user-agent-for-sessions* t
"Whether the 'User-Agent' header should be encoded into the session
string. If this value is true, a session will cease to be accessible
if the client sends a different 'User-Agent' header.")
(defvar *use-remote-addr-for-sessions* nil
"Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR)
should be encoded into the session string. If this value is true, a
session will cease to be accessible if the client's remote IP changes.
This might for example be an issue if the client uses a proxy server
which doesn't send correct 'X_FORWARDED_FOR' headers.")
(defvar *default-content-type* "text/html"
"The default content-type header which is returned to the client.
If this is text content type, the character set used for encoding the
response will automatically be added to the content type in a
``charset'' attribute.")
(defvar *methods-for-post-parameters* '(:post)
"A list of the request method types \(as keywords) for which
Hunchentoot will try to compute POST-PARAMETERS.")
(defvar *header-stream* nil
"If this variable is not NIL, it should be bound to a stream to
which incoming and outgoing headers will be written for debugging
purposes.")
(defvar *show-lisp-errors-p* nil
"Whether Lisp errors in request handlers should be shown in HTML output.")
(defvar *show-lisp-backtraces-p* t
"Whether Lisp errors shown in HTML output should contain backtrace information.")
(defvar *log-lisp-errors-p* t
"Whether Lisp errors in request handlers should be logged.")
(defvar *log-lisp-backtraces-p* t
"Whether Lisp backtraces should be logged. Only has an effect if
*LOG-LISP-ERRORS-P* is true as well.")
(defvar *log-lisp-warnings-p* t
"Whether Lisp warnings in request handlers should be logged.")
(defvar *lisp-errors-log-level* :error
"Log level for Lisp errors. Should be one of :ERROR \(the default),
:WARNING, or :INFO.")
(defvar *lisp-warnings-log-level* :warning
"Log level for Lisp warnings. Should be one of :ERROR, :WARNING
\(the default), or :INFO.")
(defvar *message-log-lock* (make-lock "global-message-log-lock")
"A global lock to prevent concurrent access to the log file used by
the ACCEPTOR-LOG-MESSAGE function.")
(defvar *access-log-lock* (make-lock "global-access-log-lock")
"A global lock to prevent concurrent access to the log file used by
the ACCEPTOR-LOG-ACCESS function.")
(defvar *catch-errors-p* t
"Whether Hunchentoot should catch and log errors \(or rather invoke
the debugger).")
(defvar-unbound *acceptor*
"The current ACCEPTOR object while in the context of a request.")
(defvar-unbound *request*
"The current REQUEST object while in the context of a request.")
(defvar-unbound *reply*
"The current REPLY object while in the context of a request.")
(defvar-unbound *session*
"The current session while in the context of a request, or NIL.")
(defconstant +implementation-link+
#+:cmu "http://www.cons.org/cmucl/"
#+:sbcl "http://www.sbcl.org/"
#+:allegro "http://www.franz.com/products/allegrocl/"
#+:lispworks "http://www.lispworks.com/"
#+:openmcl "http://openmcl.clozure.com/"
"A link to the website of the underlying Lisp implementation.")
(defvar *tmp-directory*
#+(or :win32 :mswindows) "c:\\hunchentoot-temp\\"
#-(or :win32 :mswindows) "/tmp/hunchentoot/"
"Directory for temporary files created by MAKE-TMP-FILE-NAME.")
(defvar *tmp-files* nil
"A list of temporary files created while a request was handled.")
(defconstant +latin-1+
(make-external-format :latin1 :eol-style :lf)
"A FLEXI-STREAMS external format used for `faithful' input and
output of binary data.")
(defconstant +utf-8+
(make-external-format :utf8 :eol-style :lf)
"A FLEXI-STREAMS external format used internally for logging and to
encode cookie values.")
(defvar *hunchentoot-default-external-format* +utf-8+
"The external format used to compute the REQUEST object.")
(defconstant +buffer-length+ 8192
"Length of buffers used for internal purposes.")
(defvar *default-connection-timeout* 20
"The default connection timeout used when an acceptor is reading
from and writing to a socket stream.")
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-symbol-macro *supports-threads-p*
#+:lispworks t
#-:lispworks bt:*supports-threads-p*))
(defvar *global-session-db-lock*
(load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock")))
"A global lock to prevent two threads from modifying *session-db* at
the same time \(or NIL for Lisps which don't have threads).")
(pushnew :hunchentoot *features*)
;; stuff for Nikodemus Siivola's HYPERDOC
;; see
;; and
(defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/")
(let ((exported-symbols-alist
(loop for symbol being the external-symbols of :hunchentoot
collect (cons symbol (concatenate 'string "#" (string-downcase symbol))))))
(defun hyperdoc-lookup (symbol type)
(declare (ignore type))
(cdr (assoc symbol exported-symbols-alist :test #'eq))))
(defparameter hunchentoot:*hunchentoot-version* #.(asdf:component-version (asdf:find-system :hunchentoot)))
hunchentoot-v1.2.38/session.lisp 0000644 0000000 0000000 00000041116 13211004253 015375 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defgeneric session-db-lock (acceptor &key whole-db-p)
(:documentation "A function which returns a lock that will be used
to prevent concurrent access to sessions. The first argument will be
the acceptor that handles the current request, the second argument is
true if the whole \(current) session database is modified. If it is
NIL, only one existing session in the database is modified.
This function can return NIL which means that sessions or session
databases will be modified without a lock held \(for example for
single-threaded environments). The default is to always return a
global lock \(ignoring the ACCEPTOR argument) for Lisps that support
threads and NIL otherwise."))
(defmethod session-db-lock ((acceptor t) &key (whole-db-p t))
(declare (ignore whole-db-p))
*global-session-db-lock*)
(defmacro with-session-lock-held ((lock) &body body)
"This is like WITH-LOCK-HELD except that it will accept NIL as a
\"lock\" and just execute BODY in this case."
(with-unique-names (thunk)
(with-rebinding (lock)
`(flet ((,thunk () ,@body))
(cond (,lock (with-lock-held (,lock) (,thunk)))
(t (,thunk)))))))
(defgeneric session-db (acceptor)
(:documentation "Returns the current session database which is an
alist where each car is a session's ID and the cdr is the
corresponding SESSION object itself. The default is to use a global
list for all acceptors."))
(defmethod session-db ((acceptor t))
*session-db*)
(defgeneric (setf session-db) (new-value acceptor)
(:documentation "Modifies the current session database. See SESSION-DB."))
(defmethod (setf session-db) (new-value (acceptor t))
(setq *session-db* new-value))
(defgeneric next-session-id (acceptor)
(:documentation "Returns the next sequential session ID, an integer,
which should be unique per session. The default method uses a simple
global counter and isn't guarded by a lock. For a high-performance
production environment you might consider using a more robust
implementation."))
(let ((session-id-counter 0))
(defmethod next-session-id ((acceptor t))
(incf session-id-counter)))
(defclass session ()
((session-id :initform (next-session-id (request-acceptor *request*))
:reader session-id
:type integer
:documentation "The unique ID \(an INTEGER) of the session.")
(session-string :reader session-string
:documentation "The session string encodes enough
data to safely retrieve this session. It is sent to the browser as a
cookie value or as a GET parameter.")
(user-agent :initform (user-agent *request*)
:reader session-user-agent
:documentation "The incoming 'User-Agent' header that
was sent when this session was created.")
(remote-addr :initform (real-remote-addr *request*)
:reader session-remote-addr
:documentation "The remote IP address of the client
when this session was started as returned by REAL-REMOTE-ADDR.")
(session-start :initform (get-universal-time)
:reader session-start
:documentation "The time this session was started.")
(last-click :initform (get-universal-time)
:reader session-last-click
:documentation "The last time this session was used.")
(session-data :initarg :session-data
:initform nil
:reader session-data
:documentation "Data associated with this session -
see SESSION-VALUE.")
(max-time :initarg :max-time
:initform *session-max-time*
:accessor session-max-time
:type fixnum
:documentation "The time \(in seconds) after which this
session expires if it's not used."))
(:documentation "SESSION objects are automatically maintained by
Hunchentoot. They should not be created explicitly with MAKE-INSTANCE
but implicitly with START-SESSION and they should be treated as opaque
objects.
You can ignore Hunchentoot's SESSION objects altogether and implement
your own sessions if you provide corresponding methods for
SESSION-COOKIE-VALUE and SESSION-VERIFY."))
(defun encode-session-string (id user-agent remote-addr start)
"Creates a uniquely encoded session string based on the values ID,
USER-AGENT, REMOTE-ADDR, and START"
(unless (boundp '*session-secret*)
(hunchentoot-warn "Session secret is unbound. Using Lisp's RANDOM function to initialize it.")
(reset-session-secret))
;; *SESSION-SECRET* is used twice due to known theoretical
;; vulnerabilities of MD5 encoding
(md5-hex (concatenate 'string
*session-secret*
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
*session-secret*
id
(and *use-user-agent-for-sessions*
user-agent)
(and *use-remote-addr-for-sessions*
remote-addr)
start)))))
(defun stringify-session (session)
"Creates a string representing the SESSION object SESSION. See
ENCODE-SESSION-STRING."
(encode-session-string (session-id session)
(session-user-agent session)
(session-remote-addr session)
(session-start session)))
(defmethod initialize-instance :after ((session session) &rest init-args)
"Set SESSION-STRING slot after the session has been initialized."
(declare (ignore init-args))
(setf (slot-value session 'session-string) (stringify-session session)))
(defun session-gc ()
"Removes sessions from the current session database which are too
old - see SESSION-TOO-OLD-P."
(with-session-lock-held ((session-db-lock *acceptor*))
(setf (session-db *acceptor*)
(loop for id-session-pair in (session-db *acceptor*)
for (nil . session) = id-session-pair
when (session-too-old-p session)
do (acceptor-remove-session *acceptor* session)
else
collect id-session-pair)))
(values))
(defun session-value (symbol &optional (session *session*))
"Returns the value associated with SYMBOL from the session object
SESSION \(the default is the current session) if it exists."
(when session
(let ((found (assoc symbol (session-data session) :test #'eq)))
(values (cdr found) found))))
(defsetf session-value (symbol &optional session)
(new-value)
"Sets the value associated with SYMBOL from the session object
SESSION. If there is already a value associated with SYMBOL it will be
replaced. Will automatically start a session if none was supplied and
there's no session for the current request."
(with-rebinding (symbol)
(with-unique-names (place %session)
`(let ((,%session (or ,session (start-session))))
(with-session-lock-held ((session-db-lock *acceptor* :whole-db-p nil))
(let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq)))
(cond
(,place
(setf (cdr ,place) ,new-value))
(t
(push (cons ,symbol ,new-value)
(slot-value ,%session 'session-data))
,new-value))))))))
(defun delete-session-value (symbol &optional (session *session*))
"Removes the value associated with SYMBOL from SESSION if there is
one."
(when session
(setf (slot-value session 'session-data)
(delete symbol (session-data session)
:key #'car :test #'eq)))
(values))
(defgeneric session-cookie-value (session)
(:documentation "Returns a string which can be used to safely
restore the session SESSION if as session has already been
established. This is used as the value stored in the session cookie
or in the corresponding GET parameter and verified by SESSION-VERIFY.
A default method is provided and there's no reason to change it unless
you want to use your own session objects."))
(defmethod session-cookie-value ((session session))
(and session
(format nil
"~D:~A"
(session-id session)
(session-string session))))
(defgeneric session-cookie-name (acceptor)
(:documentation "Returns the name \(a string) of the cookie \(or the
GET parameter) which is used to store a session on the client side.
The default is to use the string \"hunchentoot-session\", but you can
specialize this function if you want another name."))
(defmethod session-cookie-name ((acceptor t))
"hunchentoot-session")
(defgeneric session-created (acceptor new-session)
(:documentation "This function is called whenever a new session has
been created. There's a default method which might trigger a session
GC based on the value of *SESSION-GC-FREQUENCY*.
The return value is ignored."))
(let ((global-session-usage-counter 0))
(defmethod session-created ((acceptor t) (session t))
"Counts session usage globally and triggers session GC if
necessary."
(when (and *session-gc-frequency*
(zerop (mod (incf global-session-usage-counter)
*session-gc-frequency*)))
(session-gc))))
(defun start-session ()
"Returns the current SESSION object. If there is no current session,
creates one and updates the corresponding data structures. In this
case the function will also send a session cookie to the browser."
(let ((session (session *request*)))
(when session
(return-from start-session session))
(setf session (make-instance 'session)
(session *request*) session)
(with-session-lock-held ((session-db-lock *acceptor*))
(setf (session-db *acceptor*)
(acons (session-id session) session (session-db *acceptor*))))
(set-cookie (session-cookie-name *acceptor*)
:value (session-cookie-value session)
:path "/"
:http-only t)
(session-created *acceptor* session)
(setq *session* session)))
(defun remove-session (session)
"Completely removes the SESSION object SESSION from Hunchentoot's
internal session database."
(set-cookie (session-cookie-name *acceptor*)
:value "deleted"
:path "/"
:expires 0)
(with-session-lock-held ((session-db-lock *acceptor*))
(acceptor-remove-session *acceptor* session)
(setf (session-db *acceptor*)
(delete (session-id session) (session-db *acceptor*)
:key #'car :test #'=)))
(values))
(defun session-too-old-p (session)
"Returns true if the SESSION object SESSION has not been active in
the last \(SESSION-MAX-TIME SESSION) seconds."
(< (+ (session-last-click session) (session-max-time session))
(get-universal-time)))
(defun get-stored-session (id)
"Returns the SESSION object corresponding to the number ID if the
session has not expired. Will remove the session if it has expired but
will not create a new one."
(let ((session
(cdr (assoc id (session-db *acceptor*) :test #'=))))
(when (and session
(session-too-old-p session))
(when *reply*
(log-message* :info "Session with ID ~A too old" id))
(remove-session session)
(setq session nil))
session))
(defun regenerate-session-cookie-value (session)
"Regenerates the cookie value. This should be used
when a user logs in according to the application to prevent against
session fixation attacks. The cookie value being dependent on ID,
USER-AGENT, REMOTE-ADDR, START, and *SESSION-SECRET*, the only value
we can change is START to regenerate a new value. Since we're
generating a new cookie, it makes sense to have the session being
restarted, in time. That said, because of this fact, calling this
function twice in the same second will regenerate twice the same value."
(setf (slot-value session 'session-start) (get-universal-time)
(slot-value session 'session-string) (stringify-session session))
(set-cookie (session-cookie-name *acceptor*)
:value (session-cookie-value session)
:path "/"
:http-only t))
(defgeneric session-verify (request)
(:documentation "Tries to get a session identifier from the cookies
\(or alternatively from the GET parameters) sent by the client (see
SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE). This identifier is
then checked for validity against the REQUEST object REQUEST. On
success the corresponding session object \(if not too old) is returned
\(and updated). Otherwise NIL is returned.
A default method is provided and you only need to write your own one
if you want to maintain your own sessions."))
(defmethod session-verify ((request request))
(let ((session-identifier (or (when-let (session-cookie (cookie-in (session-cookie-name *acceptor*) request))
(url-decode session-cookie))
(get-parameter (session-cookie-name *acceptor*) request))))
(when (and (stringp session-identifier)
(scan "^\\d+:.+" session-identifier))
(destructuring-bind (id-string session-string)
(split ":" session-identifier :limit 2)
(let* ((id (parse-integer id-string))
(session (get-stored-session id))
(user-agent (user-agent request))
(remote-addr (remote-addr request)))
(cond
((and session
(string= session-string
(session-string session))
(string= session-string
(encode-session-string id
user-agent
(real-remote-addr request)
(session-start session))))
;; the session key presented by the client is valid
(setf (slot-value session 'last-click) (get-universal-time))
session)
(session
;; the session ID pointed to an existing session, but the
;; session string did not match the expected session string
(log-message* :warning
"Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
session-identifier user-agent remote-addr)
;; remove the session to make sure that it can't be used
;; again; the original legitimate user will be required to
;; log in again
(remove-session session)
nil)
(t
;; no session was found under the ID given, presumably
;; because it has expired.
(log-message* :info
"No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
session-identifier user-agent remote-addr)
nil)))))))
(defun reset-session-secret ()
"Sets *SESSION-SECRET* to a new random value. All old sessions will
cease to be valid."
(setq *session-secret* (create-random-string 10 36)))
(defun reset-sessions (&optional (acceptor *acceptor*))
"Removes ALL stored sessions of ACCEPTOR."
(with-session-lock-held ((session-db-lock acceptor))
(loop for (nil . session) in (session-db acceptor)
do (acceptor-remove-session acceptor session))
(setq *session-db* nil))
(values))
hunchentoot-v1.2.38/easy-handlers.lisp 0000644 0000000 0000000 00000040273 13211004253 016454 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defvar *dispatch-table* (list 'dispatch-easy-handlers)
"A global list of dispatch functions.")
(defvar *easy-handler-alist* nil
"An alist of \(URI acceptor-names function) lists defined by
DEFINE-EASY-HANDLER.")
(defun compute-real-name (symbol)
"Computes the `real' paramater name \(a string) from the Lisp
symbol SYMBOL. Used in cases where no parameter name is
provided."
;; we just downcase the symbol's name
(string-downcase symbol))
(defun convert-parameter (argument type)
"Converts the string ARGUMENT to TYPE where TYPE is one of the
symbols STRING, CHARACTERS, INTEGER, KEYWORD, or BOOLEAN - or
otherwise a function designator for a function of one argument.
ARGUMENT can also be NIL in which case this function also returns
NIL unconditionally."
(when (listp argument)
;; this if for the case that ARGUMENT is NIL or the result of a
;; file upload
(return-from convert-parameter argument))
(case type
(string argument)
(character (and (= (length argument) 1)
(char argument 0)))
(integer (ignore-errors* (parse-integer argument :junk-allowed t)))
(keyword (as-keyword argument :destructivep nil))
(boolean t)
(otherwise (funcall type argument))))
(defun compute-simple-parameter (parameter-name type parameter-reader)
"Retrieves the parameter named PARAMETER-NAME using the reader
PARAMETER-READER and converts it to TYPE."
(convert-parameter (funcall parameter-reader parameter-name) type))
(defun compute-list-parameter (parameter-name type parameters)
"Retrieves all parameters from PARAMETERS which are named
PARAMETER-NAME, converts them to TYPE, and returns a list of
them."
(loop for (name . value) in parameters
when (string= name parameter-name)
collect (convert-parameter value type)))
(defun compute-array-parameter (parameter-name type parameters)
"Retrieves all parameters from PARAMETERS which are named like
\"PARAMETER-NAME[N]\" \(where N is a non-negative integer),
converts them to TYPE, and returns an array where the Nth element
is the corresponding value."
;; see
#+:sbcl (declare (sb-ext:muffle-conditions warning))
(let* ((index-value-list
(loop for (full-name . value) in parameters
for index = (register-groups-bind (name index-string)
("^(.*)\\[(\\d+)\\]$" full-name)
(when (string= name parameter-name)
(parse-integer index-string)))
when index
collect (cons index (convert-parameter value type))))
(array (make-array (1+ (reduce #'max index-value-list
:key #'car
:initial-value -1))
:initial-element nil)))
(loop for (index . value) in index-value-list
do (setf (aref array index) value))
array))
(defun compute-hash-table-parameter (parameter-name type parameters key-type test-function)
"Retrieves all parameters from PARAMETERS which are named like
\"PARAMETER-NAME{FOO}\" \(where FOO is any sequence of characters
not containing curly brackets), converts them to TYPE, and
returns a hash table with test function TEST-FUNCTION where the
corresponding value is associated with the key FOO \(converted to
KEY-TYPE)."
(let ((hash-table (make-hash-table :test test-function)))
(loop for (full-name . value) in parameters
for key = (register-groups-bind (name key-string)
("^(.*){([^{}]+)}$" full-name)
(when (string= name parameter-name)
(convert-parameter key-string key-type)))
when key
do (setf (gethash key hash-table)
(convert-parameter value type)))
hash-table))
(defun compute-parameter (parameter-name parameter-type request-type)
"Computes and returns the parameter\(s) called PARAMETER-NAME
and converts it/them according to the value of PARAMETER-TYPE.
REQUEST-TYPE is one of :GET, :POST, or :BOTH."
(when (member parameter-type '(list array hash-table))
(setq parameter-type (list parameter-type 'string)))
(let ((parameter-reader (ecase request-type
(:get #'get-parameter)
(:post #'post-parameter)
(:both #'parameter)))
(parameters (and (listp parameter-type)
(case request-type
(:get (get-parameters*))
(:post (post-parameters*))
(:both (append (get-parameters*) (post-parameters*)))))))
(cond ((atom parameter-type)
(compute-simple-parameter parameter-name parameter-type parameter-reader))
((and (null (cddr parameter-type))
(eq (first parameter-type) 'list))
(compute-list-parameter parameter-name (second parameter-type) parameters))
((and (null (cddr parameter-type))
(eq (first parameter-type) 'array))
(compute-array-parameter parameter-name (second parameter-type) parameters))
((and (null (cddddr parameter-type))
(eq (first parameter-type) 'hash-table))
(compute-hash-table-parameter parameter-name (second parameter-type) parameters
(or (third parameter-type) 'string)
(or (fourth parameter-type) 'equal)))
(t (parameter-error "Don't know what to do with parameter type ~S." parameter-type)))))
(defun make-defun-parameter (description default-parameter-type default-request-type)
"Creates a keyword parameter to be used by DEFINE-EASY-HANDLER.
DESCRIPTION is one of the elements of DEFINE-EASY-HANDLER's
LAMBDA-LIST and DEFAULT-PARAMETER-TYPE and DEFAULT-REQUEST-TYPE
are the global default values."
(when (atom description)
(setq description (list description)))
(destructuring-bind (parameter-name &key (real-name (compute-real-name parameter-name))
parameter-type init-form request-type)
description
`(,parameter-name (or (and (boundp '*request*)
(compute-parameter ,real-name
,(or parameter-type default-parameter-type)
,(or request-type default-request-type)))
,init-form))))
(defmacro define-easy-handler (description lambda-list &body body)
"Defines a handler with the body BODY and optionally registers
it with a URI so that it will be found by DISPATCH-EASY-HANDLERS.
DESCRIPTION is either a symbol NAME or a list matching the
destructuring lambda list
(name &key uri acceptor-names default-parameter-type default-request-type).
LAMBDA-LIST is a list the elements of which are either a symbol
VAR or a list matching the destructuring lambda list
(var &key real-name parameter-type init-form request-type).
The resulting handler will be a Lisp function with the name NAME
and keyword parameters named by the VAR symbols. Each VAR will
be bound to the value of the GET or POST parameter called
REAL-NAME \(a string) before BODY is executed. If REAL-NAME is
not provided, it will be computed by downcasing the symbol name
of VAR.
If URI \(which is evaluated) is provided, then it must be a string or
a function designator for a function of one argument. In this case,
the handler will be returned by DISPATCH-EASY-HANDLERS, if URI is a
string and the script name of a request is URI, or if URI designates a
function and applying this function to the current request object
returns a true value.
ACCEPTOR-NAMES \(which is evaluated) can be a list of symbols which
means that the handler will be returned by DISPATCH-EASY-HANDLERS in
acceptors which have one of these names \(see ACCEPTOR-NAME).
ACCEPTOR-NAMES can also be the symbol T which means that the handler
will be returned by DISPATCH-EASY-HANDLERS in every acceptor.
Whether the GET or POST parameter \(or both) will be taken into
consideration, depends on REQUEST-TYPE which can
be :GET, :POST, :BOTH, or NIL. In the last case, the value of
DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be
used.
The value of VAR will usually be a string \(unless it resulted from a
file upload in which case it won't be converted at all), but if
PARAMETER-TYPE \(which is evaluated) is provided, the string will be
converted to another Lisp type by the following rules:
If the corresponding GET or POST parameter wasn't provided by the
client, VAR's value will be NIL. If PARAMETER-TYPE is 'STRING, VAR's
value remains as is. If PARAMETER-TYPE is 'INTEGER and the parameter
string consists solely of decimal digits, VAR's value will be the
corresponding integer, otherwise NIL. If PARAMETER-TYPE is 'KEYWORD,
VAR's value will be the keyword obtained by interning the upcased
parameter string into the keyword package. If PARAMETER-TYPE is
'CHARACTER and the parameter string is of length one, VAR's value will
be the single character of this string, otherwise NIL. If
PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it
is NIL by the first rule above, of course). If PARAMETER-TYPE is any
other atom, it is supposed to be a function designator for a unary
function which will be called to convert the string to something else.
Those were the rules for `simple' types, but PARAMETER-TYPE can
also be a list starting with one of the symbols LIST, ARRAY, or
HASH-TABLE. The second value of the list must always be a simple
parameter type as in the last paragraph - we'll call it the
`inner type' below.
In the case of 'LIST, all GET/POST parameters called REAL-NAME
will be collected, converted to the inner type, and assembled
into a list which will be the value of VAR.
In the case of 'ARRAY, all GET/POST parameters which have a name
like the result of
(format nil \"~A[~A]\" real-name n)
where N is a non-negative integer, will be assembled into an
array where the Nth element will be set accordingly, after
conversion to the inner type. The array, which will become the
value of VAR, will be big enough to hold all matching parameters,
but not bigger. Array elements not set as described above will
be NIL. Note that VAR will always be bound to an array, which
may be empty, so it will never be NIL, even if no appropriate
GET/POST parameters are found.
The full form of a 'HASH-TABLE parameter type is
(hash-table inner-type key-type test-function),
but KEY-TYPE and TEST-FUNCTION can be left out in which case they
default to 'STRING and 'EQUAL, respectively. For this parameter
type, all GET/POST parameters which have a name like the result
of
(format nil \"~A{~A}\" real-name key)
\(where KEY is a string that doesn't contain curly brackets) will
become the values \(after conversion to INNER-TYPE) of a hash
table with test function TEST-FUNCTION where KEY \(after
conversion to KEY-TYPE) will be the corresponding key. Note that
VAR will always be bound to a hash table, which may be empty, so
it will never be NIL, even if no appropriate GET/POST parameters
are found.
To make matters even more complicated, the three compound
parameter types also have an abbreviated form - just one of the
symbols LIST, ARRAY, or HASH-TABLE. In this case, the inner type
will default to 'STRING.
If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE
\(the default of which is 'STRING) will be used instead.
If the result of the computations above would be that VAR would
be bound to NIL, then INIT-FORM \(if provided) will be evaluated
instead, and VAR will be bound to the result of this evaluation.
Handlers built with this macro are constructed in such a way that
the resulting Lisp function is useful even outside of
Hunchentoot. Specifically, all the parameter computations above
will only happen if *REQUEST* is bound, i.e. if we're within a
Hunchentoot request. Otherwise, VAR will always be bound to the
result of evaluating INIT-FORM unless a corresponding keyword
argument is provided."
(when (atom description)
(setq description (list description)))
(destructuring-bind (name &key uri (acceptor-names t)
(default-parameter-type ''string)
(default-request-type :both))
description
`(progn
,@(when uri
(list
(with-rebinding (uri)
`(progn
(setq *easy-handler-alist*
(delete-if (lambda (list)
(and (or (equal ,uri (first list))
(eq ',name (third list)))
(or (eq ,acceptor-names t)
(intersection ,acceptor-names
(second list)))))
*easy-handler-alist*))
(push (list ,uri ,acceptor-names ',name) *easy-handler-alist*)))))
(defun ,name (&key ,@(loop for part in lambda-list
collect (make-defun-parameter part
default-parameter-type
default-request-type)))
,@body))))
;; help the LispWorks IDE to find these definitions
#+:lispworks
(dspec:define-form-parser define-easy-handler (description)
`(,define-easy-handler ,(if (atom description) description (first description))))
#+:lispworks
(dspec:define-dspec-alias define-easy-handler (name)
`(defun ,name))
(defun dispatch-easy-handlers (request)
"This is a dispatcher which returns the appropriate handler
defined with DEFINE-EASY-HANDLER, if there is one."
(loop for (uri acceptor-names easy-handler) in *easy-handler-alist*
when (and (or (eq acceptor-names t)
(find (acceptor-name *acceptor*) acceptor-names :test #'eq))
(cond ((stringp uri)
(string= (script-name request) uri))
(t (funcall uri request))))
do (return easy-handler)))
(defclass easy-acceptor (acceptor)
()
(:documentation "This is the acceptor of the ``easy'' Hunchentoot framework."))
(defmethod acceptor-dispatch-request ((acceptor easy-acceptor) request)
"The easy request dispatcher which selects a request handler
based on a list of individual request dispatchers all of which can
either return a handler or neglect by returning NIL."
(loop for dispatcher in *dispatch-table*
for action = (funcall dispatcher request)
when action return (funcall action)
finally (call-next-method)))
#-:hunchentoot-no-ssl
(defclass easy-ssl-acceptor (easy-acceptor ssl-acceptor)
()
(:documentation "This is an acceptor that mixes the ``easy''
Hunchentoot with SSL connections."))
hunchentoot-v1.2.38/util.lisp 0000644 0000000 0000000 00000040441 13211004253 014667 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defun starts-with-p (seq subseq &key (test 'eql))
"Tests whether the sequence SEQ starts with the sequence
SUBSEQ. Individual elements are compared with TEST."
(let* ((length (length subseq))
(mismatch (mismatch subseq seq
:test test)))
(or (null mismatch)
(<= length mismatch))))
(defun starts-with-one-of-p (seq subseq-list &key (test 'eql))
"Tests whether the sequence SEQ starts with one of the
sequences in SUBSEQ-LIST. Individual elements are compared with
TEST."
(some (lambda (subseq)
(starts-with-p seq subseq :test test))
subseq-list))
(defun create-random-string (&optional (n 10) (base 16))
"Returns a random number \(as a string) with base BASE and N
digits."
(with-output-to-string (s)
(dotimes (i n)
(format s "~VR" base
(random base *the-random-state*)))))
(defun reason-phrase (return-code)
"Returns a reason phrase for the HTTP return code RETURN-CODE \(which
should be an integer) or NIL for return codes Hunchentoot doesn't know."
(gethash return-code *http-reason-phrase-map*
"No reason phrase known"))
(defgeneric assoc* (thing alist)
(:documentation "Similar to CL:ASSOC, but 'does the right thing' if
THING is a string or a symbol.")
(:method ((thing symbol) alist)
(assoc thing alist :test #'eq))
(:method ((thing string) alist)
(assoc thing alist :test #'string-equal))
(:method (thing alist)
(assoc thing alist :test #'eql)))
(defun md5-hex (string)
"Calculates the md5 sum of the string STRING and returns it as a hex string."
(with-output-to-string (s)
(loop for code across (md5:md5sum-string string)
do (format s "~2,'0x" code))))
(defun escape-for-html (string)
"Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML
output."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
do (case char
((#\<) (write-string "<" out))
((#\>) (write-string ">" out))
((#\") (write-string """ out))
((#\') (write-string "'" out))
((#\&) (write-string "&" out))
(otherwise (write-char char out)))))))
(defun http-token-p (token)
"This function tests whether OBJECT is a non-empty string which is a
TOKEN according to RFC 2068 \(i.e. whether it may be used for, say,
cookie names)."
(and (stringp token)
(plusp (length token))
(every (lambda (char)
(and ;; CHAR is US-ASCII but not control character or ESC
(< 31 (char-code char) 127)
;; CHAR is not 'tspecial'
(not (find char "()<>@,;:\\\"/[]?={} " :test #'char=))))
token)))
(defun rfc-1123-date (&optional (time (get-universal-time)))
"Generates a time string according to RFC 1123. Default is current time.
This can be used to send a 'Last-Modified' header - see
HANDLE-IF-MODIFIED-SINCE."
(multiple-value-bind
(second minute hour date month year day-of-week)
(decode-universal-time time 0)
(format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
(svref +day-names+ day-of-week)
date
(svref +month-names+ (1- month))
year
hour
minute
second)))
(defun iso-time (&optional (time (get-universal-time)))
"Returns the universal time TIME as a string in full ISO format."
(multiple-value-bind (second minute hour date month year)
(decode-universal-time time)
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
year month date hour minute second)))
(let ((counter 0))
(declare (ignorable counter))
(defun make-tmp-file-name (&optional (prefix "hunchentoot"))
"Generates a unique name for a temporary file. This function is
called from the RFC2388 library when a file is uploaded."
(let ((tmp-file-name
#+:allegro
(pathname (system:make-temp-file-name prefix *tmp-directory*))
#-:allegro
(loop for pathname = (make-pathname :name (format nil "~A-~A"
prefix (incf counter))
:type nil
:defaults *tmp-directory*)
unless (probe-file pathname)
return pathname)))
(push tmp-file-name *tmp-files*)
;; maybe call hook for file uploads
(when *file-upload-hook*
(funcall *file-upload-hook* tmp-file-name))
tmp-file-name)))
(defun quote-string (string)
"Quotes string according to RFC 2616's definition of `quoted-string'."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
unless (or (char< char #\Space)
(char= char #\Rubout))
do (case char
((#\\) (write-string "\\\\" out))
((#\") (write-string "\\\"" out))
(otherwise (write-char char out)))))))
(defmacro upgrade-vector (vector new-type &key converter)
"Returns a vector with the same length and the same elements as
VECTOR \(a variable holding a vector) but having element type
NEW-TYPE. If CONVERTER is not NIL, it should designate a function
which will be applied to each element of VECTOR before the result is
stored in the new vector. The resulting vector will have a fill
pointer set to its end.
The macro also uses SETQ to store the new vector in VECTOR."
`(setq ,vector
(loop with length = (length ,vector)
with new-vector = (make-array length
:element-type ,new-type
:fill-pointer length)
for i below length
do (setf (aref new-vector i) ,(if converter
`(funcall ,converter (aref ,vector i))
`(aref ,vector i)))
finally (return new-vector))))
(defun ensure-parse-integer (string &key (start 0) end (radix 10))
(let ((end (or end (length string))))
(if (or (>= start (length string))
(> end (length string)))
(error 'bad-request)
(multiple-value-bind (integer stopped)
(parse-integer string :start start :end end :radix radix :junk-allowed t)
(if (/= stopped end)
(error 'bad-request)
integer)))))
(defun url-decode (string &optional (external-format *hunchentoot-default-external-format*))
"Decodes a URL-encoded string which is assumed to be encoded using the
external format EXTERNAL-FORMAT, i.e. this is the inverse of
URL-ENCODE. It is assumed that you'll rarely need this function, if
ever. But just in case - here it is. The default for EXTERNAL-FORMAT is
the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
(when (zerop (length string))
(return-from url-decode ""))
(let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
(i 0)
unicodep)
(loop
(unless (< i (length string))
(return))
(let ((char (aref string i)))
(labels ((decode-hex (length)
(ensure-parse-integer string :start i :end (incf i length)
:radix 16))
(push-integer (integer)
(vector-push integer vector))
(peek ()
(if (array-in-bounds-p string i)
(aref string i)
(error 'bad-request)))
(advance ()
(setq char (peek))
(incf i)))
(cond
((char= #\% char)
(advance)
(cond
((char= #\u (peek))
(unless unicodep
(setq unicodep t)
(upgrade-vector vector '(integer 0 65535)))
(advance)
(push-integer (decode-hex 4)))
(t
(push-integer (decode-hex 2)))))
(t
(push-integer (char-code (case char
((#\+) #\Space)
(otherwise char))))
(advance))))))
(cond (unicodep
(upgrade-vector vector 'character :converter #'code-char))
(t (octets-to-string vector :external-format external-format)))))
(defun form-url-encoded-list-to-alist (form-url-encoded-list
&optional (external-format *hunchentoot-default-external-format*))
"Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
alist. Both names and values are url-decoded while doing this."
(mapcar #'(lambda (entry)
(destructuring-bind (name &optional value)
(split "=" entry :limit 2)
(cons (string-trim " " (url-decode name external-format))
(url-decode (or value "") external-format))))
form-url-encoded-list))
(defun cookies-to-alist (cookies)
"Converts a list of cookies of the form \"key=value\" to an alist. No
character set processing is done."
(mapcar #'(lambda (entry)
(destructuring-bind (name &optional value)
(split "=" entry :limit 2)
(cons (string-trim " " name) (or value ""))))
cookies))
(defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
"URL-encodes a string using the external format EXTERNAL-FORMAT. The
default for EXTERNAL-FORMAT is the value of
*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
(with-output-to-string (s)
(loop for c across string
for index from 0
do (cond ((or (char<= #\0 c #\9)
(char<= #\a c #\z)
(char<= #\A c #\Z)
;; note that there's no comma in there - because of cookies
(find c "$-_.!*'()" :test #'char=))
(write-char c s))
(t (loop for octet across (string-to-octets string
:start index
:end (1+ index)
:external-format external-format)
do (format s "%~2,'0x" octet)))))))
(defun parse-content-type (content-type-header)
"Reads and parses a `Content-Type' header and returns it as three
values - the type, the subtype, and the requests' character set as
specified in the 'charset' parameter in the header, if there is one
and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed
to be the corresponding header value as a string."
(with-input-from-sequence (stream (map 'list 'char-code content-type-header))
(with-character-stream-semantics
(let* ((*current-error-message* (format nil "Corrupted Content-Type header ~S:" content-type-header))
(type (read-token stream))
(subtype (if (eql #\/ (read-char* stream nil))
(read-token stream)
(return-from parse-content-type
;; try to return something meaningful
(values "application" "octet-stream" nil))))
(parameters (read-name-value-pairs stream))
(charset (cdr (assoc "charset" parameters :test #'string=)))
(charset
(when (string-equal type "text")
charset)))
(values type subtype charset)))))
(defun keep-alive-p (request)
"Returns a true value unless the incoming request's headers or the
server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
The second return value denotes whether the client has explicitly
asked for a persistent connection."
(let ((connection-values
;; the header might consist of different values separated by commas
(when-let (connection-header (header-in :connection request))
(split "\\s*,\\s*" connection-header))))
(flet ((connection-value-p (value)
"Checks whether the string VALUE is one of the
values of the `Connection' header."
(member value connection-values :test #'string-equal)))
(let ((keep-alive-requested-p (connection-value-p "keep-alive")))
(values (and (acceptor-persistent-connections-p *acceptor*)
(or (and (eq (server-protocol request) :http/1.1)
(not (connection-value-p "close")))
(and (eq (server-protocol request) :http/1.0)
keep-alive-requested-p)))
keep-alive-requested-p)))))
(defun address-string ()
"Returns a string with information about Hunchentoot suitable for
inclusion in HTML output."
(flet ((escape-for-html (arg)
(if arg
(escape-for-html arg)
arg)))
(format nil "Hunchentoot ~A (~A ~A)~@[ at ~A~:[ (port ~D)~;~]~]"
*hunchentoot-version*
+implementation-link+
(escape-for-html (lisp-implementation-type))
(escape-for-html (lisp-implementation-version))
(escape-for-html (or (host *request*) (acceptor-address *acceptor*)))
(scan ":\\d+$" (or (host *request*) ""))
(acceptor-port *acceptor*))))
(defun input-chunking-p ()
"Whether input chunking is currently switched on for
*HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
not a chunked stream."
(chunked-stream-input-chunking-p *hunchentoot-stream*))
(defun ssl-p (&optional (acceptor *acceptor*))
"Whether the current connection to the client is secure. See
ACCEPTOR-SSL-P."
(acceptor-ssl-p acceptor))
(defmacro with-mapped-conditions (() &body body)
"Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
signalled as usocket conditions. For Lispworks, no mapping is performed."
#+:lispworks
`(progn ,@body)
#-:lispworks
`(usocket:with-mapped-conditions ()
,@body))
(defmacro with-conditions-caught-and-logged (() &body body)
"Run BODY with conditions caught and logged by the *ACCEPTOR*. Errors are
stopped right away so no other part of the software is impacted by them."
`(block nil
(handler-bind
((error
;; abort if there's an error which isn't caught inside
(lambda (cond)
(log-message* *lisp-errors-log-level*
"Error while processing connection: ~A" cond)
(return)))
(warning
;; log all warnings which aren't caught inside
(lambda (cond)
(when *log-lisp-warnings-p*
(log-message* *lisp-warnings-log-level*
"Warning while processing connection: ~A" cond)))))
,@body)))
hunchentoot-v1.2.38/conditions.lisp 0000644 0000000 0000000 00000012754 13211004253 016071 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(define-condition hunchentoot-condition (condition)
()
(:documentation "Superclass for all conditions related to Hunchentoot."))
(define-condition hunchentoot-error (hunchentoot-condition error)
()
(:documentation "Superclass for all errors related to Hunchentoot."))
(define-condition hunchentoot-simple-error (hunchentoot-error simple-condition)
()
(:documentation "Like HUNCHENTOOT-ERROR but with formatting capabilities."))
(defun hunchentoot-error (format-control &rest format-arguments)
"Signals an error of type HUNCHENTOOT-SIMPLE-ERROR with the provided
format control and arguments."
(error 'hunchentoot-simple-error
:format-control format-control
:format-arguments format-arguments))
(define-condition hunchentoot-warning (hunchentoot-condition warning)
()
(:documentation "Superclass for all warnings related to Hunchentoot."))
(define-condition hunchentoot-simple-warning (hunchentoot-warning simple-condition)
()
(:documentation "Like HUNCHENTOOT-WARNING but with formatting capabilities."))
(defun hunchentoot-warn (format-control &rest format-arguments)
"Signals a warning of type HUNCHENTOOT-SIMPLE-WARNING with the
provided format control and arguments."
(warn 'hunchentoot-simple-warning
:format-control format-control
:format-arguments format-arguments))
(define-condition parameter-error (hunchentoot-simple-error)
()
(:documentation "Signalled if a function was called with incosistent or illegal parameters."))
(defun parameter-error (format-control &rest format-arguments)
"Signals an error of type PARAMETER-ERROR with the provided
format control and arguments."
(error 'parameter-error
:format-control format-control
:format-arguments format-arguments))
(define-condition operation-not-implemented (hunchentoot-error)
((operation :initarg :operation
:reader hunchentoot-operation-not-implemented-operation
:documentation "The name of the unimplemented operation."))
(:report (lambda (condition stream)
(format stream "The operation ~A is not yet implemented for the implementation ~A.
Consider sending a patch..."
(hunchentoot-operation-not-implemented-operation condition)
(lisp-implementation-type))))
(:documentation "This warning is signalled when an operation \(like
SETUID for example) is not implemented for a specific Lisp."))
(defun not-implemented (name)
"Used to signal an error if an operation named NAME is not implemented."
(error 'operation-not-implemented :operation name))
(define-condition bad-request (hunchentoot-error)
())
;;;
(defgeneric maybe-invoke-debugger (condition)
(:documentation "This generic function is called whenever a
condition CONDITION is signaled in Hunchentoot. You might want to
specialize it on specific condition classes for debugging purposes.")
(:method (condition)
"The default method invokes the debugger with CONDITION if
*CATCH-ERRORS-P* is NIL."
(unless *catch-errors-p*
(invoke-debugger condition))))
(defmacro with-debugger (&body body)
"Executes BODY and invokes the debugger if an error is signaled and
*CATCH-ERRORS-P* is NIL."
`(handler-bind ((bad-request (lambda (c)
(declare (ignore c))
(setf (return-code *reply*) +http-bad-request+)
(abort-request-handler)))
(error #'maybe-invoke-debugger))
,@body))
(defmacro ignore-errors* (&body body)
"Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*."
`(ignore-errors (with-debugger ,@body)))
(defmacro handler-case* (expression &rest clauses)
"Like HANDLER-CASE, but observes *CATCH-ERRORS-P*."
`(handler-case (with-debugger ,expression)
,@clauses))
(defun get-backtrace ()
"Returns a string with a backtrace of what the Lisp system thinks is
the \"current\" error."
(handler-case
(with-output-to-string (s)
(trivial-backtrace:print-backtrace-to-stream s))
(error (condition)
(format nil "Could not generate backtrace: ~A." condition))))
hunchentoot-v1.2.38/CHANGELOG_TBNL 0000644 0000000 0000000 00000021361 13211004253 015052 0 ustar root root Version 0.11.3
2006-09-30
Added *FILE-UPLOAD-HOOK* (suggested by Erik Enge)
Fixed DEFINE-EASY-HANDLER for cases where URI is NIL
Version 0.11.2
2006-09-20
DEFINE-EASY-HANDLER: fixed and clarified redefinition
DEFINE-EASY-HANDLER: allow for functions designators as "URIs"
DEFINE-EASY-HANDLER: take file uploads into account
Made logging a little bit more robust
Added mime type for XSL-FO (.fo)
Version 0.11.1
2006-09-14
Cleaner implementation of *CATCH-ERRORS-P*
Version 0.11.0
2006-09-14
Added *CATCH-ERRORS-P*
Version 0.10.3
2006-09-05
Appease SBCL (thanks to Juho Snellman)
Version 0.10.2
2006-09-05
Better reporting of IP addresses and ports if not behind mod_lisp
Improved logging
Fixed REAL-REMOTE-ADDR
Cookies always use UTF-8 encoding (which is opaque to the client anyway)
Read request bodies without 'Content-Length' header (for Hunchentoot)
Removed accented character from test.lisp to appease SBCL (reported by Xristos Kalkanis)
Version 0.10.1
2006-08-31
Only LispWorks: Set read timeout to NIL if connected to mod_lisp
Version 0.10.0
2006-08-28
Based LispWorks version of TBNL on Hunchentoot infrastructure
Added "easy" handlers
Exported GET-BACKTRACE (suggested by Erik Enge)
Version 0.9.11
2006-08-16
Added note about SBCL problems
Version 0.9.10
2006-05-24
Prepare for LW 5.0 release
Version 0.9.9
2006-05-12
Workaround for something like "application/x-www-form-urlencoded;charset=UTF-8" (caught by John Bates)
Version 0.9.8
2006-04-25
For mod_lisp, Lisp-Content-Length header must be sent after Content-Length header
Version 0.9.7
2006-02-06
More robust computation of content length
Version 0.9.6
2006-01-22
Added the missing piece (argh!)
Version 0.9.5
2006-01-22
Made creation of REQUEST object safer (thanks to Robert J. Macomber)
Replaced some erroneous DECLAIMs with DECLAREs (thanks to SBCL's style warnings)
Slight documentation enhancements
Version 0.9.4
2006-01-03
Handle "Expect: 100-continue" for non-Apache front-ends
Re-introduced IGNORE-ERRORS in GET-REQUEST-DATA
Version 0.9.3
2006-01-01
Fixed bug in READ-HTTP-REQUEST
Version 0.9.2
2005-12-31
Protocol of reply is HTTP/1.1 now
Made HTTP/0.9 default protocol of request if none was provided
Some preparations for Hunchentoot
Various minor changes
Small fixes in docs
Version 0.9.1
2005-12-25
Added missing file mime-types.lisp (thanks to Hilverd Reker)
Version 0.9.0
2005-12-24
Experimental support for writing directly to the front-end (see SEND-HEADERS)
Added HANDLE-STATIC-FILE
Changed CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER to use new facilities
Added CREATE-FOLDER-DISPATCHER-AND-HANDLER
Added link to Travis Cross' message w.r.t. SBCL
Version 0.8.9
2005-12-16
Also use :TBNL-BIVALENT-STREAMS if :SB-UNICODE is present
Version 0.8.8
2005-12-08
Made RAW-POST-DATA more useful
Updated docs w.r.t. Araneida (thanks to Alan Shields)
Version 0.8.7
2005-11-29
Made "Content-Length" header SETFable
Version 0.8.6
2005-11-18
Restored original stream-based code for multipart/form-data parsing (got lost somehow)
Wrapped REMOTE-ADDR with IGNORE-ERRORS (just in case)
Version 0.8.5
2005-11-14
Added generic function DISPATCH-REQUEST (thanks to Jeff Caldwell)
Version 0.8.4
2005-10-21
Provide REMOTE-ADDR if connected directly (for LispWorks and AllegroCL)
Show remote user and address (if available) in non-Apache logs
Mention Debian package in docs
Version 0.8.3
2005-10-10
Alert LW users that a patch for OCTETS-TO-STRINGS is available (thanks to LispWorks support)
Version 0.8.2
2005-10-06
Make STRING-TO-OCTETS and OCTETS-TO-STRING safer for LW
Version 0.8.1
2005-09-29
Bugfix in CMUCL version of STRING-TO-OCTETS
Version 0.8.0
2005-09-24
Added the ability to cope with different external formats (incorporating suggestions from Will Glozer and Ivan Shvedunov)
Raw post data is now always saved (so *SAVE-RAW-POST-DATA-P* is gone)
Version 0.7.0
2005-09-17
Added the ability to store arbitrary data within REQUEST objects (suggested by Zach Beane)
Fixed handling of *HTTP-ERROR-HANDLER*
Note: *TBNL-VERSION* was wrong in 0.6.0 and 0.6.1
Version 0.6.1
2005-09-10
Robustified socket handling code
Version 0.6.0
2005-09-08
Added TBNL-CONTRIB package
Added contrib directory with first entry (from Alceste Scalas)
Updated link to Bill Clementson's blog
Don't redefine what's already there (for LispWorks)
Version 0.5.5
2005-04-18
Make RFC 2388 code an external dependency (thanks to Janis Dzerins)
Version 0.5.4
2005-04-03
Fixed dumb typo (caught by Bob Hutchison)
Version 0.5.3
2005-04-03
Re-introduced automatic front-end selection (originally by Bob Hutchison)
Version 0.5.2
2005-03-26
Fixed bug in modlisp.html where *CLOSE-TBNL-STREAM* could be NIL although it should be T
Set correct content type for 304 replies
Version 0.5.1
2005-03-17
Changed default cookie path in START-SESSION (suggested by Stefan Scholl)
Small bugfixes
More headers from the Araneida front-end
Added *SHOW-ACCESS-LOG-MESSAGES*
Changed "back-end" to "front-end" :)
Version 0.5.0
2005-03-17
Initial support for "stand-alone" version (no front-end) (supplied by Bob Hutchison)
New logging API
Fixes in START-TBNL/STOP-TBNL
Documentation enhancements
Version 0.4.1
2005-03-15
Fixed some typos, removed unused code
Version 0.4.0
2005-03-14
Initial Araneida support (supplied by Bob Hutchison)
Version 0.3.13
2005-03-12
Small bugfix in RFC-1123-DATE (thanks to Bob Hutchison and Stefan Scholl)
Version 0.3.12
2005-03-01
Added *HTTP-ERROR-HANDLER* (suggested and coded by Stefan Scholl)
Exported and documented *SESSION-MAX-TIME*
Version 0.3.11
2005-02-21
Added ability to access raw post data (suggested and coded by Zach Beane)
Version 0.3.10
2005-01-24
Make bivalent streams work with LispWorks 4.4
UTF-8 demo for LispWorks (thanks to Bob Hutchison)
Version 0.3.9
2004-12-31
Re-compute content length after applying MAYBE-REWRITE-URLS-FOR-SESSION (caught by Stefan Scholl)
Version 0.3.8
2004-12-27
Don't send body for HEAD requests (needs current mod_lisp version)
Version 0.3.7
2004-12-22
Change #\Del to #\Rubout in QUOTE-STRING (AllegroCL complains, #\Del isn't even semi-standard)
Version 0.3.6
2004-12-02
Make REQUIRE-AUTHORIZATION compliant to RFC 2616 (thanks to Stefan Scholl)
Version 0.3.5
2004-12-01
Several small doc fixes (thanks to Stefan Scholl)
Catch requests like "GET http://server/foo.html HTTP/1.0" (suggested by Stefan Scholl)
Version 0.3.4
2004-11-29
Added backtrace code for OpenMCL (provided by Tiarnn Corrin)
Version 0.3.3
2004-11-22
Cleaner handling of macro variables
Version 0.3.2
2004-11-11
Updated docs for mod_lisp2
Version 0.3.1
2004-11-09
Slight changes to support Chris Hanson's mod_lisp2
Changed GET-BACKTRACE for newer SBCL versions (thanks to Nikodemus Siivola)
Version 0.3.0
2004-11-09
Initial support for multipart/form-data (thanks to Michael Weber and Janis Dzerins)
Fixed bug in CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (caught by Bill Clementson)
Version 0.2.12
2004-10-15
Exported and documented DO-SESSIONS
Version 0.2.11
2004-09-02
FORM-URL-ENCODED-LIST-TO-ALIST now decodes names and values
Version 0.2.10
2004-08-28
Allow non-strings to be cookie values (bug caught by Zach Beane)
Version 0.2.9
2004-08-11
Consistent usage of RFC-1123-DATE (provided by Stefan Scholl)
Added all missing http headers from RFC 2616 (provided by Stefan Scholl)
Added support for mod_lisp version strings (see )
Don't always add session IDs when redirecting
Version 0.2.8
2004-07-24
Fixed typo in html.lisp and improved docs (both caught by Stefan Scholl)
Version 0.2.7
2004-07-24
Add missing exports and docs
Version 0.2.6
2004-07-24
Make CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER thread-safe (caught by Jeff Caldwell)
Added support for 'If-Modified-Since' request headers (provided by Stefan Scholl)
Version 0.2.5
2004-07-21
Added CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (provided by Stefan Scholl)
Improved test suite
Version 0.2.4
2004-07-19
New variable *CONTENT-TYPES-FOR-URL-REWRITE* (suggested by Stefan Scholl)
Updated index.html regarding new version of mod_lisp
Version 0.2.3
2004-06-12
Bugfix for FORM-URL-ENCODED-LIST-TO-ALIST (bug caught by Jong-won Choi)
Version 0.2.2
2004-06-10
Bugfix for SESSION-GC and RESET-SESSIONS (bug introduced in 0.2.0)
Version 0.2.1
2004-06-10
Only create backtrace if needed (speeds up AllegroCL considerably)
Version 0.2.0
2004-06-07
Added SESSION-STRING and *SESSION-REMOVAL-HOOK*
Added GET-BACKTRACE for AllegroCL
Version 0.1.2
2004-05-12
Removed some more typos in docs (thanks to Karl A. Krueger)
Changed BASE64 to CL-BASE64 in .asd file (thanks to Frank Sonnemans and Nicolas Lamirault)
Version 0.1.1
2004-05-08
Removed some old files from Jeff's port
Fixed a couple of typos in docs
Version 0.1.0
2004-05-07
First public release
Original code by Edi Weitz
Initial doc strings, port to KMRCL, logging code and various other improvements by Jeff Caldwell
hunchentoot-v1.2.38/headers.lisp 0000644 0000000 0000000 00000033136 13211004253 015330 0 ustar root root ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :hunchentoot)
(defgeneric write-header-line (key value stream)
(:documentation "Accepts a string KEY and a Lisp object VALUE and
writes them directly to the client as an HTTP header line.")
(:method (key (string string) stream)
(write-string key stream)
(write-char #\: stream)
(write-char #\Space stream)
(let ((start 0))
(loop
(let ((end (or (position #\Newline string :start start)
(length string))))
;; skip empty lines, as they confuse certain HTTP clients
(unless (eql start end)
(unless (zerop start)
(write-char #\Tab stream))
(write-string string stream :start start :end end)
(write-char #\Return stream)
(write-char #\Linefeed stream))
(setf start (1+ end))
(when (<= (length string) start)
(return))))))
(:method (key (number number) stream)
(write-header-line key (write-to-string number :escape nil :readably nil :base 10) stream))
(:method (key value stream)
(write-header-line key (princ-to-string value) stream)))
(defun maybe-add-charset-to-content-type-header (content-type external-format)
"Given the contents of a CONTENT-TYPE header, add a charset=
attribute describing the given EXTERNAL-FORMAT if no charset=
attribute is already present and the content type is a text content
type. Returns the augmented content type."
(if (and (cl-ppcre:scan "(?i)^text" content-type)
(not (cl-ppcre:scan "(?i);\\s*charset=" content-type)))
(format nil "~A; charset=~(~A~)" content-type (flex:external-format-name external-format))
content-type))
(defun start-output (return-code &optional (content nil content-provided-p))
"Sends all headers and maybe the content body to
*HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called
more than once per request. Called by PROCESS-REQUEST and/or
SEND-HEADERS. The RETURN-CODE argument represents the integer return
code of the request. The corresponding reason phrase is determined by
calling the REASON-PHRASE function. The CONTENT provided represents
the body data to send to the client, if any. If it is not specified,
no body is written to the client. The handler function is expected to
directly write to the stream in this case.
Returns the stream that is connected to the client."
(let* ((chunkedp (and (acceptor-output-chunking-p *acceptor*)
(eq (server-protocol *request*) :http/1.1)
;; only turn chunking on if the content
;; length is unknown at this point...
(null (or (content-length*) content-provided-p))))
(request-method (request-method *request*))
(head-request-p (eq request-method :head))
content-modified-p)
(multiple-value-bind (keep-alive-p keep-alive-requested-p)
(keep-alive-p *request*)
(when keep-alive-p
(setq keep-alive-p
;; use keep-alive if there's a way for the client to
;; determine when all content is sent (or if there
;; is no content)
(or chunkedp
head-request-p
(eql (return-code*) +http-not-modified+)
(content-length*)
content)))
;; now set headers for keep-alive and chunking
(when chunkedp
(setf (header-out :transfer-encoding) "chunked"))
(cond (keep-alive-p
(setf *finish-processing-socket* nil)
(when (and (acceptor-read-timeout *acceptor*)
(or (not (eq (server-protocol *request*) :http/1.1))
keep-alive-requested-p))
;; persistent connections are implicitly assumed for
;; HTTP/1.1, but we return a 'Keep-Alive' header if the
;; client has explicitly asked for one
(unless (header-out :connection) ; allowing for handler overriding
(setf (header-out :connection) "Keep-Alive"))
(setf (header-out :keep-alive)
(format nil "timeout=~D" (acceptor-read-timeout *acceptor*)))))
((not (header-out-set-p :connection))
(setf (header-out :connection) "Close"))))
(unless (and (header-out-set-p :server)
(null (header-out :server)))
(setf (header-out :server) (or (header-out :server)
(acceptor-server-name *acceptor*))))
(setf (header-out :date) (rfc-1123-date))
(when (and (stringp content)
(not content-modified-p)
(starts-with-one-of-p (or (content-type*) "")
*content-types-for-url-rewrite*))
;; if the Content-Type header starts with one of the strings
;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the
;; content
(setq content (maybe-rewrite-urls-for-session content)))
(when (stringp content)
;; if the content is a string, convert it to the proper external format
(setf content (string-to-octets content :external-format (reply-external-format*))
(content-type*) (maybe-add-charset-to-content-type-header (content-type*)
(reply-external-format*))))
(when content
;; whenever we know what we're going to send out as content, set
;; the Content-Length header properly; maybe the user specified
;; a different content length, but that will wrong anyway
(setf (header-out :content-length) (length content)))
;; send headers only once
(when *headers-sent*
(return-from start-output))
(setq *headers-sent* t)
(send-response *acceptor*
*hunchentoot-stream*
return-code
:headers (headers-out*)
:cookies (cookies-out*)
:content (unless head-request-p
content))
;; when processing a HEAD request, exit to return from PROCESS-REQUEST
(when head-request-p
(throw 'request-processed nil))
(when chunkedp
;; turn chunking on after the headers have been sent
(unless (typep *hunchentoot-stream* 'chunked-stream)
(setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)))
(setf (chunked-stream-output-chunking-p *hunchentoot-stream*) t))
*hunchentoot-stream*))
(defun send-response (acceptor stream status-code
&key headers cookies content)
"Send a HTTP response to the STREAM and log the event in ACCEPTOR.
STATUS-CODE is the HTTP status code used in the response. HEADERS
and COOKIES are used to create the response header. If CONTENT is
provided, it is sent as the response body.
If *HEADER-STREAM* is not NIL, the response headers are written to
that stream when they are written to the client.
STREAM is returned."
(when content
(setf (content-length*) (length content)))
(when (content-length*)
(if (assoc :content-length headers)
(setf (cdr (assoc :content-length headers)) (content-length*))
(push (cons :content-length (content-length*)) headers)))
;; access log message
(acceptor-log-access acceptor :return-code status-code)
;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead.
(raw-post-data :force-binary t)
(let* ((client-header-stream (flex:make-flexi-stream stream :external-format +latin-1+))
(header-stream (if *header-stream*
(make-broadcast-stream *header-stream* client-header-stream)
client-header-stream)))
;; start with status line
(format header-stream "HTTP/1.1 ~D ~A~C~C" status-code (reason-phrase status-code) #\Return #\Linefeed)
;; write all headers from the REPLY object
(loop for (key . value) in headers
when value
do (write-header-line (as-capitalized-string key) value header-stream))
;; now the cookies
(loop for (nil . cookie) in cookies
do (write-header-line "Set-Cookie" (stringify-cookie cookie) header-stream))
(format header-stream "~C~C" #\Return #\Linefeed))
;; now optional content
(when content
(write-sequence content stream)
(finish-output stream))
stream)
(defun send-headers ()
"Sends the initial status line and all headers as determined by the
REPLY object *REPLY*. Returns a binary stream to which the body of
the reply can be written. Once this function has been called, further
changes to *REPLY* don't have any effect. Also, automatic handling of
errors \(i.e. sending the corresponding status code to the browser,
etc.) is turned off for this request. If your handlers return the
full body as a string or as an array of octets you should NOT call
this function.
This function does not return control to the caller during HEAD
request processing."
(start-output (return-code*)))
(defun read-initial-request-line (stream)
"Reads and returns the initial HTTP request line, catching permitted
errors and handling *BREAK-EVEN-WHILE-READING-REQUEST-TYPE-P*. If no
request could be read, returns NIL. At this point, both an
end-of-file as well as a timeout condition are normal; end-of-file
will occur when the client has decided to not send another request but
to close the connection instead, a timeout indicates that the
connection timeout established by Hunchentoot has expired and we do
not want to wait for another request any longer."
(handler-case
(let ((*current-error-message* "While reading initial request line:"))
(with-mapped-conditions ()
(read-line* stream)))
((or end-of-file #-:lispworks usocket:timeout-error) ())))
(defun send-bad-request-response (stream &optional additional-info)
"Send a ``Bad Request'' response to the client."
(write-sequence (flex:string-to-octets
(format nil "HTTP/1.0 ~D ~A~C~CConnection: close~C~C~C~CYour request could not be interpreted by this HTTP server~C~C~@[~A~]~C~C"
+http-bad-request+ (reason-phrase +http-bad-request+) #\Return #\Linefeed
#\Return #\Linefeed #\Return #\Linefeed #\Return #\Linefeed additional-info #\Return #\Linefeed))
stream))
(defun printable-ascii-char-p (char)
(<= 32 (char-code char) 126))
(defun get-request-data (stream)
"Reads incoming headers from the client via STREAM. Returns as
multiple values the headers as an alist, the method, the URI, and the
protocol of the request."
(with-character-stream-semantics
(let ((first-line (read-initial-request-line stream)))
(when first-line
(unless (every #'printable-ascii-char-p first-line)
(send-bad-request-response stream "Non-ASCII character in request line")
(return-from get-request-data nil))
(destructuring-bind (&optional method url-string protocol)
(split "\\s+" first-line :limit 3)
(unless url-string
(send-bad-request-response stream)
(return-from get-request-data nil))
(when *header-stream*
(format *header-stream* "~A~%" first-line))
(let ((headers (and protocol (read-http-headers stream *header-stream*))))
;; maybe handle 'Expect: 100-continue' header
(when-let (expectations (cdr (assoc* :expect headers)))
(when (member "100-continue" (split "\\s*,\\s*" expectations) :test #'equalp)
;; according to 14.20 in the RFC - we should actually
;; check if we have to respond with 417 here
(let ((continue-line
(format nil "HTTP/1.1 ~D ~A"
+http-continue+
(reason-phrase +http-continue+))))
(write-sequence (map 'list #'char-code continue-line) stream)
(write-sequence +crlf+ stream)
(write-sequence +crlf+ stream)
(force-output stream)
(when *header-stream*
(format *header-stream* "~A~%" continue-line)))))
(values headers
(as-keyword method)
url-string
(if protocol
(as-keyword (trim-whitespace protocol))
:http/0.9))))))))