- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] ksprotte changed trunk/projects/bos/test/tsung.xml
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3460 Author: ksprotte URL: http://bknr.net/trac/changeset/3460 tsung.xml edited for shorter arrivalphases U trunk/projects/bos/test/tsung.xml Modified: trunk/projects/bos/test/tsung.xml =================================================================== --- trunk/projects/bos/test/tsung.xml 2008-07-16 12:18:57 UTC (rev 3459) +++ trunk/projects/bos/test/tsung.xml 2008-07-16 12:28:41 UTC (rev 3460) @@ -23,34 +23,13 @@ duration --> <load> - <arrivalphase phase="1" duration="7" unit="minute"> + <arrivalphase phase="1" duration="30" unit="second"> <users interarrival="2" unit="second" maxnumber="500"></users> </arrivalphase> - - - <arrivalphase phase="2" duration="5" unit="minute"> - <users interarrival="0.5" unit="second" maxnumber="500"></users> - </arrivalphase> - - - <arrivalphase phase="3" duration="2" unit="minute"> + + <arrivalphase phase="2" duration="2" unit="minute"> <users interarrival="0.1" unit="second" maxnumber="500"></users> </arrivalphase> - - - <arrivalphase phase="4" duration="10" unit="minute"> - <users interarrival="2" unit="second" maxnumber="500"></users> - </arrivalphase> - - - <arrivalphase phase="5" duration="5" unit="minute"> - <users interarrival="0.1" unit="second" maxnumber="500"></users> - </arrivalphase> - - - <arrivalphase phase="6" duration="10" unit="minute"> - <users interarrival="1" unit="second" maxnumber="500"></users> - </arrivalphase> </load> <options>

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3459 Author: ksprotte URL: http://bknr.net/trac/changeset/3459 fixed *contract-tree-image-update-daemon* not to use destroy-thread U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-16 12:06:28 UTC (rev 3458) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-16 12:18:57 UTC (rev 3459) @@ -305,9 +305,12 @@ ;; contract-tree image update daemon (defvar *contract-tree-image-update-daemon* nil) +(defvar *contract-tree-image-update-daemon-halt*) (defun contract-tree-image-update-daemon-loop () - (loop (contract-tree-update-images-if-needed) (sleep 10))) + (loop (when *contract-tree-image-update-daemon-halt* (return)) + (contract-tree-update-images-if-needed) + (sleep 10))) (defun contract-tree-image-update-daemon-running-p () (and *contract-tree-image-update-daemon* @@ -315,12 +318,14 @@ (defun start-contract-tree-image-update-daemon () (unless (contract-tree-image-update-daemon-running-p) - (bt:make-thread #'contract-tree-image-update-daemon-loop :name "contract-tree-image-update-daemon"))) + (setq *contract-tree-image-update-daemon-halt* nil) + (bt:make-thread #'contract-tree-image-update-daemon-loop + :name "contract-tree-image-update-daemon"))) (defun stop-contract-tree-image-update-daemon () - (when *contract-tree-image-update-daemon* - (bt:destroy-thread *contract-tree-image-update-daemon*) - (setq *contract-tree-image-update-daemon* nil))) + (when (contract-tree-image-update-daemon-running-p) + (setq *contract-tree-image-update-daemon-halt* t) + (warn "contract-tree-image-update-daemon will stop soon"))) ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 ()

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3458 Author: ksprotte URL: http://bknr.net/trac/changeset/3458 added contract-tree image update daemon U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-16 11:59:12 UTC (rev 3457) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-16 12:06:28 UTC (rev 3458) @@ -303,6 +303,25 @@ :date (blob-timestamp image) :max-age 600))))) +;; contract-tree image update daemon +(defvar *contract-tree-image-update-daemon* nil) + +(defun contract-tree-image-update-daemon-loop () + (loop (contract-tree-update-images-if-needed) (sleep 10))) + +(defun contract-tree-image-update-daemon-running-p () + (and *contract-tree-image-update-daemon* + (bt:thread-alive-p *contract-tree-image-update-daemon*))) + +(defun start-contract-tree-image-update-daemon () + (unless (contract-tree-image-update-daemon-running-p) + (bt:make-thread #'contract-tree-image-update-daemon-loop :name "contract-tree-image-update-daemon"))) + +(defun stop-contract-tree-image-update-daemon () + (when *contract-tree-image-update-daemon* + (bt:destroy-thread *contract-tree-image-update-daemon*) + (setq *contract-tree-image-update-daemon* nil))) + ;;; make-contract-tree-from-m2 (defun make-contract-tree-from-m2 () (setq *contract-tree* (make-instance 'contract-node @@ -314,7 +333,7 @@ (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (format t "~&rendering contract-tree images if needed...") (force-output) - (contract-tree-update-images-if-needed) + (start-contract-tree-image-update-daemon) (format t "done.~%") (force-output) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3457 Author: ksprotte URL: http://bknr.net/trac/changeset/3457 contract-tree new function (contract-tree-update-images-if-needed) that now is very fast in the case that there are no updates to be done U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-16 10:20:49 UTC (rev 3456) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-16 11:59:12 UTC (rev 3457) @@ -268,12 +268,26 @@ (delete-file (blob-pathname old-store-image)) (delete-object old-store-image))))))) +(defun contract-node-update-image-needed-p (node) + (or (null (image node)) + (> (timestamp node) (blob-timestamp (image node))))) + (defun contract-node-update-image-if-needed (node) - (when (or (null (image node)) - (not (probe-file (blob-pathname (image node)))) - (> (timestamp node) (blob-timestamp (image node)))) + (when (contract-node-update-image-needed-p node) (contract-node-update-image node))) +(defun contract-tree-update-images-if-needed () + ;; I did not see an easy way to avoid that + ;; CONTRACT-NODE-UPDATE-IMAGE-NEEDED-P is called twice for every + ;; node. Once inside CONTRACT-NODE-UPDATE-IMAGE-IF-NEEDED and once + ;; for the prune-test. + + ;; Let's hope we are lucky and there is nothing to do by inspecting + ;; *contract-tree* at first only once. + (when (contract-node-update-image-needed-p *contract-tree*) + (map-nodes #'contract-node-update-image-if-needed *contract-tree* + :prune-test (lambda (node) (not (contract-node-update-image-needed-p node)))))) + ;;; image handler (defclass contract-tree-image-handler (page-handler) ()) @@ -300,7 +314,7 @@ (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (format t "~&rendering contract-tree images if needed...") (force-output) - (map-nodes #'contract-node-update-image-if-needed *contract-tree*) + (contract-tree-update-images-if-needed) (format t "done.~%") (force-output) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/tsung.xml
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3456 Author: ksprotte URL: http://bknr.net/trac/changeset/3456 tsung.xml removed a few non-existing paths U trunk/projects/bos/test/tsung.xml Modified: trunk/projects/bos/test/tsung.xml =================================================================== --- trunk/projects/bos/test/tsung.xml 2008-07-16 09:53:09 UTC (rev 3455) +++ trunk/projects/bos/test/tsung.xml 2008-07-16 10:20:49 UTC (rev 3456) @@ -837,8 +837,7 @@ <request><http url='/contract-tree-kml?path=1232&lang=de' version='1.1' method='GET'></http></request> <request><http url='/image-tree-kml/2982650' version='1.1' method='GET'></http></request> <request><http url='/image-tree-kml/2982778' version='1.1' method='GET'></http></request> - <request><http url='/image-tree-kml/2982768' version='1.1' method='GET'></http></request> - <request><http url='/contract-tree-kml?path=3012&lang=de' version='1.1' method='GET'></http></request> + <request><http url='/image-tree-kml/2982768' version='1.1' method='GET'></http></request> <request><http url='/image-tree-kml/2984042' version='1.1' method='GET'></http></request> <request><http url='/contract-tree-kml?path=3003&lang=de' version='1.1' method='GET'></http></request> <request><http url='/image-tree-kml/2983924' version='1.1' method='GET'></http></request> @@ -932,8 +931,6 @@ <request><http url='/image/2984042' version='1.1' method='GET'></http></request> - <request><http url='/contract-tree-kml?path=30120&lang=de' version='1.1' method='GET'></http></request> - <request><http url='/contract-tree-image?path=3012' version='1.1' method='GET'></http></request> <request><http url='/contract-tree-kml?path=30031&lang=de' version='1.1' method='GET'></http></request> <request><http url='/contract-tree-image?path=3003' version='1.1' method='GET'></http></request> <request><http url='/image-tree-kml/2983922' version='1.1' method='GET'></http></request> @@ -1078,7 +1075,6 @@ <request><http url='/image/2984038' version='1.1' method='GET'></http></request> - <request><http url='/contract-tree-image?path=30120' version='1.1' method='GET'></http></request> <request><http url='/contract-tree-image?path=30031' version='1.1' method='GET'></http></request> <request><http url='/image/2983922' version='1.1' method='GET'></http></request>

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/tsung.xml
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3455 Author: ksprotte URL: http://bknr.net/trac/changeset/3455 updated old tsung.xml with new, existing contract ids U trunk/projects/bos/test/tsung.xml Modified: trunk/projects/bos/test/tsung.xml =================================================================== --- trunk/projects/bos/test/tsung.xml 2008-07-16 09:16:15 UTC (rev 3454) +++ trunk/projects/bos/test/tsung.xml 2008-07-16 09:53:09 UTC (rev 3455) @@ -450,39 +450,39 @@ <thinktime random='true' value='6'/> <request><http url='/m2-javascript/6610/6232' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3028251/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037429/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='2'/> <request><http url='/m2-javascript/6621/6227' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3026073/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037427/ffff00' version='1.1' method='GET'></http></request> <request><http url='/m2-javascript/6625/6222' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3024105/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037425/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='1'/> <request><http url='/m2-javascript/6635/6228' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3026085/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037423/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='2'/> <request><http url='/m2-javascript/6627/6237' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3028768/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037421/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='3'/> <request><http url='/m2-javascript/6662/6226' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3026801/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037419/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='1'/> <request><http url='/m2-javascript/6663/6228' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3026095/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037417/ffff00' version='1.1' method='GET'></http></request> <thinktime random='true' value='2'/> <request><http url='/m2-javascript/6662/6236' version='1.1' method='GET'></http></request> - <request><http url='/contract-image/3028792/ffff00' version='1.1' method='GET'></http></request> + <request><http url='/contract-image/3037407/ffff00' version='1.1' method='GET'></http></request> </session>

