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")