diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/doc/example-code.lisp ../UCW-old/ucw-core-last/ucw-core/doc/example-code.lisp *** ucw-core-last/ucw-core/doc/example-code.lisp 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/doc/example-code.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 126,136 **** (<:big (<:as-html (class-name class))) (loop ! :for slotd :in (c2mop:class-slots class) :do (<:tr (<:td (<:strong ! (dump-object-to-html (c2mop:slot-definition-name slotd)))) (<:td (dump-object-to-html ! (c2mop::slot-value-using-class class object slotd)))))))) --- 126,136 ---- (<:big (<:as-html (class-name class))) (loop ! :for slotd :in (mopp:class-slots class) :do (<:tr (<:td (<:strong ! (dump-object-to-html (mopp:slot-definition-name slotd)))) (<:td (dump-object-to-html ! (mopp::slot-value-using-class class object slotd)))))))) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/src/counter.lisp ../UCW-old/ucw-core-last/ucw-core/examples/src/counter.lisp *** ucw-core-last/ucw-core/examples/src/counter.lisp 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/src/counter.lisp 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,76 **** - ;; -*- lisp -*- - - (in-package #:ucw-user) - - ;;;; First we'll define the main component for our application. It - ;;;; will hold the current value and a boolean specifying whether we - ;;;; want to accept negative values or not. - - (defcomponent counter (tal-component) - ;; two slots, both are backtracked due to :default-backtrack. - ((value :accessor value - :initarg :value - :initform 0) - (allow-negatives :accessor allow-negatives - :initarg :allow-negatives - :initform nil)) - (:default-backtrack #'identity) - (:default-initargs :template-name "counter.tal")) - - ;;;; This action will just increment the current value of the counter. - - (defmethod/cc increment ((c counter)) - (incf (value c))) - - ;;;; This action will decrement the counter. However if the user tries - ;;;; to give the counter a negative value we ask for if they're - ;;;; sure. We present them with the option of not asking this question - ;;;; again (the :forever option). - - (defmethod/cc decrement ((self counter)) - (when (and (zerop (value self)) - (not (allow-negatives self))) - ;; the option-dialog component returns the value associated with - ;; whatever answer the user chose. - (case (call 'option-dialog - :message "Do you really want to allow negative values?" - :options '((:once-only . "Yes, but just this time.") - (:forever . "Yes, now and forever.") - (:no . "No")) - :confirm t) - (:no ;; they don't really want to decrement, do nothing. - (return-from decrement nil)) - (:forever ;; don't ask this question again - (setf (allow-negatives self) t)))) - (decf (value self))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Copyright (c) 2003-2005 Edward Marco Baringer - ;;; 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. - ;;; - ;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names - ;;; of its contributors may be used to endorse or promote products - ;;; derived from this software without specific prior written permission. - ;;; - ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - ;;; "AS IS" AND ANY EXPRESS 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 COPYRIGHT - ;;; OWNER OR CONTRIBUTORS 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. --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/src/examples.lisp ../UCW-old/ucw-core-last/ucw-core/examples/src/examples.lisp *** ucw-core-last/ucw-core/examples/src/examples.lisp 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/src/examples.lisp 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,211 **** - ;;;; -*- lisp -*- - - (in-package #:ucw-user) - - (defvar *example-server* (make-instance 'standard-server)) - - ;;;; The definiton of the example application - - (defclass example-application (static-roots-application-mixin - tal-application-mixin - standard-application) - ()) - - (defvar *wwwroot* - (merge-pathnames #P"examples/wwwroot/" - (asdf:component-pathname (asdf:find-system :ucw)))) - - (defvar *example-application* - (make-instance - 'example-application - :url-prefix "/" - :tal-generator (make-instance 'yaclml:file-system-generator - :cachep t - :root-directories (list (merge-pathnames #P"tal/" *wwwroot*))) - :debug-on-error t - :static-roots (list (cons "static/" (merge-pathnames #P"static/" *wwwroot*))))) - - ;;;; define the window component - - (defcomponent example-window (standard-window-component) - () - (:default-initargs - :title "UCW Examples" - :stylesheet (list "static/ucw.css" "static/examples.css") - :body (make-instance 'tabbed-pane - :current-component-key 'example-welcome - :contents - `((example-welcome . ,(make-instance 'example-welcome)) - (multiplication-table . ,(make-instance 'multiplication-table)) - (counter . ,(make-instance 'counter)) - (sum . ,(make-instance 'sum)) - (wiki . ,(make-instance 'wiki-viewer :page-name "WelcomePage")) - ;(file-upload-example . ,(make-instance 'file-upload-example)) - ;(timeout-cache-example . ,(make-instance 'timeout-cache-example :timeout 10)) - ;(hits-cache-example . ,(make-instance 'hits-cache-example :timeout 5)) - ))) - (:documentation "The main window component for the example application. - - This component contains the list of all the available components - and simply wraps the rendering of the current component with the - navigation bar.")) - - (defentry-point "^(index.ucw|)$" (:application *example-application* - :class regexp-dispatcher) - () - (call 'example-window)) - - - (defentry-point "mul.ucw" (:application *example-application* - :class simple-dispatcher - :with-call/cc nil - :action-options (:class 'action)) - () - (mul-table-example)) - - (defentry-point "mul-direct.ucw" (:application *example-application* - :class minimal-dispatcher - :with-call/cc nil - :action-options (:class 'action)) - () - (direct-mul-table-example)) - - (defcomponent example-welcome (html-block-element-mixin) - () - (:documentation "The first page seen by the example app. This - component does nothing other than render a litte introductory - text.") - (:render () - (<:h1 "UCW Examples") - (<:p (<:as-html "Click on a link to try a demo.")))) - - (defcomponent multiplication-table (html-block-element-mixin) - () - (:documentation "Just show a few links to mul.ucw / mul-direct.ucw") - (:render () - (<:h1 "Multiplication Table Examples") - (<:ul - (<:li (<:p (<:a :href "mul.ucw" "YACLML Multiplication table"))) - (<:li (<:p (<:a :href "direct-mul.ucw" - "Direct Stream Writing Multiplication table")))))) - - ;;;; multiplication table - - (defun mul-table-example () - (yaclml:with-yaclml-stream (html-stream (context.response *context*)) - (with-request-params (n) (context.request *context*) - (let ((n (if n - (or (parse-integer n :junk-allowed t) - 0) - 0))) - (<:html - (<:head (<:title "Multiplication table")) - (<:body - (<:a :href "index.ucw" "Go Back to Main Demo") - (<:h1 "Multiplication table upto " (<:ah n)) - (<:form :action "" :method "GET" - (<:p "N: " (<:input :type "text" :name "n") (<:input :type "submit" :value "Calculate"))) - (<:table - (<:tr - (<:th) - (loop - for i from 1 to n - do (<:th (<:ah i)))) - (loop - for i from 1 to n - do (<:tr - (<:th (<:ah i)) - (loop - for j from 1 to n - do (<:td (<:ah (* i j))))))))))))) - - (defun direct-mul-table-example () - ;; just like the above example but write directly to the client - ;; stream. you can usually tell the difference if N is large. - (send-headers (context.response *context*)) - (with-request-params (n) (context.request *context*) - (let ((n (if n - (or (parse-integer n :junk-allowed t) - 0) - 0))) - (flet ((send-string (&rest strings) - (let ((network-stream (ucw::network-stream (context.response *context*)))) - (dolist (string strings) - (write-sequence (string-to-octets (if (stringp string) - string - (princ-to-string string)) - :us-ascii) - network-stream)) - (write-sequence +CR-LF+ network-stream)))) - ;; we can't use YACLML here since the respons'se network stream is an (unsigned-byte 8) stream. - (send-string "") - (send-string "Multiplication table") - (send-string "") - (send-string "Go Back to Main Demo") - (send-string "

Multiplication table upto " n "

") - (send-string "
") - (send-string "

N:

") - (send-string "
") - (send-string "") - (send-string "") - (send-string "") - (loop - for i from 1 to n - do (send-string "")) - (send-string "") - (loop - for i from 1 to n - do (send-string "") - do (send-string "") - do (loop - for j from 1 to n - do (send-string "")) - do (send-string "")) - (send-string "
" i "
" i "" (* i j) "
"))))) - - (defun start-example-server (&key (backend :httpd) (port 8000)) - (if (server.started *example-server*) - (error "Server already started") - (setf (server.backend *example-server*) - (make-backend backend :port port))) - (register-application *example-server* *example-application*) - (startup-server *example-server*)) - - (defun stop-example-server () - (when (server.started *example-server*) - (shutdown-server *example-server*))) - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Copyright (c) 2003-2005 Edward Marco Baringer - ;;; Copyright (c) 2009 Drew Crampsie - ;;; Copyright (c) 2009 Clinton Ebadi - ;;; 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. - ;;; - ;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names - ;;; of its contributors may be used to endorse or promote products - ;;; derived from this software without specific prior written permission. - ;;; - ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - ;;; "AS IS" AND ANY EXPRESS 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 COPYRIGHT - ;;; OWNER OR CONTRIBUTORS 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. --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/src/sum.lisp ../UCW-old/ucw-core-last/ucw-core/examples/src/sum.lisp *** ucw-core-last/ucw-core/examples/src/sum.lisp 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/src/sum.lisp 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,65 **** - (in-package #:ucw-user) - - ;;;; This is an example which demonstrates component re use and a - ;;;; control flow which doesn't have a well defined 'starting' - ;;;; component. - - (defcomponent read-a-number (html-block-element-mixin) - ((label :accessor label :initarg :label :initform "A number please"))) - - (defmethod render ((reader read-a-number)) - (let ((number-string "")) - (") - ;;;; ...) we're not going to, it's bad style and UCW is makes that - ;;;; more difficult than it could be. - - ;;;; What we're supposed to do is hand off our request to a component - ;;;; and let it deal with the nitty gritty html stuff. Here's the form - ;;;; which defines the view-wiki-page component: - - (defcomponent view-wiki-page (tal-component) - ((page-name :accessor page-name :initarg :page-name)) - (:default-initargs :template-name "wiki/view.tal")) - - (defmethod tal-component-environment nconc - ((page view-wiki-page)) - (yaclml:tal-env 'contents - (cl-ppcre:regex-replace-all - "([A-Z][a-z]+){2,}" - (contents (find-wiki-page (page-name page))) - "\\&"))) - - ;;;; Notice how much the defcomponent macro looks like defclass, - ;;;; that's not accidental. view-wiki-page now names a class of - ;;;; components. The (call 'view-wiki-page ...) form in our view.ucw - ;;;; entry-point is little more than a call to make-instance. - - ;;;; view-wiki-page, since it's a window-component, is designed to - ;;;; occupy the entire browser window, it has to worry about emiting - ;;;; and tags and setting up javascript includes and - ;;;; style sheet links. Since view-wiki-page is also a template - ;;;; component it depends an a TAL file ("wiki/view.tal") to - ;;;; specify what html to output. - - ;;;; ** edit.ucw - - ;;;; *** The entry-point - - ;;;; Editing pages is only slightly more complicated than viewing: - - (defentry-point "edit.ucw" (:application *example-application*) - ((page-name "WelcomePage") name summary contents) - (if contents - (progn - (update-wiki-page page-name (make-instance 'wiki-edit - :author name - :summary summary - :contents contents)) - (call 'thankyou :page-name page-name)) - (call 'edit-wiki-page :page-name page-name))) - - ;;;; We assume that if the request contains the contents parameter - ;;;; then we're submitting an edit, otherwise we're asking for the - ;;;; edit page form. We've already seen DEFENTRY-POINT, entry-point - ;;;; lambda lists and call, so we can jump directly to the - ;;;; edit-wiki-page component: - - ;;;; *** The component - - (defcomponent edit-wiki-page (tal-component) - ((page-name :accessor page-name :initarg :page-name)) - (:default-initargs :template-name "wiki/edit.tal")) - - ;;;; Like view-wiki-page this is also a window component based on a - ;;;; TAL template. - - ;;;; ** The thankyou page - - ;;;; Just for fun we're going to use YACLML as opposed to TAL for the - ;;;; thankyou component: - - (defcomponent thankyou () - ((page-name :accessor page-name :initarg :page-name))) - - (defmethod render ((page thankyou)) - (symbol-macrolet ((page-name (<:as-html (page-name page)))) - (<:html - (<:head - (<:title "Thank you for editing " page-name)) - (<:body - (<:p "Thank you for editing " page-name) - (<:a :href (strcat "view.ucw?page-name=" (page-name page)) - "View " page-name))))) - - ;;;; As you can see by the strcat UCW isn't well adapted to munging - ;;;; strings into urls. [the situation is slightly better in tal pages - ;;;; with tal expression language]. - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;;;; * UCW Style - - ;;;; UCW styled apps, unlike regular style apps, start with components - ;;;; and actions. Only later do we tie components and actions to urls - ;;;; and pages. - - ;;;; ** wiki-manipulator - - ;;;; All of our wiki components are going to subclass - ;;;; wiki-manipulator. This class provides the page-name slot and the - ;;;; method on update-url. - - (defcomponent wiki-manipulator () - ((page-name :accessor page-name - :initarg :page-name - :backtrack t))) - - ;;;; We define a method on update-url so that bookmarking this page, - ;;;; or requesting it any time after the session has expired, will - ;;;; view the current page (even if the user was editing it when he - ;;;; created the bookmark). Note that there is nothing automatic about - ;;;; this update-url method. It only works because we know that - ;;;; wiki.ucw?page-name=Foo will show the page named Foo. Embedding - ;;;; the wiki in another application would probably make this - ;;;; assumption untrue and require a different update-url method. - - (defmethod update-url ((component wiki-manipulator) url) - (setf (ucw::uri.path url) "wiki.ucw") - (push (cons "page-name" (page-name component)) (ucw::uri.query url)) - url) - - ;;;; ** wiki-viewer - - ;;;; The wiki-viewer component shows a page of the wiki. In particular - ;;;; the component show the html version of the page named by the - ;;;; value of the viewer's page-name slot. Unlike the wiki-editor - ;;;; component a user will use the same wiki-viewer component during - ;;;; the entire course of their browsing. - - (defcomponent wiki-viewer (wiki-manipulator) - ()) - - ;;;; We split the text of the page into StudlyWords and non - ;;;; StudlyWords. StudlyWords are wrapped in links to view-page - ;;;; actions, everything else is sent as is to the client. - - (defmethod render ((page wiki-viewer)) - (<:h1 (<:as-html (page-name page))) - (let ((scanner (cl-ppcre:create-scanner "((?:[A-Z][a-z]+){2,})"))) - (dolist (part (cl-ppcre:split scanner - (contents (find-wiki-page (page-name page))) - :with-registers-p t)) - (if (cl-ppcre:scan scanner part) - (let ((part part)) - ( ol { - list-style: none; - display: table; - margin: 0; - padding: 0; - } - - div.list-container.horizontal > ol > li { - display: table-cell; - } - - div.list-container.vertical > ol > li { - /* TODO should be table-row, but that seems buggy with ff */ - display: block; - } - - - /* - collapsible pane - */ - - .collapsible .switch a:link, - .collapsible .switch a:visited, - .collapsible .switch a:hover, - .collapsible .switch a:active - { - text-decoration: none; - color: #000; - } - - .collapsible > .switch > a > img - { - padding-right: 5px; - } - - /* - validation - */ - - .ucw-form-field-invalid { - border: 1px solid #ff0000; - } - - .ucw-form-field-valid { - border: none; - } - --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/wwwroot/tal/counter.tal ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/counter.tal *** ucw-core-last/ucw-core/examples/wwwroot/tal/counter.tal 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/counter.tal 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,18 **** - - - - - - - - - - -
Current value:CURRENT VALUE
- increment - - decrement -
--- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/edit.tal ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/edit.tal *** ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/edit.tal 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/edit.tal 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,26 **** - - - -
- - -

- -

- -

- -

-

-
- - --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/view.tal ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/view.tal *** ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/view.tal 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/view.tal 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,13 **** - - - -
- page contents go here -
-

Edit

- - --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/wiki-wrapper.tal ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/wiki-wrapper.tal *** ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/wiki-wrapper.tal 2023-09-08 17:28:37.493882576 +0100 --- ../UCW-old/ucw-core-last/ucw-core/examples/wwwroot/tal/wiki/wiki-wrapper.tal 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,14 **** - - - - page name goes here - - -

page name goes here

-
- template contents go here -
- - --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/.gitignore ../UCW-old/ucw-core-last/ucw-core/.gitignore *** ucw-core-last/ucw-core/.gitignore 2023-09-08 17:28:37.489882614 +0100 --- ../UCW-old/ucw-core-last/ucw-core/.gitignore 1970-01-01 01:00:00.000000000 +0100 *************** *** 1 **** - _darcs --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/backend/basic-backend.lisp ../UCW-old/ucw-core-last/ucw-core/src/backend/basic-backend.lisp *** ucw-core-last/ucw-core/src/backend/basic-backend.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/backend/basic-backend.lisp 2022-06-20 19:28:20.000000000 +0100 *************** *** 4,9 **** (defclass basic-backend (backend) ! ((host :accessor host :initarg :host :initform nil) ! (port :accessor port :initarg :port :initform nil) (socket :initform nil :accessor socket) (server :accessor server :initarg :server) --- 4,9 ---- (defclass basic-backend (backend) ! ((host :accessor host :initarg :host) ! (port :accessor port :initarg :port) (socket :initform nil :accessor socket) (server :accessor server :initarg :server) *************** *** 97,101 **** (remote-address (remote-address request)) (raw-uri (raw-uri request))) ! (ucw.backend.info "Handling request from ~S for ~S" remote-address raw-uri) (or (block handle (dolist* ((can-match handler url-base) (handlers backend)) --- 97,101 ---- (remote-address (remote-address request)) (raw-uri (raw-uri request))) ! (ucw.backend.info "Handling request from ~a for ~S" remote-address raw-uri) (or (block handle (dolist* ((can-match handler url-base) (handlers backend)) *************** *** 110,114 **** internal-time-units-per-second))) (when (> seconds 0.05) ! (ucw.backend.info "Handled request in ~,3f secs (request came from ~S for ~S)" seconds remote-address raw-uri))))) --- 110,114 ---- internal-time-units-per-second))) (when (> seconds 0.05) ! (ucw.backend.info "Handled request in ~,3f secs (request came from ~a for ~S)" seconds remote-address raw-uri))))) *************** *** 156,168 **** (declare (optimize speed) (inline localhost-ip-address-p ip-address-from-private-network-p)) ! (let ((physical-remote-address (call-next-method))) ! (if (and physical-remote-address ! (or (ip-address-from-private-network-p physical-remote-address) ! (localhost-ip-address-p physical-remote-address))) ;; check if we are in a proxy setup and extract the real remote address if provided. ;; but do so only if the physical remote address is coming from a machine from the local net. ;; please note that this is not a realiable source for ip addresses! (let ((ip-as-string (get-header message "X-Forwarded-For"))) ! (when ip-as-string (let* ((real-remote-address (first (cl-ppcre:split "," ip-as-string :sharedp t))) (pieces (cl-ppcre:split "\\." real-remote-address :sharedp t))) --- 156,169 ---- (declare (optimize speed) (inline localhost-ip-address-p ip-address-from-private-network-p)) ! (let* ((physical-remote-address (call-next-method)) ! (address-vector (iolib.sockets:address-to-vector physical-remote-address))) ! (if (and address-vector ! (or (ip-address-from-private-network-p address-vector) ! (localhost-ip-address-p address-vector))) ;; check if we are in a proxy setup and extract the real remote address if provided. ;; but do so only if the physical remote address is coming from a machine from the local net. ;; please note that this is not a realiable source for ip addresses! (let ((ip-as-string (get-header message "X-Forwarded-For"))) ! (if ip-as-string (let* ((real-remote-address (first (cl-ppcre:split "," ip-as-string :sharedp t))) (pieces (cl-ppcre:split "\\." real-remote-address :sharedp t))) *************** *** 177,181 **** (progn (ucw.backend.info "Returning NIL instead of an invalid ip address: ~S" ip-as-string) ! nil))))) physical-remote-address))) --- 178,183 ---- (progn (ucw.backend.info "Returning NIL instead of an invalid ip address: ~S" ip-as-string) ! nil))) ! physical-remote-address)) physical-remote-address))) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/backend/basic-backend.lisp-ORI ../UCW-old/ucw-core-last/ucw-core/src/backend/basic-backend.lisp-ORI *** ucw-core-last/ucw-core/src/backend/basic-backend.lisp-ORI 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/backend/basic-backend.lisp-ORI 2011-04-03 15:37:14.000000000 +0100 *************** *** 0 **** --- 1,416 ---- + ;; -*- lisp -*- + + (in-package :it.bese.ucw.core) + + (defclass basic-backend (backend) + ((host :accessor host :initarg :host) + (port :accessor port :initarg :port) + (socket :initform nil :accessor socket) + (server :accessor server :initarg :server) + (handlers :accessor handlers :initform '()) + (request-content-length-limit :initform *request-content-length-limit* + :accessor request-content-length-limit-of + :initarg :request-content-length-limit))) + + (defprint-object (self basic-backend) + (write-string ":host ") + (princ (host self)) + (write-string " :port ") + (princ (port self))) + + (defclass basic-message (message) + ((headers :accessor headers :initform '()) + (socket :accessor socket :initarg :socket))) + + (defclass basic-request (basic-message request) + ((cookies :accessor cookies) + (parameters :accessor parameters :initform '()) + (raw-uri :accessor raw-uri :initform nil) + (query-path :accessor query-path :initform nil) + (raw-body :accessor raw-body :initform nil) + (http-method :accessor http-method :initform nil))) + + (defclass basic-response (basic-message response) + ((headers-are-sent :accessor headers-are-sent-p :initform nil :type boolean) + (cookies :accessor cookies :initform '()) + (request :accessor request :initarg :request :initform nil) + (html-stream :accessor html-stream :initform (make-string-output-stream)) + (status :accessor status :initform +http-ok+) + (external-format :accessor external-format :initform nil) + (content :accessor content :initform nil))) + + (defclass lockable-backend-mixin () + ((lock + :initform (make-recursive-lock "backend lock") + :accessor lock-of))) + + (defmacro with-lock-held-on-backend (backend &body body) + `(with-recursive-lock-held ((lock-of ,backend)) + ,@body)) + + + ;;;; Cookies + + (defmethod cookies ((request basic-request)) + (if (slot-boundp request 'cookies) + (slot-value request 'cookies) + (setf (slot-value request 'cookies) + ;; TODO consider calling safe-parse-cookies, see rfc2109 comments + (rfc2109:parse-cookies (get-header request "Cookie"))))) + + (defmethod find-cookie ((request basic-request) cookie) + (find-cookie-using-request (context.request *context*) cookie)) + + (defmethod find-cookie-using-request ((request basic-request) cookie) + (let ((cookie-name (cond ((stringp cookie) cookie) + ((rfc2109:cookie-p cookie) (rfc2109:cookie-name cookie)) + (t (error "FIND-COOKIE only supports string and rfc2109:cookie struct as cookie name specifier"))))) + (find cookie-name (cookies request) :test #'string= :key #'rfc2109:cookie-name))) + + (defun cookie-value (cookie &optional default) + (cookie-value-using-request (context.request *context*) cookie default)) + + (defmethod cookie-value-using-request ((request basic-request) cookie &optional default) + (aif (find-cookie request cookie) + (unescape-as-uri (rfc2109:cookie-value it)) + default)) + + (defun add-cookie (cookie) + "Add cookie to the current response." + (add-cookie-using-response (context.response *context*) cookie)) + + (defmethod add-cookie-using-response ((response basic-response) cookie) + (assert (rfc2109:cookie-p cookie)) + (push cookie (cookies response))) + + + ;;;; Backend methods + (defmethod initialize-backend ((backend basic-backend) &key server &allow-other-keys) + (when (and (null *mime-types*) + (probe-file *default-mime-types-file*)) + (read-mime-types *default-mime-types-file*)) + (setf (server backend) server) + backend) + + (defmethod handle-request ((backend basic-backend) (request basic-request) (response basic-response)) + (let ((start-time (get-internal-real-time)) + (remote-address (remote-address request)) + (raw-uri (raw-uri request))) + (ucw.backend.info "Handling request from ~S for ~S" remote-address raw-uri) + (or (block handle + (dolist* ((can-match handler url-base) (handlers backend)) + (declare (ignore url-base)) + (when (funcall can-match (query-path request)) + (funcall handler request response) + (return-from handle t))) + nil) + (handle-request (server backend) request response) + (error 'no-handler-for-request :raw-uri raw-uri :request request)) + (let ((seconds (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (when (> seconds 0.05) + (ucw.backend.info "Handled request in ~,3f secs (request came from ~S for ~S)" + seconds remote-address raw-uri))))) + + (defmethod publish-directory ((backend basic-backend) directory-pathname url-base) + (push (list (lambda (request-url) + (ucw.backend.dribble "Trying to match '~S' under url-base '~S' to serve it as a file from '~S'" + request-url url-base directory-pathname) + (starts-with request-url url-base)) + (lambda (request response) + (aif (map-query-path-to-file (query-path request) + url-base + directory-pathname) + (progn + (ucw.backend.debug "Serving [~S] as a file under url-base [~S]" it url-base) + (serve-file it :request request :response response)) + (progn + (ucw.backend.debug "Failed to serve [~S] as a file under url-base [~S]" (query-path request) url-base) + (error 'no-handler-for-request :raw-uri (raw-uri request) :request request)))) + url-base) + (handlers backend))) + + ;;;; Message headers methods + + (defmethod get-header ((message basic-message) header-name) + (cdr (assoc header-name (headers message) :test #'string-equal))) + + (defmethod (setf get-header) (value (message basic-message) header-name) + (aif (assoc header-name (headers message) :test #'string-equal) + (setf (cdr it) value) + (push (cons header-name value) (headers message))) + value) + + (defmethod add-header ((message basic-message) header-name value) + (push (cons header-name value) (headers message)) + value) + + (defmethod delete-header ((message basic-message) header-name) + (setf (headers message) + (delete-if #'(lambda (item) + (string-equal (car item) + header-name)) + (headers message)))) + + (defmethod remote-address :around ((message basic-message)) + (declare (optimize speed) + (inline localhost-ip-address-p ip-address-from-private-network-p)) + (let ((physical-remote-address (call-next-method))) + (if (and physical-remote-address + (or (ip-address-from-private-network-p physical-remote-address) + (localhost-ip-address-p physical-remote-address))) + ;; check if we are in a proxy setup and extract the real remote address if provided. + ;; but do so only if the physical remote address is coming from a machine from the local net. + ;; please note that this is not a realiable source for ip addresses! + (let ((ip-as-string (get-header message "X-Forwarded-For"))) + (when ip-as-string + (let* ((real-remote-address (first (cl-ppcre:split "," ip-as-string :sharedp t))) + (pieces (cl-ppcre:split "\\." real-remote-address :sharedp t))) + (declare (type list pieces)) + (if (= (length pieces) 4) + (iter (with result = (make-array 4 :element-type '(unsigned-byte 8))) + (for idx :from 0 :below 4) + (for ip-address-part = (parse-integer (pop pieces))) + (assert (<= 0 ip-address-part 255)) + (setf (aref result idx) ip-address-part) + (finally (return result))) + (progn + (ucw.backend.info "Returning NIL instead of an invalid ip address: ~S" ip-as-string) + nil))))) + physical-remote-address))) + + ;;;; Request handling + + (defun read-line-from-network (stream &optional (eof-error-p t)) + "A simple state machine which reads chars from STREAM until it + gets a CR-LF sequence or the end of the stream." + (declare (optimize (speed 3))) + (let ((buffer (make-array 50 + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) + (labels ((read-next-char () + (let ((byte (read-byte stream eof-error-p stream))) + (if (eq stream byte) + (return-from read-line-from-network buffer) + (return-from read-next-char byte)))) + (cr () + (let ((next-byte (read-next-char))) + (case next-byte + (#.+linefeed+ ;; LF + (return-from read-line-from-network buffer)) + (t ;; add both the cr and this char to the buffer + (vector-push-extend #.+carriage-return+ buffer) + (vector-push-extend next-byte buffer) + (next))))) + (next () + (let ((next-byte (read-next-char))) + (case next-byte + (#.+carriage-return+ ;; CR + (cr)) + (#.+linefeed+ ;; LF + (return-from read-line-from-network buffer)) + (t + (vector-push-extend next-byte buffer) + (next)))))) + (next)))) + + (defun accumulate-parameters (assoc-list) + "Accumulates same parameters into lists. Otherwise + multiple-selection lists won't have a list value and + 302 - Redirect

Page has moved to ~A

" (escape-as-html target) (escape-as-html target))) - (defun open-session-specific-temporary-file (&key (element-type :default) (external-format :default)) --- 67,76 ---- (defun send-redirect (target &optional (response *response*)) (setf (get-header response "Status") +http-moved-temporarily+ (get-header response "Location") target) ! (format nil "302 - Redirect !

Page has moved to ~A

" (escape-as-html target) (escape-as-html target))) (defun open-session-specific-temporary-file (&key (element-type :default) (external-format :default)) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/rerl/standard-component/standard-component.lisp ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-component/standard-component.lisp *** ucw-core-last/ucw-core/src/rerl/standard-component/standard-component.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-component/standard-component.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 53,59 **** ;; if the slot has already been initialized (due to regular ;; initargs) then simply set its place ! (rebind (slot) ! (setf (component.place slot-value) ! (make-place (slot-value comp (c2mop:slot-definition-name slot))))) (setf (parent slot-value) comp))))) --- 53,58 ---- ;; if the slot has already been initialized (due to regular ;; initargs) then simply set its place ! (setf (component.place slot-value) ! (make-place (slot-value comp (c2mop:slot-definition-name slot)))) (setf (parent slot-value) comp))))) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/rerl/standard-request-context.lisp ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-request-context.lisp *** ucw-core-last/ucw-core/src/rerl/standard-request-context.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-request-context.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 62,74 **** (defun make-dummy-context (&optional (application *default-application*)) ! (with-lock-held-on-application application ! (let* ((*context* (make-request-context application ! (make-instance 'dummy-request) ! (make-instance 'dummy-response))) ! (session (make-new-session application)) ! (frame (make-new-frame nil session))) ! (setf (session.current-frame session) frame ! (context.session *context*) session) ! *context*))) (defcomponent dummy-root-component (window-component) --- 62,73 ---- (defun make-dummy-context (&optional (application *default-application*)) ! (let* ((*context* (make-request-context application ! (make-instance 'dummy-request) ! (make-instance 'dummy-response))) ! (session (make-new-session application)) ! (frame (make-new-frame nil session))) ! (setf (session.current-frame session) frame ! (context.session *context*) session) ! *context*)) (defcomponent dummy-root-component (window-component) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/rerl/standard-session-frame.lisp ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-session-frame.lisp *** ucw-core-last/ucw-core/src/rerl/standard-session-frame.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/rerl/standard-session-frame.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 5,8 **** --- 5,10 ---- ;;;; ** STANDARD-SESSION-FRAME + (defvar *session-frame-class* 'standard-session-frame) + (defmacro register-action ((&rest args &key (through-redirect nil) (frame '(context.current-frame *context*)) *************** *** 38,46 **** ,action)))) - (defmacro register-ajax-action ((&rest args &key (class ''ajax-action) &allow-other-keys) &body body) - (remf-keywords args :class) - `(register-action (:class ,class ,@args) - ,@body)) - (defmethod register-action-in-frame ((frame standard-session-frame) action) (setf (action-id action) (insert-with-new-key (frame.actions frame) +action-id-length+ action))) --- 40,43 ---- *************** *** 173,178 **** found-callbacks)) ! (defmethod make-next-frame ((session basic-session) (previous-frame standard-session-frame) new-id) ! (make-instance (session-frame-class-of session) :effective-backtracks (clone-effective-backtracks (context.session *context*) --- 170,175 ---- found-callbacks)) ! (defmethod make-next-frame ((previous-frame standard-session-frame) new-id) ! (make-instance *session-frame-class* :effective-backtracks (clone-effective-backtracks (context.session *context*) *************** *** 181,186 **** :id new-id)) ! (defmethod make-next-frame ((session basic-session) (f null) new-id) ! (make-instance (session-frame-class-of session) :id new-id)) ;; Copyright (c) 2003-2005 Edward Marco Baringer --- 178,183 ---- :id new-id)) ! (defmethod make-next-frame ((f null) new-id) ! (make-instance *session-frame-class* :id new-id)) ;; Copyright (c) 2003-2005 Edward Marco Baringer diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-ajax/ajax-actions.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-actions.lisp *** ucw-core-last/ucw-core/src/ucw-ajax/ajax-actions.lisp 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-actions.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 0 **** --- 1,112 ---- + ;; -*- lisp -*- + + (in-package :ucw-ajax) + + (enable-bracket-syntax) + + (declaim (inline action-ajax-p)) + (defun action-ajax-p (action) + (typep action 'ajax-action)) + + (defmethod compute-url ((action ajax-action) (app application)) + (let ((uri (call-next-method))) + (setf (uri.path uri) (strcat (uri.path uri) it.bese.ucw.core::+ajax-action-dispatcher-url+)) + uri)) + + (defmethod handle-toplevel-condition ((application application) (error serious-condition) (action ajax-action)) + ;;(log-error-with-backtrace error) + (abort-action "Internal server error")) + + (defmacro handle-ajax-request ((&key (succesful-when-finishes t) (output-yaclml-stream-on-failure nil)) &body body) + (with-unique-names (yaclml-body) + `(progn + (setf (get-header *response* "Status") +http-ok+ + (get-header *response* "Content-Type") "text/xml") + (<:as-is #.(format nil "~%")) + {with-xml-syntax + ) + (progn + (it.bese.ucw.core::ucw.rerl.ajax.debug "Failed to render ajax answer, error message is ~S" -message-) + ,(when output-yaclml-stream-on-failure + `(<:as-is ,yaclml-body)) + + (when -message- + )))))>}))) + + (defmethod call-action ((action ajax-action) application session frame) + "Wrap the ajax action's output in an XML document. The action is free to render + any valid XML body that can be processed on the client side." + ;; TODO, attila: the encoding in the default xml header should be taken from (encoding (context.response *context*)) + ;; is there a function that converts to the appropiate format? + (handle-ajax-request (:succesful-when-finishes nil) + (restart-case + (let ((swank::*sldb-quit-restart* 'abort-action)) + (call-next-method) + (it.bese.ucw.core::ucw.rerl.actions.debug "The body of CALL-ACTION for AJAX-ACTION was successful, calling SEND-EVENTS-TO-THE-CLIENT") + ;; make sure we don't send partial content in case of an error + (<:as-is + ;; TODO there could be a more efficient construct in yaclml for this based on (setf (fill-pointer ...) ...) + (with-yaclml-output-to-string + (when (has-events-for-the-client session) + (send-events-to-the-client session)))) + (setf -successp- t)) + (abort-action (&optional (failure-message "Internal server error")) + :report "Abort processing this ajax action" + (it.bese.ucw.core::ucw.rerl.actions.debug "Ajax ABORT-ACTION restart invoked with FAILURE-MESSAGE ~S" failure-message) + (if failure-message + (setf -message- failure-message) + (setf -successp- t)))))) + + (defmethod call-action :around ((action ajax-action) application session frame) + (let ((form (creation-time-current-form-of action))) + (if (and form + (parent form)) + (let ((*current-form* form)) + (it.bese.ucw.core::ucw.rerl.actions.dribble "Restored *CURRENT-FORM* to ~A from CALL-ACTION of AJAX-ACTION" *current-form*) + (call-next-method)) + (call-next-method)))) + + ;; Copyright (c) 2003-2005 Edward Marco Baringer + ;; 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. + ;; + ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names + ;; of its contributors may be used to endorse or promote products + ;; derived from this software without specific prior written permission. + ;; + ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + ;; "AS IS" AND ANY EXPRESS 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 COPYRIGHT + ;; OWNER OR CONTRIBUTORS 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. diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-ajax/ajax-application.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-application.lisp *** ucw-core-last/ucw-core/src/ucw-ajax/ajax-application.lisp 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-application.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 0 **** --- 1,250 ---- + ;; See the file LICENCE for licence information. + (in-package :ucw-ajax) + + ;;(enable-sharpquote<>-syntax) + (enable-bracket-syntax) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; dirty-component-tracking + + (defclass dirty-component-tracking-application-mixin () + () + (:documentation "Application mixin that enables the tracking of dirty components.")) + + (defclass dirty-component-tracking-session (standard-session) + ((dirty-components :initform (make-hash-table :weakness :key :test #'eq) + :accessor dirty-components-of))) + + (defmethod session-class list ((app dirty-component-tracking-application-mixin)) + 'dirty-component-tracking-session) + + (defmethod has-events-for-the-client ((session dirty-component-tracking-session)) + (if (next-method-p) + (call-next-method) + (iterate-visible-dirty-components + (lambda (component) + (declare (ignore component)) + (return-from has-events-for-the-client t))))) + + ;;;;;;;;;;;;;;;;;;; + ;; ajax-application + + (defclass ajax-application-mixin (dirty-component-tracking-application-mixin) + ()) + + (defclass standard-session (basic-session) + ()) + + (defclass ajax-session (dirty-component-tracking-session standard-session) + ((event-condition-variable :accessor event-condition-variable-of + :initform (when *supports-threads-p* + (make-condition-variable))) + (latest-polling-thread :accessor latest-polling-thread-of :initform nil))) + + (defmethod session-class list ((app ajax-application-mixin)) + 'ajax-session) + + (defgeneric notify-session-event (session) + (:method ((session ajax-session)) + (when *supports-threads-p* + (it.bese.ucw.core::ucw.rerl.ajax.debug "notify-session-event for session ~S in thread ~S" session (thread-name (current-thread))) + (condition-notify (event-condition-variable-of session))))) + + (defgeneric wait-for-session-event (session) + (:method ((session standard-session)) + (when *supports-threads-p* + (it.bese.ucw.core::ucw.rerl.ajax.debug "wait-for-session-event for session ~S, in thread ~S" session (thread-name (current-thread))) + (condition-wait (event-condition-variable-of session) (lock-of session))))) + + (defmethod send-events-to-the-client ((session ajax-session)) + (ajax-render-dirty-components)) + + + ;;; + ;;; Dirty stuff + ;;; + (defvar %disable-dirtyness-tracking%) + + (defun it.bese.ucw.core::register-dirty-component (component) + (unless (boundp '%disable-dirtyness-tracking%) + (let ((session (session-of component))) + (when (typep session 'dirty-component-tracking-session) + (let ((table (dirty-components-of session))) + (it.bese.ucw.core::assert-session-lock-held session) + (when table + (it.bese.ucw.core::ucw.rerl.ajax.debug "About to register dirty component ~S, the session has ~S dirty components currently" + component (hash-table-count table)) + (setf (gethash component table) t) + (notify-session-event session))))))) + + (defun it.bese.ucw.core::unregister-dirty-component (component) + (let ((session (session-of component))) + (when (typep session 'dirty-component-tracking-session) + (let ((table (dirty-components-of session))) + (it.bese.ucw.core::assert-session-lock-held session) + (when table + (remhash component table) + (it.bese.ucw.core::ucw.rerl.ajax.debug "Component ~S is not dirty anymore, the session has ~S dirty components currently" + component (hash-table-count table))))))) + + (defmacro without-dirtyness-tracking (&body body) + "Disable dirtyness tracking. IOW, register-dirty-component will have no effects + while in the dynamic scope of without-dirtyness-tracking." + `(let ((%disable-dirtyness-tracking% t)) + ,@body)) + + (defun mark-dirty (component) + "It's a (setf (dirtyp component) t) inside a with-lock-held-on-session for convenience." + ;; TODO assert that locking another session is unsafe + (with-lock-held-on-session (session-of component) + (setf (dirtyp component) t))) + + (defun iterate-visible-dirty-components (visitor) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "iterate-visible-dirty-components entered with visitor ~S" visitor) + (when-bind table (dirty-components-of (context.session *context*)) + (let ((components (hash-table-keys table))) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "List of dirty components before collecting ~S" components) + (setf components (iter (for component in components) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "Checking component ~S" component) + (unless (dirtyp component) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "Component ~S is not dirty anymore, unregistering" component) + (it.bese.ucw.core::unregister-dirty-component component) + (next-iteration)) + (when (and (typep component 'ajax-component-mixin) + (not (has-ever-been-rendered-p component))) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "The ajax component ~S has not been rendered, skipping it" component) + (next-iteration)) + (for (values visiblep distance) = (visiblep component)) + (if visiblep + (collect (cons component distance)) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "Component ~S is not visible, dropping from the list" component)))) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "List of dirty components before sorting ~S" components) + (setf components (sort components #'< :key #'cdr)) + (it.bese.ucw.core::ucw.rerl.ajax.dribble "List of dirty components after sorting ~S" components) + (iter (for (component . nil) in components) + (it.bese.ucw.core::ucw.rerl.ajax.debug "iterate-visible-dirty-components visiting component ~S, dirtyp? ~S" + component (dirtyp component)) + ;; need to check for dirtyness again, it might have been rendered meanwhile + (when (dirtyp component) + (it.bese.ucw.core::ucw.rerl.ajax.debug "iterate-visible-dirty-components calling visitor with component ~S" component) + (funcall visitor component)))))) + + (defmethod delete-session :after (application (session ajax-session)) + ;; abort the client poller, if there's any + (it.bese.ucw.core::assert-session-lock-held session) + (setf (latest-polling-thread-of session) nil) + (notify-session-event session)) + + ;; (defvar *default-polling-delay* 3000 + ;; "The default delay in ms to wait before the client connects the server again for new events.") + ;; (defvar *max-number-of-live-polling-connections* 30 + ;; "While there are less then this many polling connections, they are blocked on the server and woke up when an event is available.") + ;; (defparameter *current-number-of-live-polling-connections* 0) + + ;; (defun calculate-client-polling-delay () + ;; (if (and *supports-threads-p* + ;; (< *current-number-of-live-polling-connections* + ;; *max-number-of-live-polling-connections*)) + ;; 0 + ;; *default-polling-delay*)) + + ;; (defgeneric handle-polling-of-session (application session frame) + ;; (:documentation "Called by the polling-dispatcher. SESSION and FRAME may be nil + ;; when a polling request was received in an unknown session.") + ;; (:method ((application ajax-application-mixin) session frame) + ;; (if (and session frame) + ;; (with-lock-held-on-session session + ;; (ucw.rerl.ajax.debug "handle-polling-of-session entered while there are ~S alive pollers" + ;; *current-number-of-live-polling-connections*) + ;; (incf *current-number-of-live-polling-connections*) + ;; (unwind-protect + ;; (progn + ;; (let ((current-thread (current-thread))) + ;; (setf (latest-polling-thread-of session) current-thread) + ;; (notify-session-event session) ; wake up any previous pollers to make them quit + ;; (when (and *supports-threads-p* + ;; (not (has-events-for-the-client session))) + ;; (ucw.rerl.ajax.debug "client-polling-handler got nil from has-events-for-the-client, falling asleep") + ;; (loop named waiting do + ;; (wait-for-session-event session) ; we release the session lock and wait for a notification + ;; (unless (eq (latest-polling-thread-of session) + ;; current-thread) + ;; (ucw.rerl.ajax.debug "client-poller aborting because there's a newer polling thread") + ;; (notify-session-event session) ; wake up any other (possible poller) threads waiting + ;; (return-from handle-polling-of-session)) + ;; (when (has-events-for-the-client session) + ;; (return-from waiting)))) + ;; (ucw.rerl.ajax.debug "client-poller woke up, sending back the ajax answer") + ;; ;; go through the public protocol, so transactions and stuff is alive while serving polling requests + ;; (handle-action (make-action + ;; (lambda () + ;; (})))) + ;; :sync ,',sync + ;; :handler ,,(if handler + ;; handler + ;; ``ucw.io.default-js-to-lisp-rpc-handler) + ;; :content (create :values evaluated-js-values) + ;; ,,@options)))))))) + + ;; (defmacro js-to-lisp-rpc* (options args &body body) + ;; "Just like js-to-lisp-rpc but the arguments are transferred to lisp as-is. IOW, you can't give a js expression + ;; that evaluates to the argument, but rather the named js variable will be visible on the lisp side." + ;; `(js-to-lisp-rpc ,options ,args ,args ,@body)) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-ajax/ajax-dispatchers.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-dispatchers.lisp *** ucw-core-last/ucw-core/src/ucw-ajax/ajax-dispatchers.lisp 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-dispatchers.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 0 **** --- 1,45 ---- + ;; -*- lisp -*- + + (in-package :ucw-ajax) + + ;;;; ajax-action-dispatcher + + (defconstant +ajax-action-dispatcher-default-priority+ (- most-positive-fixnum 1001)) + + (defclass ajax-action-dispatcher (action-dispatcher ucw-standard::starts-with-matcher) + () + (:default-initargs :priority +ajax-action-dispatcher-default-priority+ + :url-string it.bese.ucw.core::+ajax-action-dispatcher-url+) + (:documentation "This is a specialized action dispatcher to handle ajax requests.")) + + (defmethod matcher-match ((matcher ajax-action-dispatcher) + (application basic-application) + (context standard-request-context)) + (it.bese.ucw.core::ucw.rerl.dispatcher.dribble "~S trying to match as ajax-action-dispatcher" matcher) + (when (starts-with (query-path-sans-prefix context) (url-string matcher)) + (multiple-value-bind (matchesp session frame action) (call-next-method) + (declare (ignore matchesp)) + (values t session frame action)))) + + (defmethod handler-handle ((dispatcher ajax-action-dispatcher) + (application basic-application) + (context standard-request-context) + matcher-result) + (destructuring-bind (session frame action) matcher-result + (disallow-response-caching (context.response context)) + (if (and session frame action) + (progn + (ensure-session application context session) + (handle-action action application session frame)) + (send-ajax-answer-to-expired-session)))) + + (defun send-ajax-answer-to-expired-session () + (handle-ajax-request (:succesful-when-finishes nil :output-yaclml-stream-on-failure t) + (within-xhtml-tag "error-handler" + ;; " #\Newline))))) + diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-ajax/ajax.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax.lisp *** ucw-core-last/ucw-core/src/ucw-ajax/ajax.lisp 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 0 **** --- 1,180 ---- + (in-package :ucw-ajax) + + (defun current-form () + (when (and (boundp 'it.bese.ucw.core::*current-form*) + it.bese.ucw.core::*current-form*) + it.bese.ucw.core::*current-form*)) + + ;;;; ** The rendering protocol + + (defgeneric call-in-rendering-environment (trunk component) + (:documentation "This method can be used to set up the dynamic environment needed to render a component and all its children. + When ajax rendering all the parents are called with this method to get a chance to restore the dynamic environment.") + (:method-combination wrapping-standard)) + + (defmethod call-in-rendering-environment (trunk (component component)) + (funcall trunk)) + + (defmethod render :wrap-around ((component component)) + (call-in-rendering-environment #'call-next-method component) + (values)) + + (enable-bracket-syntax) + + (defmacro within-xhtml-tag (tag-name &body body) + "Execute BODY and wrap its yaclml output in a TAG-NAME xml node + with \"http://www.w3.org/1999/xhtml\" xml namespace." + `{with-xml-syntax + <(progn ,tag-name) :id "ucw-ajax" ;;:xmlns #.+xhtml-namespace-uri+ + ;;(@ "xmlns:dojo" #.+dojo-namespace-uri+) + ,@body>}) + + (defmacro within-dom-replacements-tag (&body body) + "Execute BODY and wrap its yaclml output in a dom-replacements xml node + with \"http://www.w3.org/1999/xhtml\" xml namespace. Client side js + iterates the elements of this node and replaces their counterparts + in the DOM tree with them." + `(within-xhtml-tag "div" + ,@body)) + + (defclass ajax-action (standard-action) + ((creation-time-current-form + :initform (current-form) + :accessor creation-time-current-form-of)) + (:metaclass mopp:funcallable-standard-class) + (:default-initargs :make-new-frame nil :call-render nil) + (:documentation "An ajax action in UCW is a raw action that renders an + XML document which is then processed by the client side js. The action + body may use yaclml tags and the WITH-XML-SYNTAX of yaclml to render + into the answer XML.")) + + (defmacro register-ajax-action ((&rest args &key (class ''ajax-action) &allow-other-keys) &body body) + (remf-keywords args :class) + `(register-action (:class ,class ,@args) + ,@body)) + + (defvar *ajax-component-being-rendered*) + + ;; TODO get rid of this if/when the forthcoming dojo refactor makes it pointless + (defun currently-ajax-rendered-component () + (when (boundp '*ajax-component-being-rendered*) + *ajax-component-being-rendered*)) + + (defun ajax-rendering-in-progress-p () + (boundp '*ajax-component-being-rendered*)) + + ;; all subclasses must be standard-component's because the dirtyp slot is needed by the ajax algorithms + (defcomponent ajax-component-mixin (html-element-mixin standard-component) + ((ucw-standard::dom-id :initform (js:gen-js-name-string :prefix "ajax")) ; override the initform of the inherited slot + (has-ever-been-rendered :initform nil :accessor has-ever-been-rendered-p) + (forbid-ajax-rendering :initform nil :accessor forbid-ajax-rendering-p :initarg :forbid-ajax-rendering-p + :documentation "This predicate my forbid AJAX rendering from this component and instruct the renderer to look further on the parent chain. The primary use of this is that sometimes (mostly due to browser rendring bugs) it's better to render bigger chunks of the page.")) + (:documentation "This is a marker class that marks a point in the component + chain from where a partial (AJAX) render may be started. The component + must render exactly one top-level DOM node and it must have an ID attribute. + The client side js will look up the DOM node identified by ID and replace it + with the freshly rendered one. + + Please note that this component in itself is not suitable for ajax + DOM node replacements because it does not render any wrapper nodes. + See WIDGET-COMPONENT for an ajax component that works on its own.")) + + (defparameter %ajax-stub-rendering-in-progress% nil + "Marks that we are going to render only a stub, so bail out in render :wrapping ajax-component-mixin.") + + (defgeneric render-ajax-stub (ajax-component-mixin) + (:method :around ((self ajax-component-mixin)) + (let ((%ajax-stub-rendering-in-progress% t)) + (call-next-method))) + (:method ((self ajax-component-mixin)) + (render self)) + (:documentation "Start rendering and stop at ajax-component-mixin boundaries. Only render a stub at those points (usually a <:div with an id) that can be later lazily replaced with an AJAX request.")) + + (defmethod render :after ((self ajax-component-mixin)) + (setf (has-ever-been-rendered-p self) t)) + + (defmethod render :wrapping ((self ajax-component-mixin)) + (unless %ajax-stub-rendering-in-progress% + (call-next-method))) + + (defgeneric ajax-render (component) + (:documentation "This method is called when we are rendering parts of the component hierarchy with AJAX. + By default it simply calls render after marking this fact on the ajax-component-mixin.") + (:method :around ((self ajax-component-mixin)) + (let ((*ajax-component-being-rendered* self)) + (call-next-method))) + (:method ((self ajax-component-mixin)) + (render self))) + + (defmacro in-restored-rendering-environment (component &body body) + `(call-in-restored-rendering-environment ,component + (lambda () + ,@body))) + + (defun call-in-restored-rendering-environment (component trunk) + (let ((parents)) + (iter (for parent :first component :then (parent parent)) + (while parent) + (push parent parents)) + (labels ((restorer () + ;; this is a nasty trick here: RESTORER is continously passed to the nested calls to + ;; CALL-IN-RENDERING-ENVIRONMENT until it pop'ped all the parents. then it finally calls + ;; AJAX-RENDER when all the parents have had a chance to restore the rendering environment. + (aif (pop parents) + (progn + (it.bese.ucw.core::ucw.rerl.info "Calling call-in-rendering-environment for ~S" it) + (call-in-rendering-environment #'restorer it)) + (progn + (it.bese.ucw.core::ucw.rerl.info "Environment of the parents is set up, calling trunk") + (call-in-rendering-environment trunk component))))) + (call-in-rendering-environment #'restorer (pop parents))))) + + (defun render-nearest-ajax-component (component) + (it.bese.ucw.core::ucw.rerl.debug "render-nearest-ajax-component from ~S" component) + (let ((ajax-component (iter (for current :first component :then (parent current)) + (while current) + (it.bese.ucw.core::ucw.rerl.info "Checking ~S" current) + (when (and (typep current 'ajax-component-mixin) + (not (forbid-ajax-rendering-p current))) + (return current)) + (while (slot-boundp current 'parent)) + (finally (return nil))))) + (it.bese.ucw.core::ucw.rerl.debug "render-nearest-ajax-component ended up at ~S" ajax-component) + (unless ajax-component + (error "No suitable ajax-component-mixin was found while walking the parent slots of ~A, unable to render AJAX answer" component)) + ;; we restore the env only up til the parent, because AJAX-RENDER + ;; calls RENDER which sets up the env of ajax-component itself. + (aif (parent ajax-component) + (call-in-restored-rendering-environment it (lambda () + (ajax-render ajax-component))) + (ajax-render ajax-component)))) + + (define-condition visible-dirty-component-remained (error) + ((component :initarg :component :accessor component-of)) + (:report (lambda (c stream) + (format stream "A visible dirty component ~A remained in session ~A after calling ajax-render-dirty-components. This would lead to a constant ajax rerendering in the poller. Make sure you either render all connected components or detach them!" + (component-of c) (session-of (component-of c)))))) + + (defmethod handle-toplevel-condition :around (application + (error visible-dirty-component-remained) + (action ajax-action)) + (when (debug-on-error application) + (invoke-slime-debugger-if-possible error)) + ;; when we are not debugging, just remove dirtyness and continue normal operation + (continue)) + + (defun ajax-render-dirty-components () + (within-dom-replacements-tag + (flet ((render-dirty-ajax-component (component) + (it.bese.ucw.core::ucw.rerl.debug "ajax-render-dirty-components at component ~S" component) + (render-nearest-ajax-component component))) + (iterate-visible-dirty-components #'render-dirty-ajax-component)) + (flet ((check-for-remained-dirty-component (c) + (when (visiblep c) + (restart-case + (error 'visible-dirty-component-remained :component c) + (continue () + :report "Remove dirtyness and leave me alone..." + (setf (dirtyp c) nil)))))) + (iterate-visible-dirty-components #'check-for-remained-dirty-component)))) + diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-ajax/ajax-package.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-package.lisp *** ucw-core-last/ucw-core/src/ucw-ajax/ajax-package.lisp 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-ajax/ajax-package.lisp 2011-04-03 17:25:53.000000000 +0100 *************** *** 0 **** --- 1,21 ---- + (in-package #:common-lisp-user) + + (defpackage #:ucw-ajax + (:use :ucw-core :ucw-standard :cl :yaclml :arnesi :js :iterate :bordeaux-threads) + (:shadowing-import-from :ucw-core :parent) + (:shadowing-import-from :js :new) + (:shadowing-import-from :iterate :in) + (:shadowing-import-from :iterate :with) + (:shadowing-import-from :iterate :while) + (:export + #:ajax-component-mixin + #:ajax-action + #:register-ajax-action + #:ajax-session + ;; ajax application + #:ajax-application-mixin + #:register-dirty-component + #:unregister-dirty-component + #:iterate-visible-dirty-components + )) + diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/application-mixins/transactional-application.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/application-mixins/transactional-application.lisp *** ucw-core-last/ucw-core/src/ucw-standard/application-mixins/transactional-application.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/application-mixins/transactional-application.lisp 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,74 **** - ;; -*- lisp -*- - - (in-package :ucw-standard) - - (defclass transactional-application-mixin () - ()) - - (defclass transactional-session-mixin () - ((transaction-stack :initarg :transaction-stack - :accessor session.transaction-stack - :initform nil))) - - (defclass transactional-session-frame-mixin () - ((transaction-stack :initarg :transaction-stack - :accessor frame.transaction-stack - :initform nil))) - - (defmethod session-class list ((application transactional-application-mixin)) - 'transactional-session-mixin) - - (defmethod session-frame-class list ((session transactional-session-mixin)) - 'transactional-session-frame-mixin) - - (defgeneric/cc open-transaction* (session)) - (defgeneric/cc close-transaction* (session)) - - (defun/cc open-transaction (&optional (session (context.session *context*))) - (open-transaction* session)) - - (defun/cc close-transaction (&optional (session (context.session *context*))) - (close-transaction* session)) - - (defmethod/cc open-transaction* ((s transactional-session-mixin)) - (push :open (session.transaction-stack s)) - (ucw-core::make-new-frame nil s)) - - (defmethod/cc close-transaction* ((s transactional-session-mixin)) - (let/cc k - (let ((transaction-stack (session.transaction-stack s))) - (let (fixed-k) - (setf fixed-k (lambda (v) - (declare (ignore v)) - (setf (car transaction-stack) (cons fixed-k - (context.current-frame *context*)) - (session.transaction-stack s) (cdr transaction-stack)) - (ucw-core::make-new-frame nil s) - (kall k t))) - (funcall fixed-k :whatever))))) - - (defmethod ucw-core::make-new-frame :around - (action (session transactional-session-mixin)) - (let ((frame (call-next-method))) - (setf (frame.transaction-stack frame) (session.transaction-stack session)) - frame)) - - (defmethod call-action :around (action application - (session transactional-session-mixin) - (frame transactional-session-frame-mixin)) - (if-bind transaction (car (frame.transaction-stack frame)) - (if (eql transaction :open) - (call-next-method) - (progn - (setf (context.current-frame *context*) (cdr transaction)) - (ucw-core::make-new-frame action (context.session *context*)) - (with-call/cc (funcall (car transaction) t)))) - (call-next-method))) - - ;;; export? This name would conflict with pretty much every database - ;;; package ever... - (defmacro with-transaction ((&rest options) &body body) - (declare (ignore options)) - `(progn (open-transaction) - ,@body - (close-transaction))) \ No newline at end of file --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/components/option-dialog.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/components/option-dialog.lisp *** ucw-core-last/ucw-core/src/ucw-standard/components/option-dialog.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/components/option-dialog.lisp 1970-01-01 01:00:00.000000000 +0100 *************** *** 1,90 **** - ;; -*- lisp -*- - - (in-package #:ucw-standard) - - ;;;; ** Generic Query/Option dialog - - (defclass option-dialog () - ((message :accessor message :initarg :message) - (options :accessor options :initarg :options) - (confirm :accessor confirm :initarg :confirm :initform nil)) - (:documentation "Component for querying the user. - - The value of the slot MESSAGE is used as a general heading. - - The OPTIONS slot must be an alist of (VALUE . LABEL). LABEL (a - string) will be used as the text of a link which, when clikced, - will answer VALUE. - - If the CONFIRM slot is T the user will be presented with a second - OPTION-DIALOG asking the user if they are sure they want to - submit that value.") - (:metaclass standard-component-class)) - - (defmethod tal-component-environment nconc ((dialog option-dialog)) - (make-standard-tal-environment - `((options . ,(mapcar (lambda (value-cons) - (tal-env 'text (cdr value-cons) - 'value (car value-cons))) - (options dialog)))) - dialog)) - - (defmethod/cc respond ((self option-dialog) value) - (if (confirm self) - (if (call 'option-dialog - :message (format nil "Are you sure you want to answer ~S to the question ~S?" - (cdr (assoc value (options self))) - (message self)) - :options '((t . "Yes") - (nil . "No"))) - (answer value) - ;; repeat the question - nil) - (answer value))) - - (defmethod render ((dialog option-dialog)) - (<:div :class "ucw-option-dialog" - (<:p :class "ucw-option-dialog-message" - (<:as-html (message dialog))) - (<:ul :class "ucw-option-dialog-options" - (dolist* ((value . text) (options dialog)) - (<:li :class "ucw-option-dialog-option" - ( - ;; 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. - ;; - ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names - ;; of its contributors may be used to endorse or promote products - ;; derived from this software without specific prior written permission. - ;; - ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - ;; "AS IS" AND ANY EXPRESS 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 COPYRIGHT - ;; OWNER OR CONTRIBUTORS 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. --- 0 ---- diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/standard-components.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-components.lisp *** ucw-core-last/ucw-core/src/ucw-standard/standard-components.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-components.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 16,19 **** --- 16,37 ---- ;;;; ** Simple Window + (defcomponent window-component () + ((content-type :accessor window-component.content-type + :initarg :content-type + :initform nil ; default is text/html with charset from current application + :documentation "The Content-Type header for the + http response (also used in the meta tag)"))) + + (defmethod window-component.content-type :around ((window window-component)) + "Either use slot value, or compute content-type from current application charset." + (or (call-next-method) + (setf (window-component.content-type window) + (format nil "text/html~@[; charset=~A~]" + (application.charset (context.application *context*)))))) + + (defmethod render :before ((window window-component)) + (setf (get-header (context.response *context*) "Content-Type") + (window-component.content-type window))) + (defcomponent basic-window-features-mixin () ((title :accessor window-component.title diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/standard-dispatchers.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-dispatchers.lisp *** ucw-core-last/ucw-core/src/ucw-standard/standard-dispatchers.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-dispatchers.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 125,132 **** entry-point-handler) () ! (:default-initargs :priority +regex-dispatcher-default-priority+) ! (:documentation "Matches URL using a cl-ppcre regular ! expression. Captured registers are available via ! `ucw:*dispatcher-registers*'")) (defclass regexp-binding-handler () --- 125,129 ---- entry-point-handler) () ! (:default-initargs :priority +regex-dispatcher-default-priority+)) (defclass regexp-binding-handler () diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/standard-package.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-package.lisp *** ucw-core-last/ucw-core/src/ucw-standard/standard-package.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-package.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 98,105 **** #:unique-dom-id - ;; Option Dialog - #:option-dialog - #:respond - ;; Paged List Component #:paged-list --- 98,101 ---- *************** *** 146,155 **** ;; Task #:task-component ! #:start ! ! ;; Transaction ! #:transactional-application-mixin ! #:open-transaction ! #:close-transaction)) --- 142,146 ---- ;; Task #:task-component ! #:start)) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/src/ucw-standard/standard-tags.lisp ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-tags.lisp *** ucw-core-last/ucw-core/src/ucw-standard/standard-tags.lisp 2023-09-08 17:28:37.497882538 +0100 --- ../UCW-old/ucw-core-last/ucw-core/src/ucw-standard/standard-tags.lisp 2011-04-03 15:37:14.000000000 +0100 *************** *** 77,110 **** ;;; All these tags take some kind of input, and execute a UCW callback. - (defmacro %with-callback-writer (&body body) - "Bind WRITER to either WRITER or ACCESSOR." - `(progn - (assert (xor writer accessor) nil "Must supply one of WRITER or ACCESSOR") - (let ((writer (or writer `(lambda (v) (setf ,accessor v))))) - ,@body))) - (deftag-macro " ! :maintainer "Drew Crampsie " ! :licence "BSD (sans advertising clause)" :version "0.9" + :class ucw-system :components ! ((:module :src ! :components ! ((:module :ucw-ajax ! :components ((:file "ajax-package") ! (:file "ajax" :depends-on ("ajax-package")) ! (:file "ajax-application" :depends-on ("ajax")) ! (:file "ajax-actions" :depends-on ("ajax-application")) ! (:file "ajax-dispatchers" :depends-on ("ajax-actions")) ! ))))) ! :properties ((version "0.9")) ! :depends-on (:ucw :parenscript)) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/ucw-core.asd ../UCW-old/ucw-core-last/ucw-core/ucw-core.asd *** ucw-core-last/ucw-core/ucw-core.asd 2023-09-08 17:28:37.489882614 +0100 --- ../UCW-old/ucw-core-last/ucw-core/ucw-core.asd 2022-06-20 20:06:48.000000000 +0100 *************** *** 116,126 **** "backtracking" "basic-classes"))) ! :depends-on ("core-package" "loggers" "helpers" "vars")) ! (:module :core-components ! :components ((:file "window")) ! :depends-on (:rerl))))) :properties ((version "0.9")) :depends-on (:arnesi :swank :iterate :yaclml :local-time ! :usocket :rfc2109 :net-telent-date :cl-fad :trivial-garbage :bordeaux-threads :closer-mop)) --- 116,123 ---- "backtracking" "basic-classes"))) ! :depends-on ("core-package" "loggers" "helpers" "vars"))))) :properties ((version "0.9")) :depends-on (:arnesi :swank :iterate :yaclml :local-time ! :iolib.sockets :usocket :rfc2109 :net-telent-date :cl-fad :trivial-garbage :bordeaux-threads :closer-mop)) diff -rN -C 2 '--exclude=_darcs' '--exclude=.git' ucw-core-last/ucw-core/ucw-core.asd~ ../UCW-old/ucw-core-last/ucw-core/ucw-core.asd~ *** ucw-core-last/ucw-core/ucw-core.asd~ 1970-01-01 01:00:00.000000000 +0100 --- ../UCW-old/ucw-core-last/ucw-core/ucw-core.asd~ 2022-06-20 20:06:48.000000000 +0100 *************** *** 0 **** --- 1,166 ---- + ;;; -*- lisp -*- + + ;;;; ASDF system definition file for UCW + (eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :it.bese.ucw.system) + (defpackage :it.bese.ucw.system + (:nicknames #:ucw.system) + (:export #:*load-as-production-p*) + (:use :common-lisp :asdf)))) + + (in-package :it.bese.ucw.system) + + + ;;; Export the variables in the ucw.system package, so that between + ;;; (asdf:find-system :ucw) and (asdf:oos 'asdf:load-op :ucw) users + ;;; get the chance to set these variables when loading UCW + ;;; programmatically. For more details on the variables themselves see + ;;; src/vars.lisp + + (macrolet ((def (&rest names) + `(progn + ,@(loop for name in names + collect `(defvar ,name) + collect `(export ',name))))) + (def + *ucw-swank-port* + *ucw-backend-type* + *ucw-backend-host* + *ucw-backend-port* + *ucw-server-class* + *ucw-applications-directory* + *ucw-systems* + *ucw-applications* + *ucw-log-root-directory* + *ucw-log-level* + *ucw-compile-time-log-level*)) + + (defparameter *load-as-production-p* t + "When T, load the UCW lisp files so that it will be used in a production system. + This means that debug-only blocks are skipped and various variables are initialized accordingly.") + + (defclass ucw-source-file (cl-source-file) + ()) + + (defmethod perform :around ((op operation) (component ucw-source-file)) + (let ((*features* *features*)) + (unless *load-as-production-p* + (pushnew :debug *features*)) + (call-next-method))) + + (defclass ucw-system (system) + ((test-system :initform :ucw.core.test :initarg :test-system :accessor test-system-of))) + + (defmacro defsystem* (name &body args) + `(defsystem ,name :default-component-class ucw-source-file + ,@args)) + + (defsystem* :ucw-core + :description "Core features of UnCommon Web" + :long-description "Contains the base features essential for a useful + Read Eval Render Loop (RERL)." + :author "Marco Baringer " + :licence "BSD (sans advertising clause)" + :version "0.9" + :class ucw-system + :test-system :ucw-core.test + :components + ((:module :src + :components ((:file "core-package") + (:file "helpers" :depends-on ("core-package" "vars")) + (:file "loggers" :depends-on ("core-package" "vars")) + (:file "vars" :depends-on ("core-package")) + (:file "control" :depends-on (:backend :rerl)) + (:module :backend + :components ((:file "accept-headers")) + :depends-on ("core-package" "loggers" :rerl)) + (:module :rerl + :components ((:file "protocol") + (:file "rerl-variables") + (:file "rerl-utils" :depends-on ("protocol" "rerl-variables")) + (:file "conditions" :depends-on ("protocol")) + (:file "backtracking" :depends-on ("basic-classes")) + (:file "request-loop-error" :depends-on ("conditions" "rerl-utils" "basic-action")) + (:file "basic-classes" :depends-on ("protocol" + "rerl-variables")) + (:file "basic-action" :depends-on ("protocol" + "standard-session-frame" + "basic-classes")) + (:file "basic-application" :depends-on ("rerl-utils" + "basic-classes")) + (:module :standard-component + :components ((:file "standard-component" :depends-on ("standard-component-class")) + (:file "control-flow" :depends-on ("standard-component")) + (:file "standard-component-class") + (:file "transactions" :depends-on ("standard-component"))) + :depends-on ("backtracking" + "rerl-utils" + "request-loop-error" + "basic-application" + "standard-session-frame" + "basic-action" + "basic-classes")) + (:file "basic-dispatchers" :depends-on ("request-loop-error" + "basic-application" + "basic-action")) + (:file "standard-request-context" :depends-on ("rerl-utils" + "basic-classes" + :standard-component)) + (:file "standard-server" :depends-on ("rerl-utils" + "request-loop-error" + "basic-classes")) + (:file "basic-session" :depends-on ("rerl-utils" + "basic-classes" + "standard-session-frame")) + (:file "standard-session-frame" :depends-on ("rerl-utils" + "backtracking" + "basic-classes"))) + :depends-on ("core-package" "loggers" "helpers" "vars"))))) + :properties ((version "0.9")) + :depends-on (:arnesi :swank :iterate :yaclml :local-time + :iolib.sockets :usocket :rfc2109 :net-telent-date :cl-fad + :trivial-garbage :bordeaux-threads :closer-mop)) + + ;; Backends + + (defsystem* :ucw.httpd + :components ((:module :src + :pathname "src/backend/" + :components ((:file "common") + (:file "message-queue") + (:file "basic-backend" :depends-on ("common")) + (:file "httpd" :depends-on ("message-queue" "basic-backend" "common"))))) + :depends-on (:ucw-core :rfc2388-binary :puri :cl-ppcre)) + + (defsystem* :ucw.mod-lisp + :components ((:module :src + :pathname "src/backend/" + :components ((:file "mod-lisp")))) + :depends-on (:ucw-core :ucw.httpd :iolib.sockets)) + + (defsystem* :ucw.iolib + :components ((:module :src + :pathname "src/backend/" + :components ((:file "common") + (:file "basic-backend" :depends-on ("common")) + (:file "iolib" :depends-on ("basic-backend" "common"))))) + :depends-on (:ucw-core :rfc2388-binary :puri :iolib.sockets :cl-ppcre)) + + (defsystem* :ucw-core.test + :components ((:module :test + :components + ((:file "package") + (:file "test-environment" :depends-on ("package")) + (:module "core" + :depends-on ("test-environment") + :serial t + :components ((:file "server") + (:file "application") + (:file "dispatcher") + (:file "entry-point") + (:file "component") + (:file "action") + (:file "callbacks"))) + (:file "stress" :depends-on ("core"))))) + :depends-on (:ucw-core :cxml :stefil :drakma :arnesi :iterate)) +