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)))