Revision: 3613 Author: ksprotte URL: http://bknr.net/trac/changeset/3613
added new handler look-at-allocation-area U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp
Modified: trunk/projects/bos/web/allocation-area-handlers.lisp =================================================================== --- trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -15,16 +15,19 @@ (:th "active?") (:th "total") (:th "free") - (:th "%used")) + (:th "%used") + (:th "Google Earth view")) (loop for allocation-area in (all-allocation-areas) - do (html - (:tr - (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) - (:princ-safe (store-object-id allocation-area)))) - (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) - (:td (:princ-safe (allocation-area-total-m2s allocation-area))) - (:td (:princ-safe (allocation-area-free-m2s allocation-area))) - (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) + do (html + (:tr + (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) + (:princ-safe (store-object-id allocation-area)))) + (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) + (:td (:princ-safe (allocation-area-total-m2s allocation-area))) + (:td (:princ-safe (allocation-area-free-m2s allocation-area))) + (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%") + (:td (cmslink (format nil "look-at-allocation-area/~D" (store-object-id allocation-area)) + "fly to view")))))) (:p (cmslink "create-allocation-area" "Create new allocation area")))))
(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area)
Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -243,3 +243,15 @@
+(defclass look-at-allocation-area-handler (object-handler) + ()) + +(defmethod handle-object ((handler look-at-allocation-area-handler) + (area allocation-area)) + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" + :root-element "kml") + (with-element "Document" + (with-element "name" (text (format nil "allocation-area ~D" (store-object-id area)))) + (kml-region (make-rectangle2 (allocation-area-bounding-box2 area)) + nil)))) +
Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -208,6 +208,7 @@ ("/contract" contract-handler) ("/sat-tree-kml" sat-tree-kml-handler) ("/sat-root-kml" sat-root-kml-handler) + ("/look-at-allocation-area" look-at-allocation-area-handler) ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler)