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

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

22 Jul '08

Revision: 3550 Author: ksprotte URL: http://bknr.net/trac/changeset/3550 better implementation for contract-tree-needs-update-p 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-22 10:42:59 UTC (rev 3549) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-22 10:51:32 UTC (rev 3550) @@ -299,11 +299,7 @@ (map-nodes #'contract-node-update-image *contract-tree*)) (defun contract-tree-needs-update-p () - (map-nodes (lambda (node) (when (contract-node-update-image-needed-p node) - (return-from contract-tree-needs-update-p t))) - *contract-tree* - :order :breadth-first) - nil) + (contract-node-update-image-needed-p *contract-tree*)) ;;; image handler (defclass contract-tree-image-handler (page-handler)

1 0

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

22 Jul '08

Revision: 3549 Author: ksprotte URL: http://bknr.net/trac/changeset/3549 added CONTRACT-TREE-NEEDS-UPDATE-P 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-22 09:48:51 UTC (rev 3548) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-22 10:42:59 UTC (rev 3549) @@ -298,6 +298,13 @@ (defun contract-tree-force-update-images () (map-nodes #'contract-node-update-image *contract-tree*)) +(defun contract-tree-needs-update-p () + (map-nodes (lambda (node) (when (contract-node-update-image-needed-p node) + (return-from contract-tree-needs-update-p t))) + *contract-tree* + :order :breadth-first) + nil) + ;;; image handler (defclass contract-tree-image-handler (page-handler) ())

1 0

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

22 Jul '08

Revision: 3548 Author: ksprotte URL: http://bknr.net/trac/changeset/3548 WRITE-POI-XML now uses LANGUAGE and presents a correct Spenden link 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-22 09:35:08 UTC (rev 3547) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-22 09:48:51 UTC (rev 3548) @@ -431,8 +431,10 @@ (attribute "title" (poi-string 'title)) (attribute "subtitle" (poi-string 'subtitle)) (with-element "menu" - (with-element "entry" (attribute "title" "Impressum") (attribute "href" "/de/impressum")) - (with-element "entry" (attribute "title" "Spenden") (attribute "href" "/de/spenden"))) + (with-element "entry" (attribute "title" "Impressum") + (attribute "href" (format nil "/~A/impressum" language))) + (with-element "entry" (attribute "title" "Spenden") + (attribute "href" (format nil "/~A/bestellung" language)))) (with-element "description" (text (poi-string 'description))) (with-media ("image_gallery" "Bildergalerie") (mapc #'format-image images))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/mail-generator.lisp
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3547 Author: ksprotte URL: http://bknr.net/trac/changeset/3547 fixed bug reported by vivian. "fehler bei ueberweisung ohne email Mir ist im Laufe der Tage folgendes aufgefallen: wenn ueberweiser keine emailadresse angeben und dann ueber den link aktiviert werden kommt eine Fehlermeldung die besag could not be proceeded, must contain domain bla.... Der Sponsor wird aber dann trotzdem als bezahlt eingerichtet und sein Profil erstellt. Diese Fehlermeldung muss heissen: "Sponsor processed, but not informed because no mail address" oder so was....." U trunk/projects/bos/m2/mail-generator.lisp Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2008-07-22 08:56:46 UTC (rev 3546) +++ trunk/projects/bos/m2/mail-generator.lisp 2008-07-22 09:35:08 UTC (rev 3547) @@ -327,7 +327,7 @@ vorname name strasse plz ort email telefon (if want-print "yes" "no") (if donationcert-yearly "yes" "no") - *website-url* contract-id email)) + *website-url* contract-id (or email ""))) (make-contract-xml-part contract-id (all-request-params)) (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id :note (format nil "Paid-by: Manual money transfer

1 0

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

22 Jul '08

Revision: 3546 Author: ksprotte URL: http://bknr.net/trac/changeset/3546 small fix for an assertion in make-sat-layer highest local-draw-order is reserved for the contract-tree, so make-sat-layer checks that this last level is not used for the sat-layer U trunk/projects/bos/web/sat-tree.lisp Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-07-22 08:50:30 UTC (rev 3545) +++ trunk/projects/bos/web/sat-tree.lisp 2008-07-22 08:56:46 UTC (rev 3546) @@ -185,7 +185,8 @@ (assert (geo-box-encloses-p *m2-geo-box* geo-box)) (check-type start-depth (integer 0)) (check-type local-draw-order (integer 0)) - (assert (< local-draw-order +max-num-of-local-draw-order-levels+)) + ;; highest local-draw-order is reserved for the contract-tree + (assert (< local-draw-order (1- +max-num-of-local-draw-order-levels+))) (when (find local-draw-order (class-instances 'sat-layer) :key #'local-draw-order) (cerror "create the new layer anyway" "There is already a sat-layer with the same local-draw-order '~A'." local-draw-order)) (let ((layer (make-object 'sat-layer :name name :geo-box geo-box :local-draw-order local-draw-order)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3545 Author: ksprotte URL: http://bknr.net/trac/changeset/3545 need to write now bos.m2.allocation-cache::rebuild-cache in two exceptional places U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-22 08:45:49 UTC (rev 3544) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-22 08:50:30 UTC (rev 3545) @@ -220,13 +220,13 @@ (deftransaction activate-allocation-area (area) (warn "activating ~S" area) (setf (slot-value area 'active-p) t) - (bos.m2.allocation-cache:rebuild-cache) + (bos.m2.allocation-cache::rebuild-cache) area) (deftransaction deactivate-allocation-area (area) (warn "deactivating ~S" area) (setf (slot-value area 'active-p) nil) - (bos.m2.allocation-cache:rebuild-cache) + (bos.m2.allocation-cache::rebuild-cache) area) ;;; FIXME can be optimized

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3544 Author: ksprotte URL: http://bknr.net/trac/changeset/3544 rebuild-cache should not be exported; fix for test ALLOCATION-AREA.TWO-AREAS U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-22 08:35:04 UTC (rev 3543) +++ trunk/projects/bos/m2/packages.lisp 2008-07-22 08:45:49 UTC (rev 3544) @@ -289,7 +289,6 @@ (:export #:find-exact-match #:add-area #:count-cache-entries - #:pprint-cache - #:rebuild-cache + #:pprint-cache #:allocation-cache-subsystem)) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-22 08:35:04 UTC (rev 3543) +++ trunk/projects/bos/test/allocation.lisp 2008-07-22 08:45:49 UTC (rev 3544) @@ -76,8 +76,7 @@ (sponsor (make-sponsor :login "test-sponsor")) (total-free (+ 64 64))) (progn - (iter (while (> total-free 20)) - (bos.m2.allocation-cache:rebuild-cache) + (iter (while (> total-free 20)) (for size = (1+ (random 3))) (is (= total-free (+ (allocation-area-free-m2s area1) (allocation-area-free-m2s area2))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation-cache.lisp
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3543 Author: ksprotte URL: http://bknr.net/trac/changeset/3543 rebuild-cache: assert (in-transaction-p) U trunk/projects/bos/m2/allocation-cache.lisp Modified: trunk/projects/bos/m2/allocation-cache.lisp =================================================================== --- trunk/projects/bos/m2/allocation-cache.lisp 2008-07-22 08:32:05 UTC (rev 3542) +++ trunk/projects/bos/m2/allocation-cache.lisp 2008-07-22 08:35:04 UTC (rev 3543) @@ -232,7 +232,8 @@ (format t "~5D~10T~5D~%" size count)))))) (defun rebuild-cache () - "" + (assert (in-transaction-p) nil + "rebuild-cache may only be called in a transaction context") (unless *allocation-cache* (setq *allocation-cache* (make-allocation-cache))) (clear-cache)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3542 Author: ksprotte URL: http://bknr.net/trac/changeset/3542 removed (bos.m2.allocation-cache:rebuild-cache) from daily job, cause it is done in snapshot (and wrong to do there anyway - because rebuild-cache is not a transaction, but would need to be logged) U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/web/daily.lisp Modified: trunk/projects/bos/m2/allocation-cache.lisp =================================================================== --- trunk/projects/bos/m2/allocation-cache.lisp 2008-07-22 05:40:55 UTC (rev 3541) +++ trunk/projects/bos/m2/allocation-cache.lisp 2008-07-22 08:32:05 UTC (rev 3542) @@ -232,6 +232,7 @@ (format t "~5D~10T~5D~%" size count)))))) (defun rebuild-cache () + "" (unless *allocation-cache* (setq *allocation-cache* (make-allocation-cache))) (clear-cache) Modified: trunk/projects/bos/web/daily.lisp =================================================================== --- trunk/projects/bos/web/daily.lisp 2008-07-22 05:40:55 UTC (rev 3541) +++ trunk/projects/bos/web/daily.lisp 2008-07-22 08:32:05 UTC (rev 3542) @@ -7,8 +7,6 @@ (bknr.stats::make-yesterdays-stats :delete-events t) (format t "; snapshotting datastore~%") (snapshot) - (format t "; rebuilding allocation-cache~%") - (bos.m2.allocation-cache:rebuild-cache) (format t "; running check (consistent-p)~%") (flet ((consistent-p-report () (let (consistent-p)

