[bknr-cvs] ksprotte changed trunk/projects/bos/web/

[BKNR Commits]

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)