bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] hans changed trunk/projects/quickhoney/
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3473 Author: hans URL: http://bknr.net/trac/changeset/3473 Snapshot U trunk/projects/quickhoney/src/init.lisp A trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Overlay_01.png A trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Pixel_06_1_floating_flat.png A trunk/projects/quickhoney/upgrade-stuff/button-bottom.gif A trunk/projects/quickhoney/upgrade-stuff/buy.gif A trunk/projects/quickhoney/upgrade-stuff/hey.gif U trunk/projects/quickhoney/upgrade-stuff/import.lisp A trunk/projects/quickhoney/upgrade-stuff/overlay-close.gif U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/src/init.lisp =================================================================== --- trunk/projects/quickhoney/src/init.lisp 2008-07-16 15:17:06 UTC (rev 3472) +++ trunk/projects/quickhoney/src/init.lisp 2008-07-16 18:11:24 UTC (rev 3473) @@ -1,22 +1,33 @@ (in-package :quickhoney) +(defvar *dumped-image* nil) + +(defun dump-executable () + #+openmcl + (ccl:save-application "quickhoney" :prepend-kernel t)) + (defun startup () - (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) - (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) - (close-store) - (make-instance 'store - :directory *store-directory* - :subsystems (list (make-instance 'store-object-subsystem) - (make-instance 'blob-subsystem - :n-blobs-per-directory 1000))) + (cond + (*dumped-image* + (asdf:oos 'asdf:load-op :quickhoney) + (format t "; starting from dumped image, skipping store initialization~%")) + (t + (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) + (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) + (close-store) + (make-instance 'store + :directory *store-directory* + :subsystems (list (make-instance 'store-object-subsystem) + (make-instance 'blob-subsystem + :n-blobs-per-directory 1000))) - (unless (class-instances 'bknr.cron::cron-job) - (bknr.cron:make-cron-job "daily statistics" 'make-yesterdays-statistics 1 0 :every :every) - (bknr.cron:make-cron-job "snapshot" 'snapshot-store 0 5 :every :every)) - (unless (class-instances 'rss-channel) - (make-rss-channel "quickhoney" "QuickHoney" "QuickHoney Illustrations" "rss/quickhoney" - :items (class-instances 'quickhoney-image))) - (cl-gd::load-gd-glue) + (unless (class-instances 'bknr.cron::cron-job) + (bknr.cron:make-cron-job "daily statistics" 'make-yesterdays-statistics 1 0 :every :every) + (bknr.cron:make-cron-job "snapshot" 'snapshot-store 0 5 :every :every)) + (unless (class-instances 'rss-channel) + (make-rss-channel "quickhoney" "QuickHoney" "QuickHoney Illustrations" "rss/quickhoney" + :items (class-instances 'quickhoney-image))) + (cl-gd::load-gd-glue))) #+cmu (actor-start (make-instance 'cron-actor)) (publish-quickhoney) Added: trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Overlay_01.png =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Overlay_01.png ___________________________________________________________________ Name: svn:executable + * Name: svn:mime-type + application/octet-stream Added: trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Pixel_06_1_floating_flat.png =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/QH_Layout_Pixel_06_1_floating_flat.png ___________________________________________________________________ Name: svn:executable + * Name: svn:mime-type + application/octet-stream Added: trunk/projects/quickhoney/upgrade-stuff/button-bottom.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/button-bottom.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: trunk/projects/quickhoney/upgrade-stuff/buy.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/buy.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: trunk/projects/quickhoney/upgrade-stuff/hey.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/hey.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/quickhoney/upgrade-stuff/import.lisp =================================================================== --- trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-07-16 15:17:06 UTC (rev 3472) +++ trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-07-16 18:11:24 UTC (rev 3473) @@ -3,4 +3,7 @@ (dolist (name '(#p"type-news.png" #p"type-pixel.png" #p"type-shop.png" #p"type-vector.png")) (import-image name :keywords '(:type))) +(dolist (name '(#P"overlay-close.gif" #P"hey.gif" #P"buy.gif" #P"button-bottom.gif")) + (import-image name)) + (import-image #p"news-sep.png") \ No newline at end of file Added: trunk/projects/quickhoney/upgrade-stuff/overlay-close.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/overlay-close.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-16 15:17:06 UTC (rev 3472) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-16 18:11:24 UTC (rev 3473) @@ -49,7 +49,7 @@ for (var i = 0; i < arguments.length; i++) { message += arguments[i]; } - if (window.console.log) { + if (window.console && window.console.log) { window.console.log(message); } if (want_debugger) { @@ -869,10 +869,10 @@ footer_hide(); display_path(); make_images_navbar(); + make_image_action_buttons(); $("results").style.visibility = 'hidden'; $("browse").style.visibility = 'visible'; - $("digg_picture_name").innerHTML = current_image.name; var ratio = 1 / Math.max(current_image.width / 648, current_image.height / 648); var imageproc_ops = ""; @@ -972,13 +972,14 @@ } } -function digg_send() +function hey_send() { var d = doXHR("/digg-image/" + current_image.id, { method: 'POST', headers: {"Content-Type":"application/x-www-form-urlencoded"}, - sendContent: queryString({ from: $('digg_from').value, text: $('digg_text').value }) }) - .addCallback(function () { alert('sent'); }); + sendContent: queryString({ from: $('hey_from').value, text: $('hey_text').value }) }) + .addCallback(hide_overlay); + make_overlay('send-comment', 'Sending your comment', 300); return false; } @@ -1144,3 +1145,78 @@ { document.location.href = document.location.href.replace(/\/image-browse.*/, "index#"); } + +function hide_overlay() +{ + $('overlay').style.visibility = 'hidden'; + return false; +} + +/* make_overlay() opens an overlay window with the given title. + * Additional arguments passed are assumed to be DOM child nodes and + * are added to the overlay window. + */ + +function make_overlay(id, title, width) +{ + var overlay = $('overlay'); + overlay.className = current_directory; + replaceChildNodes(overlay, + H1(null, title), + IMG({ src: '/image/overlay-close/color,000000,' + pages[current_directory].colors[2], + id: 'close', width: 13, height: 13})); + overlay.style.width = width + 'px'; + $('close').style.left = (width - 23) + 'px'; + $('close').onclick = hide_overlay; + var elements = []; + for (var i = 3; i < arguments.length; i++) { + elements.push(arguments[i]); + } + appendChildNodes(overlay, DIV({id: id}, elements)); + overlay.style.visibility = 'inherit'; +} + +function make_hey_form() +{ + var subject = 'Comment on ' + current_image.name; + make_overlay('hey', 'Comment', 320, + FORM({ method: 'POST', action: '#' }, + 'email', + BR(), + INPUT({ type: 'text', id: 'hey_from', value: '' }), + BR(), + BR(), + 'comment', + BR(), + TEXTAREA({ name: 'text', id: 'hey_text', rows: 4, columns: 40 }, ''), + BR(), + INPUT({ type: 'submit', id: 'hey_send', value: 'Send' }))); + $('hey_send').onclick = hey_send; +} + +function make_buy_form() +{ +} + +function recolored_image_path(name) +{ + return '/image/' + name + '/color,000000,' + pages[current_directory].colors[2]; +} + +function make_image_action_button(name, action) +{ + var div = DIV(null, IMG({ src: recolored_image_path(name), width: 60, height: 23 })); + div.onclick = function() { action(); return false; }; + return div; +} + +function make_image_action_buttons() +{ + var buttons = []; + if (1 || current_image.download_product) { + buttons.push(make_image_action_button('buy', make_buy_form)); + } + buttons.push(make_image_action_button('hey', make_hey_form)); + buttons.push(DIV(null, IMG({ src: recolored_image_path('button-bottom'), width: 60, height: 1 }))); + replaceChildNodes('image_action_buttons', buttons); +} \ No newline at end of file Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-16 15:17:06 UTC (rev 3472) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-16 18:11:24 UTC (rev 3473) @@ -377,17 +377,6 @@ z-index: 1; } -/* digg form */ - -div#digg { - position: absolute; - left: 700px; - top: 500px; - z-index: 10; - background-color: #eee; - padding: 10px; -} - /* news styles */ div#news_page { @@ -495,3 +484,48 @@ #frontpage div p { margin: 2em; } + +#overlay { + z-index: 100; + position: absolute; + background: white; + border: 1px solid #000000; + margin: 0px; + padding: 0px; +} + +#overlay #close { + position: absolute; + top: 12px; +} + +#overlay h1 { + margin-left: 10px; +} + +#overlay.pixel h1, #overlay.pixel h2 { + color: #ff00ff; +} + +#overlay.vector h1, #overlay.vector h2 { + color: #00ccff; +} + +#image_action_buttons { + position: absolute; + left: 584px; + top: 32px; + z-index: 100; +} + +#overlay #hey { + padding: 10px 15px 10px 10px; +} + +#overlay #hey #hey_from, #overlay #hey textarea { + width: 100%; +} + +#overlay #hey #hey_send { + margin-top: 5px; +} \ No newline at end of file Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-16 15:17:06 UTC (rev 3472) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-16 18:11:24 UTC (rev 3473) @@ -24,6 +24,9 @@ <body id="body"> + <div id="overlay"> + </div> + <div id="menu"> <a onclick="show_page('home')" href="#home"> <img alt="home" class="menu" id="m_home" src="/image/quickhoney" /> @@ -108,6 +111,9 @@ </span> </span> + <div id="image_action_buttons"> + </div> + <div id="image_detail"> </div> @@ -175,18 +181,6 @@ </div> </div> - <div id="digg"> - <form id="digg_form" method="post" action="#"> - From: <input type="text" id="digg_from" value=""/> - <br/> - Your comment on <b id="digg_picture_name"> </b>: - <br/> - <textarea name="text" id="digg_text" rows="10" cols="60"> </textarea> - <br/> - <button type="submit" onclick="return digg_send();">send</button> - </form> - </div> -  <div id="cms">

