New patches: [Avoid unwinding the stack when errors occur inside dynamic hook extents eslick@media.mit.edu**20080611092203] { hunk ./src/request-handler.lisp 143 - (handler-case (progn - (mapstores #'begin-transaction) - (eval-dynamic-hooks hooks)) - (error (err) (progn - (mapstores #'rollback-transaction) - (setf tx-error-occurred-p t) - (error err)))) + (handler-bind ((error #'(lambda (error) + (declare (ignore error)) + (mapstores #'rollback-transaction) + (setf tx-error-occurred-p t)))) + (mapstores #'begin-transaction) + (eval-dynamic-hooks hooks)) hunk ./src/store/elephant/elephant.lisp 119 - (setf action-list (delete 'elephant-transaction-hook action-list)) - (setf render-list (delete 'elephant-transaction-hook render-list)))) + (setf action-list (delete 'elephant-transaction-hook action-list)))) +;; (setf render-list (delete 'elephant-transaction-hook render-list)))) } [Multiple webapp support v0.9 eslick@media.mit.edu**20080702143739] { hunk ./src/actions.lisp 44 - (setf (session-value action-code) action-fn) + (setf (webapp-session-value action-code) action-fn) hunk ./src/actions.lisp 55 - (session-value function-or-action) + (webapp-session-value function-or-action) + (declare (ignore res)) hunk ./src/actions.lisp 91 - (setf request-action (session-value action-name)) + (setf request-action (webapp-session-value action-name)) hunk ./src/application.lisp 4 -(export '(*webapp-description* *application-dependencies* defwebapp)) +(export '(defwebapp start-webapp stop-webapp restart-webapp get-webapp + get-webapps-for-class initialize-webapp finalize-webapp + webapp-application-dependencies webapp-name webapp-description webapp-prefix + running-webapp make-webapp-uri reset-webapp-session webapp-session-value)) hunk ./src/application.lisp 9 -(defvar *webapp-name* nil - "The name of the web application (also see 'defwebapp'). Please -note, this name will be used for the composition of the page title -displayed to the user. See 'page-title' for details.") +(defvar *registered-webapps* nil + "A list of applications that the system knows about") hunk ./src/application.lisp 12 -(defvar *webapp-description* nil - "The description of the web application. Please note, this -description will be used for the composition of the page title -displayed to the user. See 'page-title' for details.") +(defclass weblocks-webapp () + ((name :accessor weblocks-webapp-name :initarg :name :initform nil :type string) + (description :accessor weblocks-webapp-description :initarg :description + :initform nil :type (or null string) + :documentation "The name of the application. This slot will be used + by 'page-title' to generate the default title for each page.") + (public-files-path :accessor weblocks-webapp-public-app-path :initarg :public-app-path + :initform nil + :documentation "The directory path for public files") + (prefix :accessor weblocks-webapp-prefix :initarg :prefix :initform "" :type string + :documentation "The default dispatch will allow a webapp to be invoked + as a subtree of the URI space at this site. This does not support + webapp dispatch on virtual hosts, browser types, etc.") + (application-dependencies :accessor weblocks-webapp-application-dependencies + :initarg :application-dependencies :initform nil :type list + :documentation "The public dependencies for all pages rendered by this + application. The automatic dependencies system will handle all of + the context or request specific dependencies.") + (init-user-session :accessor weblocks-webapp-init-user-session :initarg :init-user-session + :initform nil :type symbol + :documentation "'init-user-session' must be defined by weblocks client in the + same package as 'name'. This function will accept a single parameter - a + composite widget at the root of the application. 'init-user-session' is + responsible for adding initial widgets to this composite.") + (debug :accessor weblocks-webapp-debug :initarg :debug :initform nil)) + (:documentation +"A class that encapsulates a unique web application and all relevant resources. +A webapp is a unique set of dependencies and information that can be enabled or +disabled independently of others. Multiple webapps can be active concurrently +and incoming connections are dispatched to the root of the webapp according to a +prefix parameter that defines the URLs parsed by that webapp. The webapp does +not see the prefix parameter in URLs that are provided to it. You can, for +instance, have different sites (e.g. mobile vs. desktop) with vastly different +layout and dependencies running on the same server.")) hunk ./src/application.lisp 47 -(defvar *application-dependencies* nil - "A list of dependencies on scripts and/or stylesheets that will -persist throughout the whole application. See documentation for -'dependency' or the 'dependencies' generic function for more details.") hunk ./src/application.lisp 48 -(defun defwebapp (name &key description dependencies) - "Sets the application name (the *webapp-name* variable). 'name' -must be a symbol. This symbol will later be used to find a -package that defined 'init-user-session' - a function responsible -for the web application setup. +(defmacro defwebapp (name &key + subclasses + slots + description + (prefix (concatenate 'string "/" (attributize-name name))) + ignore-default-dependencies + dependencies + public-app-path + (init-user-session (find-symbol (symbol-name '#:init-user-session) + (symbol-package name))) + (autostart t)) + "This macro defines the key parameters for a stand alone web application. +It defines both a class with name 'name' and registers an instance of that class. +It also instantiates a defvar with an instance of this class. This is intended +to be the primary way a web application is defined. hunk ./src/application.lisp 64 -Additionally, 'name' will be used by 'page-title' to generate the -title of each page. +:subclasses - if you want to inherit subclass behvior from other webapps, you +can. It's not likely to be needed much hunk ./src/application.lisp 67 -'init-user-session' must be defined by weblocks client in the -same package as 'name'. This function will accept a single -parameter - a composite widget at the root of the -application. 'init-user-session' is responsible for adding -initial widgets to this composite. +:slots - webapps are class so slots are a list of definitions just as in defclass, +but as slots are likely to be rare on webapps, we make this a keyword argument. hunk ./src/application.lisp 70 -'description' is a short description of the web application (ex: \"A -technology demonstration\"). *webapp-description* will be set to this -description (unless description is nil), and the value will later be -used by 'page-title' to generate the page titles. +:name - instantiates a username (and the default title for) a webapp. use this +name to get and delete this webapp. Multiple instances of a webapp class can +co-exist, so long as they have different prefixes hunk ./src/application.lisp 74 -By default 'defwebapp' adds the following resources to -*application-dependencies*: +:description - A description of the application for the title page + +:ignore-default-dependencies inhibits appending the default dependencies to +the dependencies list. By default 'defwebapp' adds the following resources: + + Stylesheets: layout.css, main.css + Scripts: prototype.js, weblocks.js, scriptaculous.js + +:dependencies - is a list of dependencies to append to the default dependencies +list of the application. + +:public-app-path - The pathname for the public files for this application. +The URL will be relative to the object prefix. So a path of /home/user/webapp/my-pub +would result in a URL http://mysite.com/mypub-prefix/pub/scripts/wow.js to map to +/home/user/webapp/my-pub/scripts/wow.js. Alternatively you can choose to accept +the global default by assigning nil or :system-default to this slot. The default +initform for this argument assumes that a /pub directory exists relative to +the system which has a name matching the current package. This may be a bogus +assumption, so best to assign this parameter explicitly. + +:init-user-session - This is a symbol that is used to find a function to initialize +new user sessions. + +:autostart - Whether this webapp is started automatically when start-weblocks is +called (primarily for backward compatibility" + `(progn + (defclass ,name ,(append subclasses (list 'weblocks-webapp)) + ,slots + (:default-initargs + :name (attributize-name ',name) + :description ,description + :public-app-path (let ((path ,public-app-path)) + (if (or (null path) (eq path :system-default)) + nil + (compute-public-files-path + (intern (package-name ,*package*) :keyword)))) + :init-user-session ,init-user-session + :prefix ,prefix + :application-dependencies + (append ,(when (not ignore-default-dependencies) + `(build-local-dependencies + '((:stylesheet "layout") + (:stylesheet "main") + (:stylesheet "dialog") + (:script "prototype") + (:script "scriptaculous") + (:script "shortcut") + (:script "weblocks") + (:script "dialog")))) + (build-local-dependencies ,dependencies)))) + (pushnew ',name *registered-webapps*) + (when ,autostart + (pushnew ',name *autostarting-webapps*)) + t)) + +(defun get-webapp (name &optional (error-p t)) + "Get a running web application" + (let ((app (find (attributize-name name) *active-webapps* + :key #'weblocks-webapp-name :test #'equal))) + (if app app + (when error-p + (error "Argument ~a is not a running weblocks application." name))))) + +(defun get-webapps-for-class (name) + (let ((class (or (find-class name nil) (find-class (intern name :keyword) nil)))) + (when class + (loop for app in *active-webapps* + when (eq (class-of app) class) + collect app)))) + + +(defun check-webapp (name) + "Ensure that the we have a valid webapp class" + (unless (find-class name nil) + (error "~a is not a valid weblocks application class." name))) + +(defun start-webapp (class &rest initargs &key name &allow-other-keys) + "Starts the web application" + (check-webapp class) + (unless name + (setq name (attributize-name class))) + (let ((app (get-webapp name nil))) + (when app + (warn "An instance of ~A with name ~A is already running, ignoring start request" + class name) + (return-from start-webapp)) + (setq app (apply #'make-instance class + (append (list :name name) + (remove-keyword-parameter initargs :name)))) + (initialize-webapp app) + (enable-webapp app) + app)) + +(defun enable-webapp (app) + "Make sure the app with the \"\" prefix is always the last one and that there + is only one!" + (setf *active-webapps* + (sort (pushnew app *active-webapps*) + #'string> + :key #'weblocks-webapp-prefix)) + (when (> 1 (count "" (mapcar #'weblocks-webapp-prefix *active-webapps* ) :test #'equal)) + (error "Cannot have two defaults dispatchers with prefix \"\""))) + +(defgeneric initialize-webapp (app) + (:documentation "A protocol for performing any special initialization on the creation of a webapp object.") + (:method ((app t)) nil)) + +(defmethod initialize-webapp :before ((app weblocks-webapp)) + "Ensure that all registered stores are open" + (start-weblocks) + (open-stores)) + +(defmethod initialize-webapp :after ((app weblocks-webapp)) + "Setup per-webapp debugging support for toolbar rendering" + (flet ((compute-debug-dependencies () + (append (list (make-local-dependency :script "weblocks-debug")) + (dependencies "debug-toolbar")))) + (cond ((weblocks-webapp-debug app) + (enable-global-debugging) + (setf (weblocks-webapp-application-dependencies app) + (compact-dependencies + (append + (weblocks-webapp-application-dependencies app) + (compute-debug-dependencies))))) + (t + (let ((debug-deps (compute-debug-dependencies))) + (setf (weblocks-webapp-application-dependencies app) + (remove-if (lambda (dep) + (member dep debug-deps :test #'dependencies-equalp)) + (weblocks-webapp-application-dependencies app)))))))) + +(defun stop-webapp (name) + "Stops the web application" + (let ((app (find-app name))) + (setf *active-webapps* (delete app *active-webapps*)) + (finalize-webapp app))) + +(defgeneric finalize-webapp (app) + (:documentation "Called when the app has been pulled off the running list to perform any + webapp specific cleanup") + (:method ((app t)) nil)) + +(defmethod finalize-webapp :after ((app weblocks-webapp)) + "When all webapps are shut down, close any open stores and stop the weblocks server" + (when (null *active-webapps*) + (close-stores) + (stop-weblocks))) + +(defun find-app (name) + (let ((app (get-webapp name nil)) + (apps (get-webapps-for-class name))) + (when (not app) + (if (eq (length apps) 1) + (setf app (first apps)) + (error "App name ~A not found or no instances of class ~A found" name name))) + app)) + +(defun restart-webapp (name) + (let* ((app (find-app name)) + (class (class-of app)) + (name (weblocks-webapp-name app))) + (stop-webapp name) + (start-webapp class :name name))) + +;; +;; These procedures are relative to the current request's selected webapp +;; + +(defun current-webapp () + "Returns the currently invoked instance of a web application." + (declare (special *current-webapp*)) + *current-webapp*) + +(defun reset-webapp-session (&optional (app (current-webapp))) + "Reset sessions on a per-webapp basis" + (setf (webapp-session-value app) nil)) + +(defun webapp-application-dependencies (&optional (app (current-webapp))) + "Returns a list of dependencies on scripts and/or stylesheets that + will persist throughout the whole application. See documentation for + 'widget-application-dependencies' for more details." + (weblocks-webapp-application-dependencies app)) + +(defun webapp-name (&optional (app (current-webapp))) + "Returns the name of the web application (also see 'defwebapp'). Please + note, this name will be used for the composition of the page title + displayed to the user. See 'page-title' for details." + (weblocks-webapp-name app)) + +(defun webapp-description (&optional (app (current-webapp))) + "Returns the description of the web application. Please note, this + description will be used for the composition of the page title + displayed to the user. See 'page-title' for details." + (weblocks-webapp-description app)) + +(defun webapp-prefix (&optional (app (current-webapp))) + "Returns the URL prefix of the application." + (weblocks-webapp-prefix app)) + +(defun webapp-init-user-session (&optional (app (current-webapp))) + "Returns the init function for the user session." + (symbol-function (weblocks-webapp-init-user-session app))) + +(defun make-webapp-uri (uri &optional (app (current-webapp))) + (concatenate 'string (webapp-prefix app) uri)) + +(defun webapp-session-value (symbol) + "Get a session value from the currently running webapp" + (declare (special *current-webapp*)) + (let ((webapp-session (session-value *current-webapp*))) + (when webapp-session + (gethash symbol webapp-session)))) + +(defun (setf webapp-session-value) (value symbol) + "Set a session value for the currently runnin webapp" + (declare (special *current-webapp*)) + (let ((webapp-session (session-value *current-webapp*))) + (unless webapp-session + (setf webapp-session (make-hash-table :test 'equal) + (session-value *current-webapp*) webapp-session)) + (setf (gethash symbol webapp-session) value))) hunk ./src/application.lisp 296 -Stylesheets: layout.css, main.css -Scripts: prototype.js, weblocks.js, scriptaculous.js" - (check-type name symbol) - (setf *webapp-name* name) - (when description - (setf *webapp-description* description)) - (setf *application-dependencies* - (append (mapcar (curry #'apply #'make-local-dependency) - '((:stylesheet "layout") - (:stylesheet "main") - (:stylesheet "dialog") - (:script "prototype") - (:script "scriptaculous") - (:script "shortcut") - (:script "weblocks") - (:script "dialog"))) - dependencies))) hunk ./src/control-flow/dialog.lisp 15 - `(session-value 'dialog-contents)) + `(webapp-session-value 'dialog-contents)) hunk ./src/debug-mode.lisp 4 +(export '(disable-global-debugging enable-global-debugging)) + +(defun enable-global-debugging () + "Setup hooks for session maintenance and showing backtraces" + ;; Set hunchentoot defaults (for everyone) + (setf *show-lisp-errors-p* t) + (setf *show-lisp-backtraces-p* t) + ;; Set session maintenance (for everyone) + (unless *maintain-last-session* + (setf *maintain-last-session* + (hunchentoot-mp:make-lock "*maintain-last-session*")))) + +(defun disable-global-debugging () + "A manual method for resetting global debugging state" + (setf *show-lisp-errors-p* nil) + (setf *show-lisp-backtraces-p* nil) + (setf *maintain-last-session* nil)) + hunk ./src/debug-mode.lisp 29 - (:img :src "/pub/images/reset.png" + (:img :src (make-webapp-uri "/pub/images/reset.png") hunk ./src/debug-mode.lisp 37 + (declare (ignore args)) hunk ./src/debug-mode.lisp 39 - (redirect "/")) + (redirect (make-webapp-uri "/"))) hunk ./src/debug-mode.lisp 42 + hunk ./src/default-application.lisp 4 -(unless (and *webapp-name* - (find-symbol (symbol-name '#:init-user-session) - (symbol-package *webapp-name*))) +(defwebapp weblocks-default + :description "A default welcome application for weblocks" + :init-user-session init-user-session + :prefix "" + :autostart nil) hunk ./src/default-application.lisp 10 - (defwebapp 'weblocks) +(defmethod render-page-body :after ((app weblocks-default) rendered-html) + (with-html + (:div :class "footer" + (:p "Running on " + (str (concatenate + 'string (server-type) " " (server-version))) + " (" (str (concatenate 'string (lisp-implementation-type) " " + (lisp-implementation-version))) ")") + (:img :src (make-webapp-uri "/pub/images/footer/valid-xhtml11.png") :alt "This site has valid XHTML 1.1.") + (:img :src (make-webapp-uri "/pub/images/footer/valid-css.png") :alt "This site has valid CSS.")))) hunk ./src/default-application.lisp 21 - (defmethod render-page-body :after (rendered-html) - (with-html - (:div :class "footer" - (:p "Running on " - (str (concatenate - 'string (server-type) " " (server-version))) - " (" (str (concatenate 'string (lisp-implementation-type) " " - (lisp-implementation-version))) ")") - (:img :src "/pub/images/footer/valid-xhtml11.png" :alt "This site has valid XHTML 1.1.") - (:img :src "/pub/images/footer/valid-css.png" :alt "This site has valid CSS.")))) - - (defun init-user-session (comp) - (setf (composite-widgets comp) - (list - (lambda (&rest args) - (with-html - (:div :class "header" - (with-extra-tags)) - (:h1 "Welcome to " (:em "Weblocks!")) - (:p "To learn more on how to get started +(defun init-user-session (comp) + (setf (composite-widgets comp) + (list + (lambda (&rest args) + (declare (ignore args)) + (with-html + (:div :class "header" + (with-extra-tags)) + (:h1 "Welcome to " (:em "Weblocks!")) + (:p "To learn more on how to get started hunk ./src/default-application.lisp 38 - (:p (:em "Happy hacking!"))))))) -) ; unless + (:p (:em "Happy hacking!"))))))) + hunk ./src/dependencies.lisp 11 - compact-dependencies)) + compact-dependencies build-local-dependencies)) hunk ./src/dependencies.lisp 36 +(defparameter *page-public-dependencies* nil) + hunk ./src/dependencies.lisp 165 - (let ((full-path (merge-pathnames (public-file-relative-path type file-name) - (make-pathname :directory '(:absolute "pub"))))) + (let ((full-path +;; (concatenate 'string (webapp-prefix) "/" + (merge-pathnames (public-file-relative-path type file-name) + (make-pathname :directory '(:absolute "pub"))))) hunk ./src/dependencies.lisp 174 +(defun build-local-dependencies (dep-list) + (loop for dep in dep-list collect + (unless (subtypep (type-of dep) 'dependency) + (assert (and (consp dep) (member (first dep) '(:stylesheet :script)))) + (destructuring-bind (type file-name) dep + (make-local-dependency type file-name))))) hunk ./src/page-template.lisp 6 -(defun page-title () - "Generates a page title from the application name, application -description, and current navigation state." +;; +;; Compute the webapp page title +;; + +(defmethod page-title ((app weblocks-webapp)) + "The default page-title method generates a page title from the + application name, application description, and current navigation state." hunk ./src/page-template.lisp 14 - (apply #'concatenate 'string (humanize-name *webapp-name*) - (cond - (*current-page-description* (list " - " *current-page-description*)) - (*webapp-description* (list " - " *webapp-description*))))) + (let ((webapp-description (webapp-description))) + (apply #'concatenate 'string (webapp-name) + (cond + (*current-page-description* (list " - " *current-page-description*)) + (webapp-description (list " - " webapp-description)))))) + +;; +;; Render the current page +;; hunk ./src/page-template.lisp 24 -(defun render-page () - "Takes the widget and application dependency information and wraps +(defgeneric render-page (app) + (:documentation "Takes the widget and application dependency information and wraps hunk ./src/page-template.lisp 27 -page HTML (title, stylesheets, etc.)." +page HTML (title, stylesheets, etc.). Can be overridden by subclasses")) + +(defmethod render-page ((app weblocks-webapp)) + "Default page rendering template and protocol" hunk ./src/page-template.lisp 33 - (declare (special *page-dependencies* *application-dependencies*)) + (declare (special *page-dependencies*)) hunk ./src/page-template.lisp 35 - (all-dependencies (compact-dependencies (append *application-dependencies* - *page-dependencies*)))) + (all-dependencies (compact-dependencies (append (webapp-application-dependencies) + *page-public-dependencies*)))) hunk ./src/page-template.lisp 40 - (:meta :http-equiv "Content-type" :content *default-content-type*) - (:title (str (page-title))) + (:title (str (page-title app))) + (render-page-headers app) hunk ./src/page-template.lisp 44 - (render-page-body rendered-html) - (when *render-debug-toolbar* + (render-page-body app rendered-html) + (when (weblocks-webapp-debug app) hunk ./src/page-template.lisp 49 -(defgeneric render-page-body (rendered-html) +;; +;; Render header entries +;; + +(defmethod render-page-headers ((app weblocks-webapp)) + "A placeholder to add :meta entries, :expires headers and other + header content on a per-webapp basis. For example, using a dynamic + hook on rendering you can bind special variables that are dereferenced + here to customize header rendering on a per-request basis. By default + this function renders the current content type." + (with-html + (:meta :http-equiv "Content-type" :content *default-content-type*))) + +;; +;; Render the page body +;; + +(defgeneric render-page-body (app rendered-html) hunk ./src/page-template.lisp 70 -methods to render extra html prior and post the page wrapper.")) +methods to render extra html prior and post the page wrapper and override +the main method to replace the generation of the page wrapper and any contents +inside it but outside the rendering of the root composite")) hunk ./src/page-template.lisp 74 -(defmethod render-page-body (body-fn) +(defmethod render-page-body ((app weblocks-webapp) body-string) + "Default page-body rendering method" hunk ./src/page-template.lisp 79 - (htm (str body-fn)) + (htm (str body-string)) hunk ./src/request-handler.lisp 7 -(defgeneric handle-client-request () +(defgeneric handle-client-request (app) hunk ./src/request-handler.lisp 37 -(defmethod handle-client-request () - (when (hunchentoot::mime-type (script-name)) - (setf (return-code) +http-not-found+) - (throw 'handler-done nil)) - (when (null *session*) - (when (get-request-action-name) - (funcall *expired-action-handler*)) - (start-session) - (setf (session-value 'last-request-uri) :none) - (redirect (request-uri))) - (when *maintain-last-session* - (hunchentoot::with-lock (*maintain-last-session*) - (setf *last-session* *session*))) - (let ((*request-hook* (make-instance 'request-hooks))) - (declare (special *request-hook*)) - (when (null (root-composite)) - (let ((root-composite (make-instance 'composite :name "root"))) - (when *render-debug-toolbar* - (initialize-debug-actions)) - (setf (root-composite) root-composite) - (funcall (symbol-function (find-symbol (symbol-name '#:init-user-session) - (symbol-package *webapp-name*))) - root-composite) - (push 'update-dialog-on-request (request-hook :session :post-action))) - (when (cookie-in *session-cookie-name*) - (redirect (remove-session-from-uri (request-uri))))) hunk ./src/request-handler.lisp 38 - (let ((*weblocks-output-stream* (make-string-output-stream)) - (*uri-tokens* (tokenize-uri (request-uri))) - (*current-navigation-url* "/") *dirty-widgets* - *on-ajax-complete-scripts* *page-dependencies* - *current-page-description*) - (declare (special *weblocks-output-stream* *current-navigation-url* *dirty-widgets* - *on-ajax-complete-scripts* *uri-tokens* *page-dependencies* - *current-page-description*)) - (when (pure-request-p) - (throw 'handler-done (eval-action))) - ; a default dynamic-action hook function wraps get operations in a transaction - (with-dynamic-hooks (:dynamic-action) - (eval-hook :pre-action) - (eval-action) - (eval-hook :post-action)) - (when (and (not (ajax-request-p)) - (find *action-string* (get-parameters) - :key #'car :test #'string-equal)) - (redirect (remove-action-from-uri (request-uri)))) - (with-dynamic-hooks (:dynamic-render) - (eval-hook :pre-render) - (if (ajax-request-p) - (progn - (setf *current-navigation-url* - (obtain-uri-from-navigation - (find-navigation-widget - (root-composite)))) - (render-dirty-widgets)) - (progn - (apply-uri-to-navigation *uri-tokens* - (find-navigation-widget (root-composite))) - ; we need to render widgets before the boilerplate HTML - ; that wraps them in order to collect a list of script and - ; stylesheet dependencies. - (render-widget (root-composite)) - ; set page title if it isn't already set - (when (and (null *current-page-description*) - (last *uri-tokens*)) - (setf *current-page-description* (humanize-name (url-decode (last-item *uri-tokens*))))) - ; render page will wrap the HTML already rendered to - ; *weblocks-output-stream* with necessary boilerplate HTML - (render-page))) - (eval-hook :post-render)) - (unless (ajax-request-p) - (setf (session-value 'last-request-uri) *uri-tokens*)) - (get-output-stream-string *weblocks-output-stream*)))) +(defmethod handle-client-request (app) + (let ((*current-webapp* app)) + (declare (special *current-webapp*)) + (when (hunchentoot::mime-type (script-name)) + (setf (return-code) +http-not-found+) + (throw 'handler-done nil)) + (when (null *session*) + (when (get-request-action-name) + (funcall *expired-action-handler*)) + (start-session) + (setf (webapp-session-value 'last-request-uri) :none) + (redirect (request-uri))) + (when *maintain-last-session* + (hunchentoot::with-lock (*maintain-last-session*) + (setf *last-session* *session*))) + (let ((*request-hook* (make-instance 'request-hooks))) + (declare (special *request-hook*)) + (when (null (root-composite)) + (let ((root-composite (make-instance 'composite :name "root"))) + (when (weblocks-webapp-debug app) + (initialize-debug-actions)) + (setf (root-composite) root-composite) + (funcall (webapp-init-user-session) root-composite) + (push 'update-dialog-on-request (request-hook :session :post-action))) + (when (cookie-in *session-cookie-name*) + (redirect (remove-session-from-uri (request-uri))))) + + (let ((*weblocks-output-stream* (make-string-output-stream)) + (*uri-tokens* (tokenize-uri (request-uri))) + (*current-navigation-url* "/") *dirty-widgets* + *on-ajax-complete-scripts* *page-public-dependencies* + *current-page-description*) + (declare (special *weblocks-output-stream* *current-navigation-url* *dirty-widgets* + *on-ajax-complete-scripts* *uri-tokens* *page-public-dependencies* + *current-page-description*)) + (when (pure-request-p) + (throw 'handler-done (eval-action))) + + (with-dynamic-hooks (:dynamic-action) + (eval-hook :pre-action) + (eval-action) + (eval-hook :post-action)) + (when (and (not (ajax-request-p)) + (find *action-string* (get-parameters) + :key #'car :test #'string-equal)) + (redirect (remove-action-from-uri (request-uri)))) + (with-dynamic-hooks (:dynamic-render) + (eval-hook :pre-render) + (if (ajax-request-p) + (progn + (setf *current-navigation-url* + (obtain-uri-from-navigation + (find-navigation-widget + (root-composite)))) + (render-dirty-widgets)) + (progn + (apply-uri-to-navigation *uri-tokens* + (find-navigation-widget (root-composite))) + ; we need to render widgets before the boilerplate HTML + ; that wraps them in order to collect a list of script and + ; stylesheet dependencies. + (render-widget (root-composite)) + ; set page title if it isn't already set + (when (and (null *current-page-description*) + (last *uri-tokens*)) + (setf *current-page-description* (humanize-name (last-item *uri-tokens*)))) + ; render page will wrap the HTML already rendered to + ; *weblocks-output-stream* with necessary boilerplate HTML + (render-page app))) + (eval-hook :post-render)) + (unless (ajax-request-p) + (setf (webapp-session-value 'last-request-uri) *uri-tokens*)) + (get-output-stream-string *weblocks-output-stream*))))) hunk ./src/request-hooks.lisp 39 - (if (session-value 'request-hooks) - (session-value 'request-hooks) - (setf (session-value 'request-hooks) + (if (webapp-session-value 'request-hooks) + (webapp-session-value 'request-hooks) + (setf (webapp-session-value 'request-hooks) hunk ./src/request.lisp 17 - (equalp *uri-tokens* (session-value 'last-request-uri)))) + (equalp *uri-tokens* (webapp-session-value 'last-request-uri)))) hunk ./src/request.lisp 21 - (equalp (session-value 'last-request-uri) :none)) + (equalp (webapp-session-value 'last-request-uri) :none)) hunk ./src/server.lisp 5 - compute-public-files-path *public-files-path* server-type - server-version active-sessions)) + compute-public-files-path server-type + server-version active-sessions + set-weblocks-default-public-files-path weblocks-default-public-files-path)) hunk ./src/server.lisp 37 - (if debug - (setf *render-debug-toolbar* t - *maintain-last-session* (hunchentoot-mp:make-lock "*maintain-last-session*")) - (setf *render-debug-toolbar* nil - *maintain-last-session* nil)) - (when debug - (setf *show-lisp-errors-p* t) - (setf *show-lisp-backtraces-p* t)) - (open-stores) - (when *render-debug-toolbar* - (setf *application-dependencies* - (append *application-dependencies* - (dependencies "debug-toolbar") - (list (make-local-dependency :script "weblocks-debug"))))) hunk ./src/server.lisp 41 - (remove-keyword-parameter - (remove-keyword-parameter keys :port) :debug))))) + (remove-keyword-parameter keys :port))) + (dolist (class *autostarting-webapps*) + (unless (get-webapps-for-class class) + (start-webapp class :debug debug))))) hunk ./src/server.lisp 48 - (if (not (null *weblocks-server*)) - (progn - (setf *last-session* nil) - (reset-sessions) - (stop-server *weblocks-server*) - (setf *weblocks-server* nil))) - (close-stores)) + (when (not (null *weblocks-server*)) + (dolist (app *active-webapps*) + (stop-webapp (weblocks-webapp-name app))) + (setf *last-session* nil) + (reset-sessions) + (stop-server *weblocks-server*) + (setf *weblocks-server* nil))) hunk ./src/server.lisp 71 -(setf *dispatch-table* - (append (list (lambda (request) +(defun set-weblocks-default-public-files-path (path) + (setf *public-files-path* path)) + +(defun weblocks-default-public-files-path () + *public-files-path*) + +(defun weblocks-dispatcher (request) + "Dispatcher function suitable for inclusion into hunchentooth dispatch table. +The function serves all started applications" + (flet ((is-prefix-of (string prefix) + (let ((mismatch (mismatch string prefix))) + (or (null mismatch) + (>= mismatch (length prefix)))))) + (dolist (app *active-webapps*) + (let* ((script-name (script-name request)) + (app-prefix (webapp-prefix app)) + (app-pub-prefix (concatenate 'string app-prefix "/pub/"))) + (log-message :debug "App Dispatch '~A' '~A' '~A'" script-name app-prefix app-pub-prefix) + (cond + ((is-prefix-of script-name app-pub-prefix) + (return-from weblocks-dispatcher + (funcall (create-folder-dispatcher-and-handler + app-pub-prefix + (or (weblocks-webapp-public-app-path app) *public-files-path*)) + request))) + ((is-prefix-of script-name app-prefix) + (return-from weblocks-dispatcher + #'(lambda () + (handle-client-request app))))))) + (log-message :debug "App Not Found ~A" (script-name request)))) + +;; install weblocks-dispatcher + +(eval-when (:load-toplevel) + (progn + (let ((pos (position 'weblocks-dispatcher *dispatch-table*))) + (if pos + (rplaca (nthcdr (1- pos) *dispatch-table*) + #'(lambda (request) hunk ./src/server.lisp 111 - request)) - (create-prefix-dispatcher "/" 'handle-client-request)) - *dispatch-table*)) + request))) + (setf *dispatch-table* + (append + (list + ;; CSS files that are served from webapp specific directories have dependencies + ;; on images in "/pub". I am not sure how to dynamically adjusts references in + ;; CSS files. + #'(lambda (request) + (funcall (create-folder-dispatcher-and-handler "/pub/" *public-files-path*) + request)) + 'weblocks-dispatcher) + *dispatch-table*)))))) hunk ./src/server.lisp 148 + hunk ./src/snippets/suggest.lisp 61 + (declare (ignore keys)) hunk ./src/utils/misc.lisp 214 - (cl-ppcre:split "[/\\\\]" (cl-ppcre:regex-replace "\\?.*" uri "")))) + (cl-ppcre:split "[/\\\\]" + (cl-ppcre:regex-replace "\\?.*" + (subseq uri (length (webapp-prefix))) + "")))) hunk ./src/utils/misc.lisp 260 - (apply #'concatenate 'string "/" (intersperse *uri-tokens* "/"))) + (apply #'concatenate 'string (webapp-prefix) "/" (intersperse *uri-tokens* "/"))) hunk ./src/views/view/utils.lisp 178 -the returned items to *page-dependencies*. This is later used by +the returned items to *page-public-dependencies*. This is later used by hunk ./src/views/view/utils.lisp 181 - (declare (special *page-dependencies*)) - (setf *page-dependencies* - (append *page-dependencies* (dependencies (find-view view)))) + (declare (special *page-public-dependencies*)) + (setf *page-public-dependencies* + (append *page-public-dependencies* (dependencies (find-view view)))) hunk ./src/weblocks.lisp 30 -(defparameter *render-debug-toolbar* nil - "A global flag that defines whether the debug toolbar should be - rendered. Normally set to true when weblocks is started in debug - mode.") - hunk ./src/weblocks.lisp 35 +(defvar *autostarting-webapps* nil + "A list of webapps to start when start-weblocks is called") + +(defvar *active-webapps* nil + "A list of running applications. Applications are only available + after they have been started.") + hunk ./src/weblocks.lisp 59 - `(session-value 'root-composite)) + `(webapp-session-value 'root-composite)) hunk ./src/widgets/widget/widget-mop.lisp 36 - (find-class 'widget-direct-slot-definition)) + (declare (ignore initargs)) + (find-class 'widget-direct-slot-definition)) hunk ./src/widgets/widget/widget-mop.lisp 46 + (declare (ignore initargs)) hunk ./src/widgets/widget/widget-mop.lisp 50 + (declare (ignore slot-name)) hunk ./src/widgets/widget/widget.lisp 171 -*page-dependencies*. This is later used by Weblocks to declare +*page-public-dependencies*. This is later used by Weblocks to declare hunk ./src/widgets/widget/widget.lisp 173 - (declare (special *page-dependencies*)) - (setf *page-dependencies* - (append *page-dependencies* (dependencies obj))) + (declare (special *page-public-dependencies*)) + (setf *page-public-dependencies* + (append *page-public-dependencies* (dependencies obj))) hunk ./src/widgets/widget/widget.lisp 251 -(defun find-widget-by-path (path &optional (root (session-value 'root-composite))) +(defun find-widget-by-path (path &optional (root (webapp-session-value 'root-composite))) hunk ./weblocks.asd 40 - "request" store)) + "request" "dependencies" store)) } Context: [missing whitespace in dom-classes caused invalid css class strings to be generated Jan Rychter **20080706103029] [Match metatilities-base interface change in the clsql store Jan Rychter **20080705113243 Original patch from Ben Mackay : I have created a patch to fix this issue in the "clsql oddities" portion of ./src/store/clsql/clsql.lisp. ] [introduce dom-object-mixin and a uniform dom-id generation scheme Jan Rychter **20080625173213] [fix (authenticatedp) to work according to its documentation Jan Rychter **20080529110525] [eliminate superfluous attributize-name Jan Rychter **20080517095029] [Resolve parallel proxy patch conflict eslick@media.mit.edu**20080703113754] [Set proxy-oid slot after making associated persistent object. rme@clozure.com**20080703070624] [Add dependency for proxy.lisp rme@clozure.com**20080703031709] [Fix for duplicate persist-object calls eslick@media.mit.edu**20080702135506] [Support for quickforms using the elephant proxy mechanism eslick@media.mit.edu**20080702075720] [Fixed warning in elephant store eslick@media.mit.edu**20080626094906] [add json-function, make use of it in all places, replacing strings with parenscript as we go Jan Rychter **20080624105046] [new dependencies subsystem Jan Rychter **20080624103939] [implement view validators (:satisfies for views) Jan Rychter **20080622104507] [Predicates supplied as :satisfies parameters in views may now return error messages. Jan Rychter **20080622104550] [Kill *invalid-input-message*, make parsers generate the full error message, fix documentation and tests Jan Rychter **20080529103311] [add an :extra-submit-code parameter to with-html-form Jan Rychter **20080624100340] [CONTRIB: removed spurious notice in integer-range.lisp; added NUMBER-RANGE presentation and parser. polzer@gnu.org**20080620180620] [Match metatilities-base interface change. Stephen Compall **20080620025442] [CONTRIB: added INTEGER-RANGE presentation/parser polzer@gnu.org**20080619153857] [CONTRIB: added example for TabView, Panel, Resize. polzer@gnu.org**20080619100932] [CONTRIB: fixed dual password parser polzer@gnu.org**20080619075108] [added user contributions (YUI, lpolzer) polzer@gnu.org**20080617094946] [Making dataedit-drilldown-action a generic function coffeemug@gmail.com**20080613043156] [Export WIDGET-DOM-ID for user code. polzer@gnu.org**20080612081721] [Fixing resetting of gen-id in test suite coffeemug@gmail.com**20080612053431] [Added WIDGET-DOM-ID to generate consistent IDs across JS and CSS code. polzer@gnu.org**20080611174936] [Removed spurious (BREAK) in login widget code. polzer@gnu.org**20080611174852] [GEN-ID: accept an optional prefix akin to GENSYM's interface polzer@gnu.org**20080610112314] [Only provide a default webapp if the user hasn't installed her own, yet. polzer@gnu.org**20080528115243] [DEFPARAMETER->DEFVAR in server.lisp:*public-files-path* polzer@gnu.org**20080528114847] [Elephant efficiency improvements, support for standard classes, fix some bugs eslick@media.mit.edu**20080603085407] [Removing filter-related code from elephant store coffeemug@gmail.com**20080513161752] [Refactoring of request-handler.lisp to support dynamic hooks; chaupdated elephant store to use the facility; fixed two test setup issues eslick@media.mit.edu**20080513040153] [Add elephant test, demo and fix bugs in transaction handling (mp safe now I hope) eslick@media.mit.edu**20080512191859] [Rename slot for clairty; fix object deletion bug eslick@media.mit.edu**20080512120712] [Fix aif bug in elephant proxy eslick@media.mit.edu**20080511121207] [Elephant store with proxy support eslick@media.mit.edu**20080511120611] [Added an elephant store eslick@media.mit.edu**20080510182614] [Refactored client-side initiateAction*. Extended WITH-HTML-FORM to let the user choose the JS submission function. polzer@gnu.org**20080506155445] [Fixing find-slot-dsd to work for multiple inheritance coffeemug@gmail.com**20080505232653] [Fixing an issue with encoded titles coffeemug@gmail.com**20080504180452] [Login widget should focus on first input field by default coffeemug@gmail.com**20080501003612] [Adding support for focusing form elements coffeemug@gmail.com**20080501003145] [Replacing generate-widget-id with gen-id coffeemug@gmail.com**20080501002258] [Updating prototype bundled with weblocks to 1.6.0.2 coffeemug@gmail.com**20080501002237] [Adding support for width and height to image presentation coffeemug@gmail.com**20080430212415] [Improving datalist item styling (removing headers) coffeemug@gmail.com**20080430183639] [Fixing an item-id type descreptancy in dataseq select coffeemug@gmail.com**20080430044519] [Missing dataedit tests coffeemug@gmail.com**20080430035315] [Refactoring gridedit into dataedit-mixin, adding support for listedit coffeemug@gmail.com**20080430031445] [Removing manual from the docs (maintained on the wiki now) coffeemug@gmail.com**20080427052916] [Fixing new widget id scheme - ids are expected to be strings coffeemug@gmail.com**20080421181810] [Fixing unit tests related to gensym fix coffeemug@gmail.com**20080421061715] [OpenMCL changed gensym on us to only be unique accross threads. Implemented our own session-based version of widget numbering scheme coffeemug@gmail.com**20080421060530] [Making loop iteration CL compliant in snippets coffeemug@gmail.com**20080421052043] [Refactoring datagrid into dataseq and datagrid, and adding datalist widget coffeemug@gmail.com**20080421050614] [Fixing sequence access on postgres coffeemug@gmail.com**20080415010216] [Improving ajax errors debugging support (fixing on IE, fixing unit tests) coffeemug@gmail.com**20080411013513] [Providing much better handling of session timeouts and ajax errors coffeemug@gmail.com**20080410185507] [Adding user-management utilities to login widget coffeemug@gmail.com**20080402234506] [Adding support for *last-session* (in debug mode) and active-sessions coffeemug@gmail.com**20080402233204] [Specifying background for navigation (necessary with recent css changes) coffeemug@gmail.com**20080331051453] [Fixing function-designator-p to work on more implementations coffeemug@gmail.com**20080326061541] [Improving do-widget error message coffeemug@gmail.com**20080323195759] [Improving error reporting in do-widget coffeemug@gmail.com**20080323195107] [Adding login widget coffeemug@gmail.com**20080323170438] [Adding support for redirect on AJAX coffeemug@gmail.com**20080323164924] [Fixing a typo in quickform docs coffeemug@gmail.com**20080322232902] [Enhancing quickform widget to remove stale messages after successful submission coffeemug@gmail.com**20080321044425] [Adding quickform widget coffeemug@gmail.com**20080320203030] [Misplaces paren in call-answer coffeemug@gmail.com**20080320202648] [Explicit error on replacing a widget with no parent coffeemug@gmail.com**20080320202205] [Factoring class-from-view out of render-view coffeemug@gmail.com**20080320022511] [Adding support for non-field specific error messages in form views coffeemug@gmail.com**20080320021525] [Adding wiki-style navigation widget caching coffeemug@gmail.com**20080319032939] [Adding support for specifying where clause to grids coffeemug@gmail.com**20080319025529] [Fixing url-presentation docs coffeemug@gmail.com**20080319022456] [Adding support for wiki-style URLs to navigation widget coffeemug@gmail.com**20080318215543] [Refactoring navigation widget coffeemug@gmail.com**20080318205038] [Fixing request handler to act more sensibly when action throws with respect to db transactions coffeemug@gmail.com**20080318042626] [Fixing a css issue with forms coffeemug@gmail.com**20080317230351] [Adding render-form-and-button snippet coffeemug@gmail.com**20080317225556] [Fixing documentation typo coffeemug@gmail.com**20080317212458] [Adding support for image and url presentations coffeemug@gmail.com**20080317212410] [Fixing datagrid scratch store bug coffeemug@gmail.com**20080317200204] [Adding memory-utils-test (unused for now) coffeemug@gmail.com**20080317194255] [Adding support for scratch stores coffeemug@gmail.com**20080317194047] [Removing incorrect assumption in hash-keys test coffeemug@gmail.com**20080317052324] [Defining a default action for forms coffeemug@gmail.com**20080317052302] [Adding support for rendering views by creating objects on the fly coffeemug@gmail.com**20080317052215] [Adding support for renaming formview buttons coffeemug@gmail.com**20080316185322] [Adding support for freeform captions in the views coffeemug@gmail.com**20080315184350] [Fixing documentation for make-action coffeemug@gmail.com**20080314231638] [Fixing do-widget to mark appropriate widgets as dirty coffeemug@gmail.com**20080227205705] [Replacing defview-anon with defview () coffeemug@gmail.com**20080227191531] [Fixing an issue with do-widget that incorrectly replaces widgets in certain cases coffeemug@gmail.com**20080227184222] [Adding option not to render navigation menu coffeemug@gmail.com**20080227182826] [Prevent subclasses of parser from generating own error messages if there is a user-supplied one. Jan Rychter **20080224104234] [Fixing a typo in dropdown coffeemug@gmail.com**20080223173707] [Fixing password presentation to work on null values coffeemug@gmail.com**20080222054904] [Allowing input-presentation to be used in views other than form view coffeemug@gmail.com**20080218191350] [Adding support for ajaxless forms and form encoding type coffeemug@gmail.com**20080217201843] [Removing obsolete exports from datagrid coffeemug@gmail.com**20080217183734] [Adding support for widget-parent, making answer recursive, replacing do-place with do-widget coffeemug@gmail.com**20080216201818] [Allowing customizing data-view title coffeemug@gmail.com**20080213221243] [Adding css tyles to 'modify' and 'close' dataform links coffeemug@gmail.com**20080210064923] [Fixing outdated documentation on public paths coffeemug@gmail.com**20080209204026] [Moving do-page documentation into comments coffeemug@gmail.com**20080206222209] [Removing unnecessary initform nil that causes issues on OpenMCL coffeemug@gmail.com**20080206221959] [Cleaning up weblocks-demo snapshot coffeemug@gmail.com**20080206215248] [Adding presentation types test files coffeemug@gmail.com**20080206215025] [Specifying widget to views in dataform coffeemug@gmail.com**20080206214730] [Adding missing gridedit file coffeemug@gmail.com**20080206214522] [Replacing renderers with UI DSL, Adding CLSQL backend coffeemug@gmail.com**20080206195814] [TAG pre 0.1 coffeemug@gmail.com**20080206195804] Patch bundle hash: 0ab3a071c5e420a8838f912a5d6c79ca887c8913