1 0

[bknr-cvs] edi changed trunk/thirdparty/drakma/
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3454 Author: edi URL: http://bknr.net/trac/changeset/3454 Integrate patch from Daniel Janus U trunk/thirdparty/drakma/CHANGELOG.txt U trunk/thirdparty/drakma/cookies.lisp U trunk/thirdparty/drakma/doc/index.html U trunk/thirdparty/drakma/packages.lisp U trunk/thirdparty/drakma/specials.lisp Modified: trunk/thirdparty/drakma/CHANGELOG.txt =================================================================== --- trunk/thirdparty/drakma/CHANGELOG.txt 2008-07-16 08:59:09 UTC (rev 3453) +++ trunk/thirdparty/drakma/CHANGELOG.txt 2008-07-16 09:16:15 UTC (rev 3454) @@ -1,3 +1,5 @@ +Added *ALLOW-DOTLESS-COOKIE-DOMAINS-P* (thanks to Daniel Janus) + Version 0.11.5 2008-03-21 Added workaround for CLISP (thanks to Anton Vodonosov) Modified: trunk/thirdparty/drakma/cookies.lisp =================================================================== --- trunk/thirdparty/drakma/cookies.lisp 2008-07-16 08:59:09 UTC (rev 3453) +++ trunk/thirdparty/drakma/cookies.lisp 2008-07-16 09:16:15 UTC (rev 3454) @@ -93,8 +93,10 @@ (defun valid-cookie-domain-p (domain) "Checks if the string DOMAIN contains enough dots to be -acceptable." - (or (string-equal domain "localhost") +acceptable. If *ALLOW-DOTLESS-COOKIE-DOMAINS-P* is non-NIL, +every domain name is considered acceptable." + (or *allow-dotless-cookie-domains-p* + (string-equal domain "localhost") (> (count #\. (normalize-cookie-domain domain) :test #'char=) 1))) (defun cookie-domain-matches (domain uri) Modified: trunk/thirdparty/drakma/doc/index.html =================================================================== --- trunk/thirdparty/drakma/doc/index.html 2008-07-16 08:59:09 UTC (rev 3453) +++ trunk/thirdparty/drakma/doc/index.html 2008-07-16 09:16:15 UTC (rev 3454) @@ -84,6 +84,7 @@ <li><a href="#cookie-jar-cookies"><code>cookie-jar-cookies</code></a> <li><a href="#cookie="><code>cookie=</code></a> <li><a href="#delete-old-cookies"><code>delete-old-cookies</code></a> + <li><a href="#*allow-dotless-cookie-domains-p*"><code>*allow-dotless-cookie-domains-p*</code></a> <li><a href="#*ignore-unparseable-cookie-dates-p*"><code>*ignore-unparseable-cookie-dates-p*</code></a> </ol> <li><a href="#headers">Headers</a> @@ -1261,6 +1262,20 @@  + + + [Special variable] <a class=none name='*allow-dotless-cookie-domains-p*'>*allow-dotless-cookie-domains-p*</a> +<blockquote> + +When this variable is not <code>NIL</code>, cookie domains containing +no dots are considered valid. The default is <code>NIL</code>, +meaning to disallow such domains except for <code>"localhost"<code>. + +</blockquote> + + + +  [Special variable] <a class=none name='*ignore-unparseable-cookie-dates-p*'>*ignore-unparseable-cookie-dates-p*</a> Modified: trunk/thirdparty/drakma/packages.lisp =================================================================== --- trunk/thirdparty/drakma/packages.lisp 2008-07-16 08:59:09 UTC (rev 3453) +++ trunk/thirdparty/drakma/packages.lisp 2008-07-16 09:16:15 UTC (rev 3454) @@ -33,7 +33,8 @@ (:use :cl :puri :flexi-streams :chunga) ;; the variable defined in the ASDF system definition (:import-from :drakma-asd :*drakma-version-string*) - (:export :*body-format-function* + (:export :*allow-dotless-cookie-domains-p* + :*body-format-function* :*drakma-default-external-format* :*header-stream* :*ignore-unparseable-cookie-dates-p* Modified: trunk/thirdparty/drakma/specials.lisp =================================================================== --- trunk/thirdparty/drakma/specials.lisp 2008-07-16 08:59:09 UTC (rev 3453) +++ trunk/thirdparty/drakma/specials.lisp 2008-07-16 09:16:15 UTC (rev 3454) @@ -70,6 +70,11 @@ which incoming and outgoing headers will be written for debugging purposes.") +(defvar *allow-dotless-cookie-domains-p* nil + "When this variable is not NIL, cookie domains containing no dots +are considered valid. The default is NIL, meaning to disallow such +domains except for \"localhost\".") + (defvar *ignore-unparseable-cookie-dates-p* nil "Whether Drakma is allowed to treat `Expires' dates in cookie headers as non-existent if it can't parse them. If the value of this

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/fixtures.lisp
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3453 Author: ksprotte URL: http://bknr.net/trac/changeset/3453 made bos test fixture INITIAL-BOS-STORE more robust for ccl U trunk/projects/bos/test/fixtures.lisp Modified: trunk/projects/bos/test/fixtures.lisp =================================================================== --- trunk/projects/bos/test/fixtures.lisp 2008-07-15 15:44:31 UTC (rev 3452) +++ trunk/projects/bos/test/fixtures.lisp 2008-07-16 08:59:09 UTC (rev 3453) @@ -56,8 +56,9 @@ :website-url bos.m2::*website-url*) (make-user "anonymous") ; needed for web tests (&body)) - (close-store) - (cl-fad:delete-directory-and-files store-path)))) + (close-store) + ;; (cl-fad:delete-directory-and-files store-path) ; fails on ccl + (asdf:run-shell-command "rm -r '~A'" store-path)))) (defmacro store-test (name &body body) `(progn

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3452 Author: ksprotte URL: http://bknr.net/trac/changeset/3452 poi-kml-all-handler now uses last-modifiepoi-kml-all-handler now uses last-modifiedd U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-15 14:37:26 UTC (rev 3451) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-15 15:44:31 UTC (rev 3452) @@ -576,22 +576,26 @@ ()) (defmethod handle ((handler poi-kml-all-handler)) - (with-query-params ((lang "en")) - (with-xml-response () - ;; (sax:processing-instruction cxml::*sink* "xml-stylesheet" "href=\"/static/tri.xsl\" type=\"text/xsl\"") - (with-namespace (nil "http://earth.google.com/kml/2.1") - (with-element "kml" - (with-element "Document" - (with-element "Style" - (attribute "id" "poiPlacemarkIcon") - (with-element "IconStyle" - ;; (with-element "color" (text "ffffffff")) - (with-element "scale" (text "0.8")) - (with-element "Icon" - (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) - (mapc #'(lambda (poi) (write-poi-kml poi lang)) - (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published poi))) - (class-instances 'poi))))))))) + (let* ((relevant-pois (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published poi))) + (class-instances 'poi))) + (pois-last-change (reduce #'max relevant-pois :key (lambda (poi) (store-object-last-change poi 1))))) + (hunchentoot:handle-if-modified-since pois-last-change) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date pois-last-change)) + (with-query-params ((lang "en")) + (with-xml-response () + ;; (sax:processing-instruction cxml::*sink* "xml-stylesheet" "href=\"/static/tri.xsl\" type=\"text/xsl\"") + (with-namespace (nil "http://earth.google.com/kml/2.1") + (with-element "kml" + (with-element "Document" + (with-element "Style" + (attribute "id" "poiPlacemarkIcon") + (with-element "IconStyle" + ;; (with-element "color" (text "ffffffff")) + (with-element "scale" (text "0.8")) + (with-element "Icon" + (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) + (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) + (mapc #'(lambda (poi) (write-poi-kml poi lang)) relevant-pois))))))))

1 0

[bknr-cvs] ksprotte changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 15 Jul '08

15 Jul '08

Revision: 3451 Author: ksprotte URL: http://bknr.net/trac/changeset/3451 dont update store-object's last-change slot during restore U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-15 14:13:49 UTC (rev 3450) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-15 14:37:26 UTC (rev 3451) @@ -89,7 +89,8 @@ (not (in-transaction-p))) (error "Attempt to set persistent slot ~A of ~A outside of a transaction" slot-name object)) - (unless (eq 'last-change slot-name) + (unless (or (eq :restore (store-state *store*)) + (eq 'last-change slot-name)) (setf (slot-value object 'last-change) (current-transaction-timestamp))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd)

1 0