1 0

[bknr-cvs] hans changed trunk/bknr/LICENSE
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3472 Author: hans URL: http://bknr.net/trac/changeset/3472 update LICENSE U trunk/bknr/LICENSE Modified: trunk/bknr/LICENSE =================================================================== --- trunk/bknr/LICENSE 2008-07-16 15:14:37 UTC (rev 3471) +++ trunk/bknr/LICENSE 2008-07-16 15:17:06 UTC (rev 3472) @@ -1,4 +1,5 @@ -Copyright (c) 2003,2004,2005, BKNR (Hans Hübner, Manuel Odendahl) +Copyright (c) 2003-2008 BKNR (Hans Hübner, Manuel Odendahl, +David Lichteblau, Kilian Sprotte) All rights reserved. Redistribution and use in source and binary forms, with or without

1 0

[bknr-cvs] hans changed buildbot/master/Makefile
by BKNR Commits 16 Jul '08

16 Jul '08

Revision: 3471 Author: hans URL: http://bknr.net/trac/changeset/3471 dummy change to trigger update U buildbot/master/Makefile Modified: buildbot/master/Makefile =================================================================== --- buildbot/master/Makefile 2008-07-16 15:05:15 UTC (rev 3470) +++ buildbot/master/Makefile 2008-07-16 15:14:37 UTC (rev 3471) @@ -20,3 +20,4 @@ update: svn update +

