;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/lisplet.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. 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 :claw) (defgeneric clawserver-register-lisplet (clawserver lisplet) (:documentation "This method registers a lisplet for request dispatching - CLAWSERVER the CLAWSERVER instance - LISPLET the LISPLET instance")) (defgeneric clawserver-unregister-lisplet (clawserver lisplet) (:documentation "This method unregisters a lisplet from request dispatching - CLAWSERVER the CLAWSERVER instance - LISPLET the LISPLET instance")) (defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p) (:documentation "Registers a function into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the function - FUNCTION the function to register for dispatching - LOCATION The url location where the function will be registered (relative to the lisplet base path) keys: - :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the function as a login page")) (defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p external-format) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - PAGE-CLASS symbol name of the page that is to be registerd for dispatching - LOCATION The url location where the page will be registered (relative to the lisplet base path) keys: - :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the page as a login page - :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) (defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type external-format) (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching - LOCATION The url location where the resource will be registered (relative to the lisplet base path) - CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type - :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST - LISPLET the lisplet object")) (defgeneric lisplet-dispatch-request (lisplet) (:documentation "Dispatches the http request. - LISPLET the lisplet object")) (defgeneric lisplet-protect (lisplet location roles) (:documentation "protects all the resources that start with the given LOCATION, making them available only if the user is logged and belongs at least to one of the given roles. parameters: - LISPLET the lisplet object. - LOCATION the location that must be protected. - ROLES a string list containing all the roles allowed to acces the given location.")) (defgeneric lisplet-check-authorization (lisplet &optional request) (:documentation "Performs authentication and authorization checking. Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login.")) (defgeneric lisplet-authentication-type (lisplet) (:documentation "When there is no page or function registered into the lisplet as login page returns :BASIC, otherwise returns :FORM. parameters: - LISPLET the lisplet object.")) (defgeneric build-lisplet-location (lisplet) (:documentation "Constructs a full path prepending the lisplet base path to the given location")) (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) (let* ((error-handlers (if (current-lisplet) (lisplet-error-handlers (current-lisplet)) (make-hash-table))) (handler (gethash error-code error-handlers))) (if handler (funcall handler) (let ((error-page (make-instance 'error-page :title (format nil "Server error: ~a" error-code) :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page))))))) (defclass lisplet (i18n-aware) ((base-path :initarg :base-path :reader lisplet-base-path :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page :accessor lisplet-welcome-page :documentation "url location for the welcome page") (login-page :initarg :login-page :accessor lisplet-login-page :documentation "url location for the welcome page") (external-format :initarg :external-format :accessor lisplet-external-format :documentation "The default charset external format for resources provided by this lisplet.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") (pages :initform nil :accessor lisplet-pages :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher") (error-handlers :initform (make-hash-table) :accessor lisplet-error-handlers :documentation "An hash table where keys are http error codes and values are functions with no parameters") (protected-resources :initform nil :accessor lisplet-protected-resources :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") (redirect-protected-resources-p :initarg :redirect-protected-resources-p :accessor lisplet-redirect-protected-resources-p :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) (:default-initargs :welcome-page nil :login-page nil :external-format nil :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. It is similar, for purposes, to a JAVA servlet")) (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) (location (lisplet-base-path lisplet))) (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location (cons location #'(lambda () (progn (setf (current-realm *request*) (lisplet-realm lisplet) (current-lisplet) lisplet) (lisplet-dispatch-method lisplet)))) dispatchers))))) (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) (location (lisplet-base-path lisplet))) (remove-by-location location dispatchers))) (defmethod build-lisplet-location ((lisplet lisplet)) "Constructs a full path prepending the lisplet base path to the given location" (format nil "~a~a" (clawserver-base-path (current-server)) (lisplet-base-path lisplet))) (defmethod lisplet-authentication-type ((lisplet lisplet)) (if (lisplet-login-page lisplet) :form :basic)) (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p (setf (lisplet-welcome-page lisplet) location)) (when login-page-p (setf (lisplet-login-page lisplet) location)))) (defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p external-format) (let ((charset-external-format (or external-format (lisplet-external-format lisplet)))) (lisplet-register-function-location lisplet #'(lambda () (with-output-to-string (*standard-output*) (page-render (make-instance page-class :lisplet lisplet :url location :external-format charset-external-format)))) location :welcome-page-p welcome-page-p :login-page-p login-page-p))) (defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type external-format) (let ((pages (lisplet-pages lisplet)) (charset-external-format (or external-format (lisplet-external-format lisplet)))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location (if (directory-pathname-p resource-path) #'(lambda () (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) (unless (or (null charset-external-format) (eq (flexi-streams:external-format-name (reply-external-format)) (flexi-streams:external-format-name charset-external-format))) (setf (reply-external-format) charset-external-format)) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) (defmethod lisplet-dispatch-request ((lisplet lisplet)) (let ((dispatchers (lisplet-pages lisplet)) (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) (uri (script-name)) (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) (when (= (return-code) +http-ok+) (if (and welcome-page (string= uri base-path)) (page-render (lisplet-welcome-page lisplet)) (lisplet-dispatch-request lisplet))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) (let ((protected-resources (lisplet-protected-resources lisplet))) (setf (lisplet-protected-resources lisplet) (sort-protected-resources (pushnew-location (cons location roles) protected-resources))))) (defun redirect-to-https (server request &optional uri) "Redirects a request sent through http using https" (let ((path (or uri (request-uri request))) (port (server-port request)) (protocol :http)) #-:hunchentoot-no-ssl (when (or (clawserver-mod-lisp-p server) (clawserver-ssl-certificate-file server)) (setf protocol :https port (if (clawserver-mod-lisp-p server) *apache-https-port* (clawserver-sslport server)))) (redirect path :port port :protocol protocol))) (defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) (let* ((uri (script-name request)) (base-path (build-lisplet-location lisplet)) (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))) (server (current-server request)) (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) (setf (return-code) +http-ok+) (when login-config (when (and auth-basicp (null princp)) (configuration-login login-config)) (setf princp (current-principal)) (loop for protected-resource in protected-resources for match = (format nil "~a/~a" base-path (car protected-resource)) for allowed-roles = (cdr protected-resource) do (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))) (setf (return-code) +http-forbidden+) (throw 'handler-done nil)) ((and (null princp) auth-basicp) (setf (return-code) +http-authorization-required+ (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) (throw 'handler-done nil)) ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) (redirect-to-https server request login-page-url) (throw 'handler-done nil)) #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) (redirect-to-https server request) (throw 'handler-done nil))))))))