[bknr-cvs] r2398 - branches/bos/projects/bos/web

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Wed Jan 23 13:09:12 2008
New Revision: 2398

Added:
   branches/bos/projects/bos/web/kml-handlers.lisp
Modified:
   branches/bos/projects/bos/web/bos.web.asd
   branches/bos/projects/bos/web/sponsor-handlers.lisp
   branches/bos/projects/bos/web/webserver.lisp
Log:
added new handler: ("/contract-kml" contract-kml-handler)
there is also a new link to it in "Edit Sponsor"

it basically works, but needs to be improved...

there is a gap in Google Earth between adjacent contracts --
probably, we need to add 1 (in our coordinate system) before
the conversion
this should represent the width of one square concerning
the "right and bottom points"


Modified: branches/bos/projects/bos/web/bos.web.asd
==============================================================================
--- branches/bos/projects/bos/web/bos.web.asd	(original)
+++ branches/bos/projects/bos/web/bos.web.asd	Wed Jan 23 13:09:12 2008
@@ -30,6 +30,7 @@
 	       (:file "contract-handlers" :depends-on ("web-utils"))
 	       (:file "contract-image-handler" :depends-on ("web-utils"))
 	       (:file "reports-xml-handler" :depends-on ("boi-handlers"))
+	       (:file "kml-handlers" :depends-on ("packages"))
 	       (:file "sponsor-handlers" :depends-on ("web-utils"))
 	       (:file "news-handlers" :depends-on ("web-utils"))
 	       (:file "allocation-area-handlers" :depends-on ("web-utils"))

Added: branches/bos/projects/bos/web/kml-handlers.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/web/kml-handlers.lisp	Wed Jan 23 13:09:12 2008
@@ -0,0 +1,40 @@
+(in-package :bos.web)
+
+(defun contract-utm-bounding-box (contract)
+  "Returns LEFT, TOP, RIGHT, BOTTOM."
+  (let (min-x min-y max-x max-y)
+    (dolist (m2 (contract-m2s contract))
+      (setf min-x (min (m2-utm-x m2) (or min-x (m2-utm-x m2))))
+      (setf min-y (min (m2-utm-y m2) (or min-y (m2-utm-y m2))))
+      (setf max-x (max (m2-utm-x m2) (or max-x (m2-utm-x m2))))
+      (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2)))))
+    (list min-x max-y max-x min-y)))
+
+(defun points2string (points)
+  (format nil "~:{~F,~F,0 ~}" points))
+
+(defclass contract-kml-handler (object-handler)
+  ())
+
+(defmethod handle-object ((handler contract-kml-handler) (contract contract) req)
+  (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml")    
+    ;; when name is xmlns, the attribute does not show up - why (?)
+    ;; (attribute "xmlns" "http://earth.google.com/kml/2.2")
+    (destructuring-bind (left top right bottom) (contract-utm-bounding-box contract)
+      (with-element "Document"      
+	(with-element "Placemark"
+	  (with-element "name" (format nil "contract~a" (store-object-id contract)))
+	  (with-element "description" "a description")
+	  (with-element "Polygon"	    
+	    (with-element "tessellate" (text "1"))
+	    (with-element "outerBoundaryIs"
+	      (with-element "LinearRing"
+		(with-element "coordinates"
+		  (text (points2string (list (geo-utm:utm-x-y-to-lon-lat left bottom +utm-zone+ t)
+					     (geo-utm:utm-x-y-to-lon-lat right bottom +utm-zone+ t)
+					     (geo-utm:utm-x-y-to-lon-lat right top +utm-zone+ t)
+					     (geo-utm:utm-x-y-to-lon-lat left top +utm-zone+ t)))))))))))))
+
+(defmethod handle-object ((handle-object contract-kml-handler) (object null) req)
+  (error "Contract not found."))
+

Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/sponsor-handlers.lisp	Wed Jan 23 13:09:12 2008
@@ -160,7 +160,9 @@
 					 (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor)))))
 					 (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor))))))))
 		    (:td (:princ-safe (if (contract-paidp contract) "paid" "not paid")))
-		    (:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
+		    (:td (cmslink (format nil "contract-kml/~A" (store-object-id contract)) "Google Earth")
+			 :br
+			 (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
 			 (when (probe-file (contract-pdf-pathname contract))
 			   (html :br (cmslink (contract-pdf-url contract) "Show Certificate")))
 			 (when (contract-worldpay-trans-id contract)

Modified: branches/bos/projects/bos/web/webserver.lisp
==============================================================================
--- branches/bos/projects/bos/web/webserver.lisp	(original)
+++ branches/bos/projects/bos/web/webserver.lisp	Wed Jan 23 13:09:12 2008
@@ -198,7 +198,7 @@
 					("/edit-poi-image" edit-poi-image-handler)
 					("/edit-sponsor" edit-sponsor-handler)
 					("/contract" contract-handler)
-					("/reports-xml" reports-xml-handler)
+					("/reports-xml" reports-xml-handler)					
 					("/complete-transfer" complete-transfer-handler)
 					("/edit-news" edit-news-handler)
 					("/make-poi" make-poi-handler)
@@ -224,6 +224,7 @@
 					("/cancel-contract" cancel-contract-handler)
 					("/statistics" statistics-handler)
 					("/rss" rss-handler)
+					("/contract-kml" contract-kml-handler)
 					#+(or)
 					("/" redirect-handler
 					 :to "/index")