1 0

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

16 Jul '08

Revision: 3470 Author: ksprotte URL: http://bknr.net/trac/changeset/3470 renamed allocation-cache to allocation-area-inclusion-cache U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-07-16 14:50:25 UTC (rev 3469) +++ trunk/projects/bos/m2/map.lisp 2008-07-16 15:05:15 UTC (rev 3470) @@ -79,11 +79,12 @@ (setf (ldb (byte 8 0) pixel-rgb-value) blue) pixel-rgb-value)) -(defstruct (allocation-cache (:conc-name ac-)) +;;; allocation-area-inclusion-cache +(defstruct (allocation-area-inclusion-cache (:conc-name ac-)) x y width height array areas) -(defvar *allocation-cache* nil - "allocation-cache struct indicating whether a certain square meter is inside of an allocation area") +(defvar *allocation-area-inclusion-cache* nil + "allocation-area-inclusion-cache struct indicating whether a certain square meter is inside of an allocation area") (defun point-in-any-allocation-area-p% (x-coord y-coord) (find-if #'(lambda (allocation-area) @@ -92,13 +93,13 @@ (point-in-polygon-p x-coord y-coord (allocation-area-vertices allocation-area)))) (store-objects-with-class 'allocation-area))) -(defun initialize-allocation-cache () +(defun initialize-allocation-area-inclusion-cache () (destructuring-bind (x y width height) (allocation-areas-bounding-box) - (setf *allocation-cache* - (make-allocation-cache :x x :y y :width width :height height + (setf *allocation-area-inclusion-cache* + (make-allocation-area-inclusion-cache :x x :y y :width width :height height :array (make-array (list width height) :element-type '(unsigned-byte 1)) :areas (class-instances 'allocation-area)))) - (dolist (area (ac-areas *allocation-cache*)) + (dolist (area (ac-areas *allocation-area-inclusion-cache*)) (destructuring-bind (top-left-x top-left-y width height) (allocation-area-bounding-box2 area) (dotimes (x width) (dotimes (y height) @@ -106,26 +107,26 @@ (y-coord (+ y top-left-y))) (when (and (point-in-polygon-p x-coord y-coord (allocation-area-bounding-box area)) (point-in-polygon-p x-coord y-coord (allocation-area-vertices area))) - (setf (aref (ac-array *allocation-cache*) - (- x-coord (ac-x *allocation-cache*)) - (- y-coord (ac-y *allocation-cache*))) + (setf (aref (ac-array *allocation-area-inclusion-cache*) + (- x-coord (ac-x *allocation-area-inclusion-cache*)) + (- y-coord (ac-y *allocation-area-inclusion-cache*))) 1)))))))) -(defvar *allocation-cache-lock* (bt:make-lock "Area Cache Lock")) +(defvar *allocation-area-inclusion-cache-lock* (bt:make-lock "Area Cache Lock")) -(defun validate-allocation-cache () - (bt:with-lock-held (*allocation-cache-lock*) - (unless (and *allocation-cache* +(defun validate-allocation-area-inclusion-cache () + (bt:with-lock-held (*allocation-area-inclusion-cache-lock*) + (unless (and *allocation-area-inclusion-cache* (equal (class-instances 'allocation-area) - (ac-areas *allocation-cache*))) - (initialize-allocation-cache)))) + (ac-areas *allocation-area-inclusion-cache*))) + (initialize-allocation-area-inclusion-cache)))) (defun point-in-any-allocation-area-p (x-coord y-coord) - (and (< -1 (- x-coord (ac-x *allocation-cache*)) (ac-width *allocation-cache*)) - (< -1 (- y-coord (ac-y *allocation-cache*)) (ac-height *allocation-cache*)) - (plusp (aref (ac-array *allocation-cache*) - (- x-coord (ac-x *allocation-cache*)) - (- y-coord (ac-y *allocation-cache*)))))) + (and (< -1 (- x-coord (ac-x *allocation-area-inclusion-cache*)) (ac-width *allocation-area-inclusion-cache*)) + (< -1 (- y-coord (ac-y *allocation-area-inclusion-cache*)) (ac-height *allocation-area-inclusion-cache*)) + (plusp (aref (ac-array *allocation-area-inclusion-cache*) + (- x-coord (ac-x *allocation-area-inclusion-cache*)) + (- y-coord (ac-y *allocation-area-inclusion-cache*)))))) (defclass image-tile (tile) ((original-image :documentation "Original satellite image" @@ -152,7 +153,7 @@ (copy-image original-image *default-image* 0 0 0 0 (image-width) (image-height))))) (defmethod image-tile-process ((tile image-tile) (operation (eql :areas))) - (validate-allocation-cache) + (validate-allocation-area-inclusion-cache) (do-rows (y) (do-pixels-in-row (x) (when (point-in-any-allocation-area-p (tile-absolute-x tile x) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-16 14:50:25 UTC (rev 3469) +++ trunk/projects/bos/test/allocation.lisp 2008-07-16 15:05:15 UTC (rev 3470) @@ -208,7 +208,7 @@ (make-allocation-rectangle 0 0 8 8) (finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp nil)))) -(test validate-allocation-cache +(test validate-allocation-area-inclusion-cache (with-fixture initial-bos-store () (let ((area1 (make-allocation-rectangle 0 0 8 8))) - (finishes (bos.m2::validate-allocation-cache))))) \ No newline at end of file + (finishes (bos.m2::validate-allocation-area-inclusion-cache))))) \ No newline at end of file

