[claw-cvs] r85 - trunk/main/claw/src
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Mon Sep 8 09:33:19 UTC 2008
Author: achiumenti
Date: Mon Sep 8 05:33:16 2008
New Revision: 85
Modified:
trunk/main/claw/src/connector.lisp
trunk/main/claw/src/lisplet.lisp
trunk/main/claw/src/misc.lisp
trunk/main/claw/src/packages.lisp
trunk/main/claw/src/server.lisp
trunk/main/claw/src/session-manager.lisp
Log:
CLAW redirection bugfix
Modified: trunk/main/claw/src/connector.lisp
==============================================================================
--- trunk/main/claw/src/connector.lisp (original)
+++ trunk/main/claw/src/connector.lisp Mon Sep 8 05:33:16 2008
@@ -207,10 +207,7 @@
(:documentation "Sets the outgoing Content-Length http header"))
(defclass connector (claw-service)
- ((behind-apache-p :initarg :behind-apache-p
- :accessor connector-behind-apache-p
- :documentation "Returns true if the connector is running behind apache.")
- (port :initarg :port
+ ((port :initarg :port
:accessor connector-port
:documentation "The port under which normal http requests are handled")
(sslport :initarg :sslport
@@ -218,10 +215,10 @@
:documentation "The port under which https requests are handled")
(address :initarg :address
:accessor connector-address
- :documentation "The address under which https reqhests are handled"))
+ :documentation "The address whe the connector is bound to"))
(:default-initargs :port 80 :sslport 443
- :address nil
- :behind-apache-p nil :name 'connector)
+ :address *claw-default-server-address*
+ :name 'connector)
(:documentation "CONNECTOR is an interface, so you cannot directly use it.
A Connector subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides.
To properly work a CLAWSERVER instance must be provided with a CONNECTOR implementation.
Modified: trunk/main/claw/src/lisplet.lisp
==============================================================================
--- trunk/main/claw/src/lisplet.lisp (original)
+++ trunk/main/claw/src/lisplet.lisp Mon Sep 8 05:33:16 2008
@@ -127,10 +127,11 @@
(location (lisplet-base-path lisplet)))
(unless (string= "/" (subseq location 0 1))
(setf location (concatenate 'string "/" location)))
- (setf (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
- (cons location
- lisplet)
- lisplets)))))
+ (setf (lisplet-server-address lisplet) (clawserver-address clawserver)
+ (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
+ (cons location
+ lisplet)
+ lisplets)))))
(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
(let ((lisplets (clawserver-lisplets clawserver))
@@ -195,6 +196,7 @@
(let* ((*claw-current-realm* (lisplet-realm lisplet))
(*claw-current-lisplet* lisplet)
(*claw-session* (default-session-manager-session-verify *session-manager*))
+ (*root-path* (format nil "~a~a" *server-path* (lisplet-base-path lisplet)))
(base-path (build-lisplet-location lisplet))
(uri (claw-script-name))
(welcome-page (lisplet-welcome-page lisplet)))
@@ -215,13 +217,11 @@
"Redirects a request sent through http using https"
(let* ((connector (clawserver-connector *clawserver*))
(path (or uri (claw-request-uri)))
- (port (connector-port connector))
- (sslport (connector-sslport connector)))
- (if (connector-behind-apache-p connector)
- (claw-redirect path :port *apache-https-port* :protocol :https)
- (claw-redirect path :port (or sslport port) :protocol (if sslport
- :https
- :http)))))
+ (sslport (if (claw-proxified-p)
+ (clawserver-proxy-https-port *clawserver*)
+ (connector-sslport connector))))
+ (claw-redirect path :host (claw-host-name) :port sslport
+ :protocol :https)))
(defmethod lisplet-check-authorization ((lisplet lisplet))
(let* ((connector (clawserver-connector *clawserver*))
@@ -230,7 +230,7 @@
(protected-resources (lisplet-protected-resources lisplet))
(princp (current-principal))
(login-config (current-config))
- (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet)))
+ (login-page-url (format nil "~a~a" base-path (lisplet-login-page lisplet)))
(sslport (connector-sslport connector))
(auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
(when (or (string= uri base-path) (string= uri (concatenate 'string base-path "/")))
@@ -240,22 +240,23 @@
(when (and auth-basicp (null princp))
(configuration-login login-config))
(setf princp (current-principal))
- (loop for protected-resource in protected-resources
+ (loop for protected-resource in (append (list (cons (lisplet-login-page lisplet) nil)) protected-resources)
for match = (format nil "~a/~a" base-path (car protected-resource))
for allowed-roles = (cdr protected-resource)
do
+ (progn
(when (or (starts-with-subseq match uri) (string= login-page-url uri))
(cond
- ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+ ((and princp allowed-roles (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
(setf (claw-return-code) +http-forbidden+)
(throw 'handler-done nil))
((and (null princp) auth-basicp)
(setf (claw-return-code) +http-authorization-required+
(claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
(throw 'handler-done nil))
- ((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
- (redirect-to-https login-page-url)
- (throw 'handler-done nil))
+ ((and (null princp)
+ (string-not-equal (claw-script-name) login-page-url))
+ (redirect-to-https (format nil "~a~a" *root-path* (lisplet-login-page lisplet))))
((and sslport (not (= (claw-server-port) sslport)))
- (redirect-to-https)
- (throw 'handler-done nil))))))))
+ (redirect-to-https (format nil "~a~a" *root-path* (car protected-resource)))
+ (throw 'handler-done nil)))))))))
Modified: trunk/main/claw/src/misc.lisp
==============================================================================
--- trunk/main/claw/src/misc.lisp (original)
+++ trunk/main/claw/src/misc.lisp Mon Sep 8 05:33:16 2008
@@ -75,6 +75,14 @@
"The three-character names of the twelve months - needed for cookie
date format.")
+ (defvar *root-path*
+ nil
+ "The eventually froxified lisplet path ")
+
+ (defvar *server-path*
+ nil
+ "The eventually froxified claw server path ")
+
(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
@@ -223,7 +231,7 @@
(defun claw-server-port ()
"Wrapper function around CLAWSERVER-SERVER-PORT.
Returns the IP port \(as a number) where the request came in."
- (clawserver-server-addr *clawserver*))
+ (clawserver-server-port *clawserver*))
(defun claw-user-agent ()
"Wrapper function around CLAWSERVER-USER-AGENT.
@@ -339,7 +347,7 @@
"Wrapper function around CLAWSERVER-REDIRECT.
Sends back appropriate headers to redirect the client to target \(a string)."
(clawserver-redirect *clawserver* target
- :host (or host (lisplet-server-address *claw-current-lisplet*))
+ :host (or host (claw-host-name))
:port port
:protocol protocol
:add-session-id add-session-id :code code))
@@ -392,7 +400,7 @@
(defun claw-start-session (&key max-time domain)
"Starts a session bound to the current lisplet base path"
(session-manager-start-session (clawserver-session-manager *clawserver*)
- :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*))
+ :path (format nil "~a/" *root-path*)
:max-time max-time
:domain domain))
@@ -540,3 +548,22 @@
minute
second)))
+(defun claw-host-name ()
+ "Extracts the host name from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+ (first (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-port ()
+ "Extracts the host port from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+ (second (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-protocol ()
+ "Return :HTTP or :HTTPS depending on the header HOST parameter"
+ (let ((port (parse-integer (second (split-sequence #\: (claw-header-in 'host)))))
+ (connector (clawserver-connector *clawserver*)))
+ (if (= port (connector-port connector))
+ :http
+ :https)))
+
+(defun claw-proxified-p ()
+ "Retrun a non NIL value when the request is handled by a proxy"
+ (claw-header-in 'x-forwarded-host))
\ No newline at end of file
Modified: trunk/main/claw/src/packages.lisp
==============================================================================
--- trunk/main/claw/src/packages.lisp (original)
+++ trunk/main/claw/src/packages.lisp Mon Sep 8 05:33:16 2008
@@ -56,6 +56,10 @@
#:claw-header-in
#:claw-headers-in
#:claw-authorization
+ #:claw-host-name
+ #:claw-host-port
+ #:claw-host-protocol
+ #:claw-proxified-p
#:claw-remote-addr
#:claw-remote-port
#:claw-real-remote-addr
@@ -91,7 +95,6 @@
#:claw-cookie-http-only
#:connector
- #:connector-behind-apache-p
#:connector-host
#:connector-request-method
#:connector-script-name
@@ -149,8 +152,11 @@
#:lisplet-register-resource-location
#:lisplet-protect
#:lisplet-authentication-type
+ #:lisplet-reverse-proxy-path
- #:build-lisplet-location
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;#:build-lisplet-location
+ #:*root-path*
+ #:*server-path*
;; claw-service
#:claw-service
#:claw-service-name
Modified: trunk/main/claw/src/server.lisp
==============================================================================
--- trunk/main/claw/src/server.lisp (original)
+++ trunk/main/claw/src/server.lisp Mon Sep 8 05:33:16 2008
@@ -224,11 +224,9 @@
(defgeneric (setf clawserver-sslport) (sslport clawserver)
(:documentation "Sets the claw server https port. When server is started an error will be signaled."))
-(defgeneric (setf clawserver-address) (address clawserver)
+(defgeneric clawserver-address (clawserver)
(:documentation "Binds the claw server to a specific address. When server is started an error will be signaled."))
-(defgeneric clawserver-behind-apache-p (clawserver)
- (:documentation "Returns true if the server (or better, the connector) is running behind apache."))
;;-----------------------------------------------------------------------------------------------
(defgeneric (setf clawserver-read-timeout) (read-timeout clawserver)
(:documentation "Sets the read timeout in seconds. When server is started an error will be signaled."))
@@ -250,6 +248,15 @@
((base-path :initarg :base-path
:accessor clawserver-base-path
:documentation "This slot is used to keep all server resources under a common URL")
+ (proxy-http-port :initarg :proxy-http-port
+ :accessor clawserver-proxy-http-port
+ :documentation "The port eventually used to proxify http requests")
+ (proxy-https-port :initarg :proxy-https-port
+ :accessor clawserver-proxy-https-port
+ :documentation "The port eventually used to proxify https requests")
+ (reverse-proxy-path :initarg :reverse-proxy-path
+ :accessor clawserver-reverse-proxy-path
+ :documentation "When request is sent via proxy, use this value to build absolute paths")
(connector :initarg :connector
:accessor clawserver-connector
:documentation "Reads or sets the server connector that dispatches requests and processes replies from the remote host.")
@@ -271,6 +278,9 @@
:accessor clawserver-lisplets
:documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is the lisplet"))
(:default-initargs :base-path ""
+ :proxy-http-port *apache-http-port*
+ :proxy-https-port *apache-https-port*
+ :reverse-proxy-path nil
:services (make-hash-table))
(:documentation "CLAWSERVER is built around huncentoot and has the
instructions for lisplet dispatching, so use this class to start and stop
@@ -294,6 +304,9 @@
(base-path (clawserver-base-path clawserver))
(lisplets (clawserver-lisplets clawserver))
(script-name (connector-script-name connector))
+ (*server-path* (or (when (claw-proxified-p)
+ (clawserver-reverse-proxy-path clawserver))
+ (clawserver-base-path clawserver)))
(rel-script-name)
(rel-script-name-libs)
(http-result nil))
@@ -510,14 +523,14 @@
(defmethod clawserver-redirect (clawserver target &key host port protocol add-session-id code)
(connector-redirect (clawserver-connector clawserver) target :host host :port port :protocol protocol :add-session-id add-session-id :code code))
-(defmethod clawserver-behind-apache-p ((clawserver clawserver))
- (connector-behind-apache-p (clawserver-connector clawserver)))
-
(defmethod clawserver-script-name ((clawserver clawserver))
(connector-script-name (clawserver-connector clawserver)))
+(defmethod clawserver-address ((clawserver clawserver))
+ (connector-address (clawserver-connector clawserver)))
+
(defmethod error-renderer ((clawserver clawserver) &key (error-code 404))
- (let ((request-uri (connector-request-uri (clawserver-connector clawserver)))
+ (let ((request-uri (format nil "~a/~a" *server-path* (subseq (claw-script-name) (1+ (length (clawserver-base-path clawserver))))))
(connector (clawserver-connector clawserver))
(style "body {
font-family: arial, elvetica;
Modified: trunk/main/claw/src/session-manager.lisp
==============================================================================
--- trunk/main/claw/src/session-manager.lisp (original)
+++ trunk/main/claw/src/session-manager.lisp Mon Sep 8 05:33:16 2008
@@ -283,7 +283,7 @@
(let ((cookie (make-instance 'claw-cookie
:name cookie-name
:expires (get-universal-time)
- :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*))
+ :path (format nil "~a/" *root-path*)
:domain nil
:value "")))
(setf (connector-cookie-out connector cookie-name) cookie)))
@@ -337,9 +337,18 @@
*claw-session* session))))))
(defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session)
- (let ((current-session (or session (default-session-manager-current-session session-manager))))
+ (let ((connector (clawserver-connector *clawserver*))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (current-session (or session (default-session-manager-current-session session-manager))))
(bt:with-lock-held ((default-session-manager-service-lock session-manager))
- (remhash (session-id current-session) (default-session-manager-sessions session-manager)))))
+ (remhash (session-id current-session) (default-session-manager-sessions session-manager))
+ (let ((cookie (make-instance 'claw-cookie
+ :name cookie-name
+ :expires (get-universal-time)
+ :path (format nil "~a/" *root-path*)
+ :domain nil
+ :value "")))
+ (setf (connector-cookie-out connector cookie-name) cookie)))))
(defmethod session-manager-session-value ((session-manager default-session-manager) symbol)
(let ((session (default-session-manager-current-session session-manager)))
More information about the Claw-cvs
mailing list