;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: TBNL; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/tbnl/modlisp.lisp,v 1.30 2005/03/14 21:42:30 edi Exp $
;;; Copyright (c) 2004-2005, 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 #:tbnl)
(defun write-header-line (key value)
"Accepts a KEY and a VALUE and writes them, one line at a time,
to the mod_lisp or HTTP/araneida socket stream."
(cond (*modlisp-headers*
(write-header-line/modlisp key value))
(t (write-header-line/http key value))))
(defun write-header-line/modlisp (key value)
"Accepts a KEY and a VALUE and writes them, one line at a time,
to the mod_lisp socket stream"
(write-string key *apache-stream*)
(write-char #\NewLine *apache-stream*)
;; remove line breaks which would confuse mod_lisp
(format *apache-stream* "~A"
(cl-ppcre:regex-replace-all "[\\r\\n]" value " "))
(write-char #\NewLine *apache-stream*))
(defun write-header-line/http (key value)
"Accepts a KEY and a VALUE and writes them, one line at a time,
to the http/araneida socket stream"
(if (string= "Status" key)
(format *apache-stream* "HTTP/1.0 ~A" (cl-ppcre:regex-replace-all "[\\r\\n]" value " "))
(format *apache-stream* "~A: ~A" key (cl-ppcre:regex-replace-all "[\\r\\n]" value " ")))
(write-char #\Return *apache-stream*)
(write-char #\NewLine *apache-stream*))
(defun send-output (content)
"Sends all headers and the content body to Apache/mod_lisp. Handles
the supported return codes accordingly. Called by PROCESS-APACHE-COMMAND."
(let* ((return-code (return-code *reply*))
(status-line (status-line return-code))
(head-request-p (string-equal (request-method :as-keyword nil) "HEAD")))
(unless status-line
(setq content (escape-for-html
(format nil "Unknown http return code: ~A" return-code))
return-code +http-internal-server-error+
status-line (status-line return-code)))
(unless (member return-code `(,+http-ok+ ,+http-not-modified+))
;; call error handler, if any - should return NIL if it can't
;; handle the error.
(when *http-error-handler*
(setq content (funcall *http-error-handler* return-code)))
;; handle common return codes other than 200, which weren't
;; handled by the error handler.
(unless content
(setf (content-type *reply*)
"text/html; charset=iso-8859-1"
content
(format nil "~D ~A~A
~A
~A / mod_lisp~A/~A / TBNL ~A (~A ~A) at ~A Port ~D"
return-code status-line status-line
(case return-code
((#.+http-internal-server-error+)
content)
((#.+http-moved-temporarily+ #.+http-moved-permanently+)
(format nil "The document has moved here"
(header-out "Location")))
((#.+http-authorization-required+)
"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+)
(format nil "You don't have permission to access ~A on this server."
(script-name)))
((#.+http-not-found+)
(format nil "The requested URL ~A was not found on this server."
(script-name))))
(or (header-in "server-baseversion") "Apache")
(or (header-in "modlisp-major-version") "")
(or (header-in "modlisp-version") "")
*tbnl-version*
+implementation-link+
(lisp-implementation-type)
(lisp-implementation-version)
(host *request*)
(server-port :request *request*)))))
;; start with status line
(write-header-line "Status" (format nil "~d ~a" return-code status-line))
;; if there's content write the corresponding headers
(when content
(let ((content-length (length content)))
(when (plusp content-length)
(when (starts-with-one-of-p (content-type *reply*)
*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)
content-length
(length content)))
(write-header-line "Content-Length" (format nil "~d" content-length))
(write-header-line "Lisp-Content-Length"
(cond (head-request-p "0")
(t (format nil "~d" content-length))))
(write-header-line "Content-Type" (content-type *reply*))
(write-header-line "Keep-Socket" "1")
(setf *close-apache-stream* nil))))
;; write all headers from the REPLY object
(loop for (key . value) in (headers-out *reply*)
do (write-header-line key value))
;; now the cookies
(loop for (nil . cookie) in (cookies-out *reply*)
do (write-header-line "Set-Cookie" (stringify-cookie cookie)))
;; write log messages
(loop for (log-level . message) in (reverse (log-messages *reply*))
do (write-header-line (case log-level
((:emerg) "Log-Emerg")
((:alert) "Log-Alert")
((:crit) "Log-Crit")
((:error) "Log-Error")
((:warning) "Log-Warning")
((:notice) "Log-Notice")
((:info) "Log-Info")
((:debug) "Log-Debug")
(otherwise "Log"))
message))
;; all headers sent
(cond (*modlisp-headers*
(write-string "end" *apache-stream*)
(write-char #\NewLine *apache-stream*))
(t
(write-char #\Return *apache-stream*)
(write-char #\NewLine *apache-stream*)))
;; now optional content
(cond ((or (null content)
head-request-p)
t)
((stringp content)
(write-string content *apache-stream*)
t)
#+:tbnl-bivalent-streams
((typep content 'sequence)
(ignore-errors
(write-sequence content *apache-stream*)))
(t
nil))))
(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 (script-name &key
(host (host *request*) host-provided-p)
(protocol (if (ssl-session-id *request*)
:https
:http))
(add-session-id (not (or host-provided-p
(cookie-in *session-cookie-name*))))
permanently)
"Redirects the browser to the resource SCRIPT-NAME on host
HOST. PROTOCOL must be one of the keywords :HTTP or :HTTPS. Adds a
session ID if ADD-SESSION-ID is true. If PERMANENTLY is true, a 301
request is sent to the browser, otherwise a 302."
(let ((url (format nil "~A://~A~A"
(ecase protocol
((:http) "http")
((:https) "https"))
host script-name)))
(when add-session-id
(setq url (add-cookie-value-to-url url :replace-ampersands-p nil)))
(setf (header-out "Location")
url
(return-code *reply*)
(if permanently
+http-moved-permanently+
+http-moved-temporarily+))
(throw 'tbnl-handler-done nil)))
(defun require-authorization (&optional (realm "TBNL"))
(setf (header-out "WWW-Authenticate")
(format nil "Basic realm=\"~A\"" (quote-string realm))
(return-code *reply*)
+http-authorization-required+)
(throw 'tbnl-handler-done nil))
(defun process-apache-command (command)
"Processes COMMAND as created by GET-APACHE-COMMAND using the
corresponding user funtion from *DISPATCH-TABLE*. Sets up REPLY,
REQUEST, and SESSION objects. Called by APACHE-LISTEN."
(let (*tmp-files*)
(unwind-protect
(let* ((*session* nil)
;; first create a REPLY object so we can immedetialy start
;; logging
(*reply* (debug-value *reply* (make-instance 'reply)))
(*request* (debug-value *request*
(make-instance 'request
:headers-in command)))
backtrace)
(multiple-value-bind (body error)
(catch 'tbnl-handler-done
(handler-bind ((error
(lambda (cond)
(debug-value *error* cond)
;; only generate backtrace if needed
(setq backtrace
(and (or (and *show-lisp-errors-p*
*show-lisp-backtraces-p*)
(and *log-lisp-errors-p*
*log-lisp-backtraces-p*))
(debug-value *backtrace*
(get-backtrace cond))))
(when *log-lisp-errors-p*
(log-message *lisp-errors-log-level*
"~A~:[~*~;~%~A~]"
cond
*log-lisp-backtraces-p*
backtrace))
(throw 'tbnl-handler-done
(values nil cond))))
(warning
(lambda (cond)
(debug-value *error* cond)
(when *log-lisp-warnings-p*
(log-message *lisp-warnings-log-level*
"~A~:[~*~;~%~A~]"
cond
*log-lisp-backtraces-p*
backtrace)))))
(loop for dispatcher in *dispatch-table*
for action = (funcall dispatcher *request*)
when action
return (funcall action)
finally (setf (return-code *reply*)
+http-not-found+))))
(when error
(setf (return-code *reply*)
+http-internal-server-error+))
(send-output
(debug-value *body*
(cond ((and error *show-lisp-errors-p*)
(format nil "~A~:[~*~;~%~%~A~]
"
(escape-for-html (format nil "~A" error))
*show-lisp-backtraces-p*
(escape-for-html (format nil "~A" backtrace))))
(error
"An error has occured")
(t body))))))
(loop for path in *tmp-files*
when (and (pathnamep path)
(probe-file path))
do (ignore-errors (delete-file path))))))
(defun read-http-headers ()
(let ((headers nil))
(labels ((read-header-line ()
"Read a header line, considering continuations"
(with-output-to-string (header-line)
(loop
(let* ((line (read-line *apache-stream* t nil))
(end (position #\Return line))
(next (and (> end 0) (peek-char nil *apache-stream* nil nil))))
(write-sequence line header-line :end end)
(unless (or (eql next #\Space) (eql next #\Tab)) (return))))))
(split-header (line)
(unless (or (not line) (zerop (length line)))
(destructuring-bind (key value) (cl-ppcre:split ":" line :limit 2)
(cons (nstring-capitalize key) (string-trim " " value)))))
(add-header (pair)
(let* ((existing-header (string-assoc (car pair) headers)))
(if existing-header
(rplacd (string-assoc (car pair) headers) (cdr pair))
(push pair headers)))))
(loop
(let ((pair (split-header (read-header-line))))
(unless pair (return))
(add-header pair)))
headers)))
(defun read-http-request (first-line &optional (default-port *apache-port*))
(let ((*modlisp-headers* nil))
(destructuring-bind (method url-string &optional protocol)
(cl-ppcre:split " " first-line :limit 3)
(declare (ignorable method protocol))
(let ((headers (and protocol (read-http-headers))))
(push (cons "method" method) headers)
(push (cons "url" url-string) headers)
(when protocol (push (cons "server-protocol"
(string-trim '(#\Space #\NewLine #\Return) protocol))
headers))
(push (cons "content-stream" *apache-stream*) headers)
;(push (cons "server-ip-port" (format nil "~d" default-port)) headers)
(multiple-value-bind (result code)
(ignore-errors
(process-apache-command headers)
(force-output *apache-stream*))
(declare (ignorable result))
(declare (ignorable code))
(when code (format t "Error in TBNL:: CODE ~S -- RESULT ~S~%" code result))
(setf *close-apache-stream* t)
nil)))))
(defun get-apache-command ()
"Reads alternating key/value lines and posted content \(if any) from
mod_lisp. Returns the results as an alist."
(ignore-errors
(let ((first-line (read-line *apache-stream* nil nil)))
(if (find #\Space first-line)
(read-http-request first-line)
(let ((second-line (read-line *apache-stream* nil nil)))
(let* ((headers (loop for key = (read-line *apache-stream* nil nil)
while (and key
(string-not-equal key "end"))
for value = (read-line *apache-stream* nil nil)
collect (cons key value)))
(content-length (string-assoc "content-length" headers)))
(push (cons first-line second-line) headers)
(when content-length
(push (cons "content-stream" *apache-stream*)
headers))
headers))))))
(defun apache-listen (*apache-stream* command-processor &rest args)
"Listens on *APACHE-STREAM* for commands from mod_lisp. Packages the
command using GET-APACHE-COMMAND and passes it to the
COMMAND-PROCESSOR function \(which is PROCESS-APACHE-COMMAND). ARGS
are ignored. Designed to be called by a KMRCL:LISTENER object."
(declare (ignore args))
(let ((*close-apache-stream* t))
(unwind-protect
(loop for *apache-socket-usage-counter* from 0
do (let ((command (debug-value *command* (get-apache-command))))
(ignore-errors
(when command
(cond ((ignore-errors
(funcall command-processor command))
(ignore-errors
(force-output *apache-stream*)))
(t
;; if an error occured during processing of
;; COMMAND we close this particular connection
;; to Apache
(ignore-errors
(setq *close-apache-stream* t)))))
(when *close-apache-stream* (return)))))
(ignore-errors
(kmrcl:close-active-socket *apache-stream*)))))
(defun start-tbnl ()
"Starts listening on port *APACHE-PORT* if needed. Initializes
*SESSION-SECRET* if needed. Returns the newly created or already
existing KMRCL:LISTENER object."
(unless (boundp '*session-secret*)
(reset-session-secret))
(cond ((and (boundp '*listener*)
*listener*)
(warn "The variable *LISTENER* is already bound to a true value")
*listener*)
(t
(setq *listener* (make-instance 'kmrcl:listener
:port *apache-port*
:base-name "tbnl"
:function 'apache-listen
:function-args (cons 'process-apache-command nil)
:format :text
:wait nil
:catch-errors t
:timeout nil
:number-fixed-workers nil
:remote-host-checker nil))
(kmrcl:init/listener *listener* :start))))
(defun stop-tbnl ()
"Stops the KMRCL:LISTENER object bound to *LISTENER* if it exists."
(cond ((and (boundp '*listener*)
*listener*
(typep *listener* 'kmrcl:listener))
(kmrcl:init/listener *listener* :stop)
(setq *listener* nil))
(t
(warn "The variable *LISTENER* is not bound to a
KMRCL:LISTENER object")
nil))
(values))