1 0

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

16 Jul '08

Revision: 3469 Author: ksprotte URL: http://bknr.net/trac/changeset/3469 use with-transaction around setf allocation-area bounding-box U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-16 14:41:37 UTC (rev 3468) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-16 14:50:25 UTC (rev 3469) @@ -164,11 +164,12 @@ (defmethod allocation-area-bounding-box ((allocation-area allocation-area)) (with-slots (left top width height bounding-box) allocation-area (unless (slot-boundp allocation-area 'bounding-box) - (setf bounding-box (coerce (list (cons left top) - (cons (+ left width) top) - (cons (+ left width) (+ top height)) - (cons left (+ top height))) - 'vector))) + (with-transaction ("setf allocation-area bounding-box") + (setf bounding-box (coerce (list (cons left top) + (cons (+ left width) top) + (cons (+ left width) (+ top height)) + (cons left (+ top height))) + 'vector)))) bounding-box)) (defmethod allocation-area-bounding-box2 ((allocation-area allocation-area))

1 0

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

16 Jul '08

Revision: 3468 Author: ksprotte URL: http://bknr.net/trac/changeset/3468 new test: validate-allocation-cache U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-16 13:51:58 UTC (rev 3467) +++ trunk/projects/bos/test/allocation.lisp 2008-07-16 14:41:37 UTC (rev 3468) @@ -208,3 +208,7 @@ (make-allocation-rectangle 0 0 8 8) (finishes (delete-object (make-contract (make-sponsor :login "test-sponsor") 1 :paidp nil)))) +(test validate-allocation-cache + (with-fixture initial-bos-store () + (let ((area1 (make-allocation-rectangle 0 0 8 8))) + (finishes (bos.m2::validate-allocation-cache))))) \ No newline at end of file