1 0

[bknr-cvs] hans changed trunk/projects/pch/src/pch
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3541 Author: hans URL: http://bknr.net/trac/changeset/3541 snapshot intermediate state U trunk/projects/pch/src/pch.erl A trunk/projects/pch/src/pch_cache_mgr.erl A trunk/projects/pch/src/pch_front.erl Modified: trunk/projects/pch/src/pch.erl =================================================================== --- trunk/projects/pch/src/pch.erl 2008-07-21 15:40:49 UTC (rev 3540) +++ trunk/projects/pch/src/pch.erl 2008-07-22 05:40:55 UTC (rev 3541) @@ -3,39 +3,15 @@ -module(pch). -export([start/0, loop/2, stop/0]). --define(DEFAULTS, [{name, ?MODULE}, - {port, 9888}]). +-define(HTTP_PORT, 9888). +-define(MANAGEMENT_PORT, 9889). start() -> Cache = ets:new(table, [set, public]), - Loop = fun (Req) -> ?MODULE:loop(Req, Cache) end, - mochiweb_http:start([{loop, Loop} | ?DEFAULTS]). + pch_cache_mgr:start(?MANAGEMENT_PORT, Cache), + pch_front:start(?HTTP_PORT, Cache). stop() -> - mochiweb_http:stop(?MODULE). + pch_front:stop(), + pch_cache_mgr:stop(). -fetch_from_backend(Path) -> - {ok, {{_Version, 200, _ReasonPhrase}, Headers, Body}} = - http:request("http://test.createrainforest.org" ++ Path), - {ok, Headers, Body}. - -backend_request(Req, Cache) -> - Path = Req:get(path), - case ets:lookup(Cache, Path) of - [{Path, Headers, Body}] -> - io:format("cache HIT for ~p~n", [Path]), - Req:respond({200, Headers, Body}); - _ -> - io:format("cache MISS for ~p~n", [Path]), - {ok, Headers, Body} = fetch_from_backend(Path), - ets:insert(Cache, {Path, Headers, Body}), - Req:respond({200, Headers, Body}) - end. - -loop(Req, Cache) -> - case Req:get(method) of - M when M =:= 'GET' -> - backend_request(Req, Cache); - _ -> - Req:respond({501, [], ""}) - end. Added: trunk/projects/pch/src/pch_cache_mgr.erl =================================================================== --- trunk/projects/pch/src/pch_cache_mgr.erl (rev 0) +++ trunk/projects/pch/src/pch_cache_mgr.erl 2008-07-22 05:40:55 UTC (rev 3541) @@ -0,0 +1,19 @@ +-module(pch_cache_mgr). +-export([start/1, loop/2, stop/0]). + +start(Port, Cache) -> + mochiweb_http:start([{loop, fun (Req) -> + ?MODULE:loop(Req, Cache) end}, + {port, Port}, + {name, ?MODULE}]). + +stop() -> + mochiweb_http:stop(?MODULE). + +loop(Req, Cache) -> + case Req:get(method) of + M when M =:= 'GET' -> + backend_request(Req, Cache); + _ -> + Req:respond({501, [], ""}) + end. Added: trunk/projects/pch/src/pch_front.erl =================================================================== --- trunk/projects/pch/src/pch_front.erl (rev 0) +++ trunk/projects/pch/src/pch_front.erl 2008-07-22 05:40:55 UTC (rev 3541) @@ -0,0 +1,37 @@ +-module(pch_front). +-export([start/0, loop/2, stop/0]). + +start(Port, Cache) -> + mochiweb_http:start([{loop, fun (Req) -> + ?MODULE:loop(Req, Cache) end}, + {port, Port}, + {name, ?MODULE}]). + +stop() -> + mochiweb_http:stop(?MODULE), + +fetch_from_backend(Path) -> + {ok, {{_Version, 200, _ReasonPhrase}, Headers, Body}} = + http:request("http://test.createrainforest.org" ++ Path), + {ok, Headers, Body}. + +backend_request(Req, Cache) -> + Path = Req:get(path), + case ets:lookup(Cache, Path) of + [{Path, Headers, Body}] -> + io:format("cache HIT for ~p~n", [Path]), + Req:respond({200, Headers, Body}); + _ -> + io:format("cache MISS for ~p~n", [Path]), + {ok, Headers, Body} = fetch_from_backend(Path), + ets:insert(Cache, {Path, Headers, Body}), + Req:respond({200, Headers, Body}) + end. + +loop(Req, Cache) -> + case Req:get(method) of + M when M =:= 'GET' -> + backend_request(Req, Cache); + _ -> + Req:respond({501, [], ""}) + end.

1 0