[bknr-cvs] ksprotte changed trunk/projects/bos/web/kml-handlers.lisp

[BKNR Commits]

Revision: 3625
Author: ksprotte
URL: http://bknr.net/trac/changeset/3625

finished kml-root handler, performing necessary string replacements in given kml template
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-24 15:19:13 UTC (rev 3624)
+++ trunk/projects/bos/web/kml-handlers.lisp	2008-07-24 19:30:56 UTC (rev 3625)
@@ -1,6 +1,8 @@
 ;;; -*- coding: utf-8 -*-
 (in-package :bos.web)
 
+(enable-interpol-syntax)
+
 (defpersistent-class kml-root-data ()
   ((language :initarg :language :reader language :type string
              :index-type string-unique-index
@@ -69,6 +71,50 @@
     (let ((kml-root-data (kml-root-data-with-language lang)))
       (kml-string kml-root-data))))
 
+(defclass kml-root-handler (object-handler)
+  ())
+
+(defun replace-all-url-hosts (string new-host)
+  "Replaces all hostnames in STRING by NEW-HOST."
+  (ppcre:regex-replace-all #?r"((?:https?|ftp)://)\w+(?:\.\w+)*" string #?r"\1${new-host}"))
+
+(defun replace-lang-query-params (string new-lang)
+  (ppcre:regex-replace-all #?r"(?i)(lang=)[a-z]{2,2}" string #?r"\1${new-lang}"))
+
+(defun replace-personalized-contract-placeholder (string sponsor lang)
+  (if (null sponsor)
+      string
+      (let ((contract (first (sponsor-contracts sponsor))))
+        (ppcre:regex-replace #?r"<!-- +personalized +contract +placemark +-->"
+                             string
+                             (cxml:with-xml-output (cxml:make-string-sink :omit-xml-declaration-p t)
+                               (write-personalized-contract-placemark-kml contract lang))))))
+
+(defun serve-kml-root-data (&optional sponsor)  
+  (with-query-params ((lang "en"))
+    (let* ((kml-root-data (kml-root-data-with-language lang))
+           (last-modified (store-object-last-change kml-root-data 0)))
+      (hunchentoot:handle-if-modified-since last-modified )
+      (setf (hunchentoot:header-out :last-modified)
+            (hunchentoot:rfc-1123-date last-modified)
+            (hunchentoot:header-out :content-type)
+            "application/vnd.google-earth.kml+xml"
+            (hunchentoot:header-out :content-disposition)
+            (format nil "attachment; filename=kml-root-~A.kml" lang))
+      (let ((kml-string (kml-string kml-root-data)))
+        (setq kml-string (replace-all-url-hosts kml-string (website-host))
+              kml-string (replace-lang-query-params kml-string lang)
+              kml-string (replace-personalized-contract-placeholder kml-string sponsor lang))))))
+
+(defmethod handle-object ((handler kml-root-handler) (object sponsor))
+  (serve-kml-root-data object))
+
+(defmethod handle-object ((handler kml-root-handler) (object contract))
+  (serve-kml-root-data (contract-sponsor object)))
+
+(defmethod handle-object ((handler kml-root-handler) (object null))
+  (serve-kml-root-data))
+
 ;;; kml-format utils
 (defun kml-format-points (points stream)
   (mapc #'(lambda (point) (kml-format-point point stream)) points))
@@ -124,6 +170,16 @@
 (defclass kml-root-dynamic-handler (object-handler)
   ((timestamp :accessor timestamp :initform (get-universal-time))))
 
+(defun write-personalized-contract-placemark-kml (contract lang)
+  (with-element "Style"
+    (attribute "id" "contractPlacemarkIcon")
+    (with-element "IconStyle"
+      (with-element "color" (text "ff0000ff"))
+      (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)))))))
+  (write-contract-placemark-kml contract lang))
+
 (defun write-root-kml (handler sponsor)
   (let ((*print-case* :downcase)
         (contract (when sponsor (first (sponsor-contracts sponsor)))))
@@ -138,14 +194,7 @@
           (with-element "name" (text "BOS"))
           (with-element "open" (text "1"))
           (when contract
-            (with-element "Style"
-              (attribute "id" "contractPlacemarkIcon")
-              (with-element "IconStyle"
-                (with-element "color" (text "ff0000ff"))
-                (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)))))))
-            (write-contract-placemark-kml contract lang))
+            (write-personalized-contract-placemark-kml contract lang))
           (with-element "LookAt"
             (with-element "longitude" (text "116.988156014724"))
             (with-element "latitude" (text "-1.045791509671129"))