1 0

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

16 Jul '08

Revision: 3467 Author: ksprotte URL: http://bknr.net/trac/changeset/3467 compute timestamp with less consing in country-stats-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:38:42 UTC (rev 3466) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:51:58 UTC (rev 3467) @@ -129,8 +129,11 @@ ()) (defmethod handle ((handler country-stats-handler)) - (let* ((paid-contracts (remove-if-not #'contract-paidp (class-instances 'contract))) - (timestamp (reduce #'max paid-contracts :key (lambda (contract) (store-object-last-change contract 0))))) + (let* ((contracts (class-instances 'contract)) + (timestamp (reduce #'max contracts :key (lambda (contract) + (if (contract-paidp contract) + (store-object-last-change contract 0) + 0))))) (hunchentoot:handle-if-modified-since timestamp) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date timestamp)) @@ -152,7 +155,7 @@ (with-element "Icon" ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (dolist (country-contracts (sort (group-on paid-contracts + (dolist (country-contracts (sort (group-on (remove-if-not #'contract-paidp contracts) :test #'equal :key (lambda (contract) (string-upcase (sponsor-country (contract-sponsor contract)))))

1 0

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

16 Jul '08

Revision: 3466 Author: ksprotte URL: http://bknr.net/trac/changeset/3466 added timestamp to country-stats-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:30:21 UTC (rev 3465) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-16 13:38:42 UTC (rev 3466) @@ -129,7 +129,11 @@ ()) (defmethod handle ((handler country-stats-handler)) - (handle-every-n-seconds (60) + (let* ((paid-contracts (remove-if-not #'contract-paidp (class-instances 'contract))) + (timestamp (reduce #'max paid-contracts :key (lambda (contract) (store-object-last-change contract 0))))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8" :root-element "kml") (with-query-params ((lang "en")) @@ -148,7 +152,7 @@ (with-element "Icon" ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) - (dolist (country-contracts (sort (group-on (all-contracts) + (dolist (country-contracts (sort (group-on paid-contracts :test #'equal :key (lambda (contract) (string-upcase (sponsor-country (contract-sponsor contract)))))

1 0

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

16 Jul '08

Revision: 3465 Author: ksprotte URL: http://bknr.net/trac/changeset/3465 added timestamp for poi-xml-handler 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-16 13:24:40 UTC (rev 3464) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-16 13:30:21 UTC (rev 3465) @@ -562,9 +562,13 @@ (defmethod handle-object ((handler poi-xml-handler) poi) - (with-query-params ((lang "en")) - (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") - (write-poi-xml poi lang)))) + (let ((timestamp (store-object-last-change poi 1))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) + (with-query-params ((lang "en")) + (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") + (write-poi-xml poi lang))))) (defclass poi-kml-handler (object-handler) ()

1 0

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

16 Jul '08

Revision: 3464 Author: ksprotte URL: http://bknr.net/trac/changeset/3464 again whitespace... U trunk/projects/bos/web/poi-handlers.lisp Change set too large, please see URL above

1 0

← Newer
1
...
22
23
24
25
26
27
28
...
33
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008