| 1 | ;;; -*- coding: utf-8 -*- |
|---|
| 2 | (in-package :bos.web) |
|---|
| 3 | |
|---|
| 4 | (enable-interpol-syntax) |
|---|
| 5 | |
|---|
| 6 | (defpersistent-class kml-root-data () |
|---|
| 7 | ((language :initarg :language :reader language :type string |
|---|
| 8 | :index-type string-unique-index |
|---|
| 9 | :index-reader kml-root-data-with-language) |
|---|
| 10 | (kml-string :accessor kml-string))) |
|---|
| 11 | |
|---|
| 12 | (defun ensure-kml-root-data-for-language (language) |
|---|
| 13 | (or (kml-root-data-with-language language) |
|---|
| 14 | (make-instance 'kml-root-data :language language))) |
|---|
| 15 | |
|---|
| 16 | (defun kml-root-data-validate-file-upload (file-upload) |
|---|
| 17 | (cxml:parse-file (upload-pathname file-upload) |
|---|
| 18 | (cxml-dom:make-dom-builder))) |
|---|
| 19 | |
|---|
| 20 | (defclass kml-upload-handler (admin-only-handler form-handler) |
|---|
| 21 | ()) |
|---|
| 22 | |
|---|
| 23 | (defmethod handle-form ((handler kml-upload-handler) action) |
|---|
| 24 | (dolist (language (class-instances 'website-language)) |
|---|
| 25 | (ensure-kml-root-data-for-language (website-language-code language))) |
|---|
| 26 | (labels ((xml-parse-error-context (xml-parse-error) |
|---|
| 27 | (ppcre:register-groups-bind (line column) |
|---|
| 28 | ("Line +(\\d+).*column +(\\d+)" |
|---|
| 29 | (princ-to-string xml-parse-error)) |
|---|
| 30 | (when (and line column) |
|---|
| 31 | (values (parse-integer line) (parse-integer column)))))) |
|---|
| 32 | (with-bos-cms-page (:title "KML Upload") |
|---|
| 33 | (html ((:form |
|---|
| 34 | :method "POST" :enctype "multipart/form-data") |
|---|
| 35 | (dolist (kml-root-data (class-instances 'kml-root-data)) |
|---|
| 36 | (let ((language (language kml-root-data))) |
|---|
| 37 | (html (:h2 (:princ language)) |
|---|
| 38 | (:p ((:input :type "file" :name language :size 50)) |
|---|
| 39 | " " |
|---|
| 40 | (let ((file-upload (request-uploaded-file language))) |
|---|
| 41 | (when file-upload |
|---|
| 42 | (handler-case |
|---|
| 43 | (progn |
|---|
| 44 | (kml-root-data-validate-file-upload file-upload) |
|---|
| 45 | (with-transaction ("update kml-string") |
|---|
| 46 | (setf (kml-string kml-root-data) |
|---|
| 47 | (arnesi:read-string-from-file (upload-pathname file-upload) |
|---|
| 48 | :external-format :utf-8))) |
|---|
| 49 | (html (:princ "updated successfully"))) |
|---|
| 50 | (cxml:xml-parse-error (c) |
|---|
| 51 | (multiple-value-bind (line column) |
|---|
| 52 | (xml-parse-error-context c) |
|---|
| 53 | (print (list line column)) |
|---|
| 54 | (html ((:span :class "error") |
|---|
| 55 | (:format "there was a xml parse error ~:[~;near line ~D, column ~D~]" |
|---|
| 56 | (and line column) |
|---|
| 57 | line column))))))))) |
|---|
| 58 | ;; we want this after the processing |
|---|
| 59 | (:p (:format "last-change: ~A" |
|---|
| 60 | (format-date-time (store-object-last-change kml-root-data 0))) |
|---|
| 61 | " " |
|---|
| 62 | (cmslink (format nil "/kml-upload?lang=~A&action=download" language) |
|---|
| 63 | "download current version"))))) |
|---|
| 64 | (submit-button "upload" "upload")) |
|---|
| 65 | (:p "Please note that the " (:b "download current version") |
|---|
| 66 | " links above show you the kml files exactly like you |
|---|
| 67 | uploaded them. These are not the KML files as seen by the |
|---|
| 68 | users.") |
|---|
| 69 | (:p "For the actually served kml files some automatic |
|---|
| 70 | replacements are being done. You can inspect those by the |
|---|
| 71 | following links:") |
|---|
| 72 | (:p (dolist (kml-root-data (class-instances 'kml-root-data)) |
|---|
| 73 | (let ((language (language kml-root-data))) |
|---|
| 74 | (html (cmslink (format nil "/kml-root?lang=~A" language) |
|---|
| 75 | (:format "kml ~A" language)) |
|---|
| 76 | " ")))))))) |
|---|
| 77 | |
|---|
| 78 | (defmethod handle-form ((handler kml-upload-handler) (action (eql :download))) |
|---|
| 79 | (with-query-params (lang) |
|---|
| 80 | (setf (hunchentoot:header-out :content-type) |
|---|
| 81 | "application/binary" |
|---|
| 82 | (hunchentoot:header-out :content-disposition) |
|---|
| 83 | (format nil "attachment; filename=kml-root-~A.kml" lang)) |
|---|
| 84 | (let ((kml-root-data (kml-root-data-with-language lang))) |
|---|
| 85 | (kml-string kml-root-data)))) |
|---|
| 86 | |
|---|
| 87 | (defclass kml-root-handler (object-handler) |
|---|
| 88 | ()) |
|---|
| 89 | |
|---|
| 90 | (defun replace-all-url-hosts (string new-host) |
|---|
| 91 | "Replaces all hostnames in STRING by NEW-HOST." |
|---|
| 92 | (ppcre:regex-replace-all #?r"((?:https?|ftp)://)\w+(?:\.\w+)*(?::\d+)?" string #?r"\1${new-host}")) |
|---|
| 93 | |
|---|
| 94 | (defun replace-lang-query-params (string new-lang) |
|---|
| 95 | (ppcre:regex-replace-all #?r"(?i)(lang=)[a-z]{2,2}" string #?r"\1${new-lang}")) |
|---|
| 96 | |
|---|
| 97 | (defun replace-personalized-contract-placeholder (string sponsor lang) |
|---|
| 98 | (if (null sponsor) |
|---|
| 99 | string |
|---|
| 100 | (let ((contract (first (sponsor-contracts sponsor)))) |
|---|
| 101 | (ppcre:regex-replace #?r"<!-- +personalized +contract +placemark *-->" |
|---|
| 102 | string |
|---|
| 103 | (cxml:with-xml-output (cxml:make-string-sink :omit-xml-declaration-p t) |
|---|
| 104 | (write-personalized-contract-placemark-kml contract lang)))))) |
|---|
| 105 | |
|---|
| 106 | (defun replace-contract-tree-placeholder (string sponsor lang) |
|---|
| 107 | (ppcre:regex-replace |
|---|
| 108 | #?r"<!-- +squaremetre +area +contract +tree +link *-->" |
|---|
| 109 | string |
|---|
| 110 | (if (and sponsor (first (sponsor-contracts sponsor))) |
|---|
| 111 | (let* ((contract (first (sponsor-contracts sponsor))) |
|---|
| 112 | (node (find-contract-node *contract-tree* contract)) |
|---|
| 113 | (path (node-path node)) |
|---|
| 114 | (contract-id (store-object-id contract))) |
|---|
| 115 | (format nil "<href>http://~a/contract-tree-kml?rmcid=~D&rmcpath=~{~D~}&lang=~A</href>" |
|---|
| 116 | (website-host) contract-id path lang)) |
|---|
| 117 | (format nil "<href>http://~A/contract-tree-kml?lang=~A</href>" |
|---|
| 118 | (website-host) lang)))) |
|---|
| 119 | |
|---|
| 120 | (defun serve-kml-root-data (&optional sponsor) |
|---|
| 121 | (with-query-params ((lang "en")) |
|---|
| 122 | (let* ((kml-root-data (kml-root-data-with-language lang)) |
|---|
| 123 | (last-modified (store-object-last-change kml-root-data 0))) |
|---|
| 124 | (hunchentoot:handle-if-modified-since last-modified ) |
|---|
| 125 | (setf (hunchentoot:header-out :last-modified) |
|---|
| 126 | (hunchentoot:rfc-1123-date last-modified) |
|---|
| 127 | (hunchentoot:header-out :content-type) |
|---|
| 128 | "application/vnd.google-earth.kml+xml" |
|---|
| 129 | (hunchentoot:header-out :content-disposition) |
|---|
| 130 | (format nil "attachment; filename=kml-root-~A.kml" lang)) |
|---|
| 131 | (let ((kml-string (kml-string kml-root-data))) |
|---|
| 132 | (setq kml-string (replace-all-url-hosts kml-string (website-host)) |
|---|
| 133 | kml-string (replace-lang-query-params kml-string lang) |
|---|
| 134 | kml-string (replace-personalized-contract-placeholder kml-string sponsor lang) |
|---|
| 135 | kml-string (replace-contract-tree-placeholder kml-string sponsor lang)))))) |
|---|
| 136 | |
|---|
| 137 | (defmethod handle-object ((handler kml-root-handler) (object sponsor)) |
|---|
| 138 | (serve-kml-root-data object)) |
|---|
| 139 | |
|---|
| 140 | (defmethod handle-object ((handler kml-root-handler) (object contract)) |
|---|
| 141 | (serve-kml-root-data (contract-sponsor object))) |
|---|
| 142 | |
|---|
| 143 | (defmethod handle-object ((handler kml-root-handler) (object null)) |
|---|
| 144 | (serve-kml-root-data)) |
|---|
| 145 | |
|---|
| 146 | ;;; kml-format utils |
|---|
| 147 | (defun kml-format-points (points stream) |
|---|
| 148 | (mapc #'(lambda (point) (kml-format-point point stream)) points)) |
|---|
| 149 | |
|---|
| 150 | (defmethod kml-format-point ((point list) stream) |
|---|
| 151 | (format stream "~,20F,~,20F,0 " (first point) (second point))) |
|---|
| 152 | |
|---|
| 153 | (defmethod kml-format-point ((point point) stream) |
|---|
| 154 | (multiple-value-bind (lon lat) |
|---|
| 155 | (point-lon-lat point) |
|---|
| 156 | (format stream "~,20F,~,20F,0 " lon lat))) |
|---|
| 157 | |
|---|
| 158 | (defun kml-format-color (color &optional (opacity 255)) |
|---|
| 159 | (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) |
|---|
| 160 | |
|---|
| 161 | (defun contract-description (contract language) |
|---|
| 162 | (let* ((sponsor (contract-sponsor contract)) |
|---|
| 163 | (name (user-full-name sponsor))) |
|---|
| 164 | (flet ((donor-id () (dictionary-entry "Donor ID:" language)) |
|---|
| 165 | (name () (dictionary-entry "Name:" language)) |
|---|
| 166 | (country () (dictionary-entry "Country:" language)) |
|---|
| 167 | (donated () (dictionary-entry "donated:" language)) |
|---|
| 168 | (since () (dictionary-entry "since:" language))) |
|---|
| 169 | (with-xml-output (cxml:make-string-sink) |
|---|
| 170 | (with-element "div" |
|---|
| 171 | (with-element "table" |
|---|
| 172 | (with-element "tr" |
|---|
| 173 | (with-element "td" (text (donor-id))) |
|---|
| 174 | (with-element "td" (text (princ-to-string (store-object-id sponsor))))) |
|---|
| 175 | (with-element "tr" |
|---|
| 176 | (with-element "td" (text (name))) |
|---|
| 177 | (with-element "td" (text (or name "[anonymous]")))) |
|---|
| 178 | (with-element "tr" |
|---|
| 179 | (with-element "td" (text (country))) |
|---|
| 180 | (with-element "td" |
|---|
| 181 | (text (dictionary-entry (second (assoc (make-keyword-from-string (sponsor-country sponsor)) |
|---|
| 182 | *country-english-names*)) language)) |
|---|
| 183 | (text " ") |
|---|
| 184 | (with-element "img" |
|---|
| 185 | (attribute "src" (format nil "http://~A/images/flags/~(~A~).gif" |
|---|
| 186 | (website-host) (sponsor-country sponsor))) |
|---|
| 187 | (attribute "width" "20") |
|---|
| 188 | (attribute "height" "12")))) |
|---|
| 189 | (with-element "tr" |
|---|
| 190 | (with-element "td" (text (donated))) |
|---|
| 191 | (with-element "td" (text (format nil "~D m²" (length (contract-m2s contract)))))) |
|---|
| 192 | (with-element "tr" |
|---|
| 193 | (with-element "td" (text (since))) |
|---|
| 194 | (with-element "td" (text (format-date-time (contract-date contract) :show-time nil))))) |
|---|
| 195 | (when (sponsor-info-text sponsor) |
|---|
| 196 | (text (sponsor-info-text sponsor)))))))) |
|---|
| 197 | |
|---|
| 198 | (defclass kml-root-dynamic-handler (object-handler) |
|---|
| 199 | () |
|---|
| 200 | (:documentation "This handler is not actually used anymore, because |
|---|
| 201 | the root kml files are uploaded through the CMS. It is still left here |
|---|
| 202 | in the codebase, because it was used to generate the initial templates |
|---|
| 203 | and might be needed again.")) |
|---|
| 204 | |
|---|
| 205 | (defun write-personalized-contract-placemark-kml (contract lang) |
|---|
| 206 | (with-element "Style" |
|---|
| 207 | (attribute "id" "contractPlacemarkIcon") |
|---|
| 208 | (with-element "IconStyle" |
|---|
| 209 | (with-element "color" (text "ff0000ff")) |
|---|
| 210 | (with-element "Icon" |
|---|
| 211 | ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) |
|---|
| 212 | (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) |
|---|
| 213 | (write-contract-placemark-kml contract lang)) |
|---|
| 214 | |
|---|
| 215 | (defun write-root-kml (handler sponsor) |
|---|
| 216 | (declare (ignore handler)) |
|---|
| 217 | (let ((*print-case* :downcase) |
|---|
| 218 | (contract (when sponsor (first (sponsor-contracts sponsor))))) |
|---|
| 219 | ;; only the first contract of SPONSOR will be shown |
|---|
| 220 | (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8" |
|---|
| 221 | :root-element "kml" :xmlns "http://www.opengis.net/kml/2.2") |
|---|
| 222 | (with-query-params ((lang "en")) |
|---|
| 223 | (with-element "Document" |
|---|
| 224 | (with-element "name" (text "BOS")) |
|---|
| 225 | (with-element "open" (text "1")) |
|---|
| 226 | (when contract |
|---|
| 227 | (write-personalized-contract-placemark-kml contract lang)) |
|---|
| 228 | (with-element "LookAt" |
|---|
| 229 | (with-element "longitude" (text "116.975859")) |
|---|
| 230 | (with-element "latitude" (text "-1.044691")) |
|---|
| 231 | (with-element "altitude" (text "0")) |
|---|
| 232 | (with-element "heading" (text "0")) |
|---|
| 233 | (with-element "tilt" (text "0")) |
|---|
| 234 | (with-element "range" (text "11000"))) |
|---|
| 235 | (with-element "Folder" |
|---|
| 236 | (with-element "name" (text (dictionary-entry "Sat-Images" lang))) |
|---|
| 237 | (with-element "open" (text "1")) |
|---|
| 238 | (dolist (sat-layer (sort (copy-list (class-instances 'sat-layer)) |
|---|
| 239 | #'< :key #'year)) |
|---|
| 240 | (kml-network-link (format nil "http://~a/sat-root-kml?name=~A" (website-host) (name sat-layer)) |
|---|
| 241 | :rect (geo-box-rectangle *m2-geo-box*) |
|---|
| 242 | :lod '(:min 0 :max -1) |
|---|
| 243 | :name (dictionary-entry (princ-to-string (name sat-layer)) lang) |
|---|
| 244 | :hide-children t))) |
|---|
| 245 | (let ((href (if (not contract) |
|---|
| 246 | (format nil "http://~a/contract-tree-kml?lang=~A" (website-host) lang) |
|---|
| 247 | (let* ((node (find-contract-node *contract-tree* contract)) |
|---|
| 248 | (path (node-path node)) |
|---|
| 249 | (contract-id (store-object-id contract))) |
|---|
| 250 | (format nil "http://~a/contract-tree-kml?rmcid=~D&rmcpath=~{~D~}&lang=~A" |
|---|
| 251 | (website-host) contract-id path lang))))) |
|---|
| 252 | (kml-network-link href |
|---|
| 253 | :rect (geo-box-rectangle (geo-box *contract-tree*)) |
|---|
| 254 | :lod (node-lod *contract-tree*) |
|---|
| 255 | :name (dictionary-entry "Squaremetre Area" lang) |
|---|
| 256 | :hide-children t)) |
|---|
| 257 | (kml-network-link (format nil "http://~a/poi-kml-all?lang=~A" (website-host) lang) |
|---|
| 258 | :name (dictionary-entry "POIs" lang) |
|---|
| 259 | :rect (make-rectangle :x 0 :y 0 :width +width+ :height +width+) |
|---|
| 260 | :lod '(:min 0 :max -1) |
|---|
| 261 | :hide-children nil) |
|---|
| 262 | (kml-network-link (format nil "http://~a/country-stats?lang=~A" (website-host) lang) |
|---|
| 263 | :name (dictionary-entry "Country-Stats" lang) |
|---|
| 264 | :hide-children nil |
|---|
| 265 | :look-at (lambda () |
|---|
| 266 | (with-element "LookAt" |
|---|
| 267 | (with-element "longitude" (text "8.297592139883164")) |
|---|
| 268 | (with-element "latitude" (text "49.89989439494514")) |
|---|
| 269 | (with-element "altitude" (text "0")) |
|---|
| 270 | (with-element "range" (text "5400715.913126094")) |
|---|
| 271 | (with-element "tilt" (text "0")) |
|---|
| 272 | (with-element "heading" (text "0")))))))))) |
|---|
| 273 | |
|---|
| 274 | (defmethod handle-object ((handler kml-root-dynamic-handler) (object sponsor)) |
|---|
| 275 | (write-root-kml handler object)) |
|---|
| 276 | |
|---|
| 277 | (defmethod handle-object ((handler kml-root-dynamic-handler) (object contract)) |
|---|
| 278 | (handle-object handler (contract-sponsor object))) |
|---|
| 279 | |
|---|
| 280 | (defmethod handle-object ((handler kml-root-dynamic-handler) (object null)) |
|---|
| 281 | (write-root-kml handler nil)) |
|---|
| 282 | |
|---|
| 283 | (defclass country-stats-handler (page-handler) |
|---|
| 284 | ()) |
|---|
| 285 | |
|---|
| 286 | (defmethod handle ((handler country-stats-handler)) |
|---|
| 287 | (let* ((contracts (all-contracts)) |
|---|
| 288 | (timestamp (reduce #'max contracts :key (lambda (contract) |
|---|
| 289 | (if (contract-paidp contract) |
|---|
| 290 | (store-object-last-change contract 0) |
|---|
| 291 | 0))))) |
|---|
| 292 | (hunchentoot:handle-if-modified-since timestamp) |
|---|
| 293 | (setf (hunchentoot:header-out :last-modified) |
|---|
| 294 | (hunchentoot:rfc-1123-date timestamp)) |
|---|
| 295 | (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" |
|---|
| 296 | :root-element "kml" :xmlns "http://www.opengis.net/kml/2.2") |
|---|
| 297 | (with-query-params ((lang "en")) |
|---|
| 298 | (with-element "Document" |
|---|
| 299 | (with-element "name" (text "Country-Stats")) |
|---|
| 300 | (with-element "Style" |
|---|
| 301 | (attribute "id" "countryStatsStyle") |
|---|
| 302 | (with-element "IconStyle" |
|---|
| 303 | (with-element "Icon" |
|---|
| 304 | (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) |
|---|
| 305 | (do-sponsor-countries (country) |
|---|
| 306 | (assert (keywordp country)) |
|---|
| 307 | (let ((coords (cdr (assoc country *country-coords*)))) |
|---|
| 308 | (when coords |
|---|
| 309 | (destructuring-bind (lon lat) |
|---|
| 310 | coords |
|---|
| 311 | (multiple-value-bind (number-of-paying-sponsors number-of-sold-m2s) |
|---|
| 312 | (contract-stats-for-country country) |
|---|
| 313 | (with-element "Placemark" |
|---|
| 314 | (with-element "name" (text (format nil "~A" (dictionary-entry |
|---|
| 315 | (second (assoc country *country-english-names*)) lang)))) |
|---|
| 316 | (with-element "styleUrl" (text "#countryStatsStyle")) |
|---|
| 317 | (with-element "LookAt" |
|---|
| 318 | (with-element "longitude" (text (format nil "~,20F" lat))) |
|---|
| 319 | (with-element "latitude" (text (format nil "~,20F" lon))) |
|---|
| 320 | (with-element "range" (text "1000000"))) |
|---|
| 321 | (with-element "description" |
|---|
| 322 | (text (format nil "<p>~A</p><table><tbody><tr><td>~A:</td><td>~D ~A</td></tr> |
|---|
| 323 | <tr><td>~A:</td><td>~D m²</td></tr></tbody></table>" |
|---|
| 324 | (dictionary-entry "BOS says thank you to all sponsors!" lang) |
|---|
| 325 | (dictionary-entry |
|---|
| 326 | (second (assoc country *country-english-names*)) lang) |
|---|
| 327 | number-of-paying-sponsors |
|---|
| 328 | (if (= 1 number-of-paying-sponsors) |
|---|
| 329 | (dictionary-entry "sponsor" lang) |
|---|
| 330 | (dictionary-entry "sponsors" lang)) |
|---|
| 331 | (dictionary-entry "total contribution" lang) |
|---|
| 332 | number-of-sold-m2s))) |
|---|
| 333 | (with-element "Snippet" |
|---|
| 334 | (text (format nil "~A ~A" |
|---|
| 335 | number-of-paying-sponsors |
|---|
| 336 | (if (= 1 number-of-paying-sponsors) |
|---|
| 337 | (dictionary-entry "sponsor" lang) |
|---|
| 338 | (dictionary-entry "sponsors" lang))))) |
|---|
| 339 | (with-element "Point" |
|---|
| 340 | (with-element "coordinates" |
|---|
| 341 | (text (format nil "~,20F,~,20F,0" lat lon))))))))))))))) |
|---|
| 342 | |
|---|
| 343 | |
|---|
| 344 | |
|---|
| 345 | (defclass look-at-allocation-area-handler (object-handler) |
|---|
| 346 | ()) |
|---|
| 347 | |
|---|
| 348 | (defmethod handle-object ((handler look-at-allocation-area-handler) |
|---|
| 349 | (area allocation-area)) |
|---|
| 350 | (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" |
|---|
| 351 | :root-element "kml" :xmlns "http://www.opengis.net/kml/2.2") |
|---|
| 352 | (with-element "Document" |
|---|
| 353 | (with-element "name" (text (format nil "allocation-area ~D" (store-object-id area)))) |
|---|
| 354 | (kml-region (make-rectangle2 (allocation-area-bounding-box2 area)) |
|---|
| 355 | nil)))) |
|---|
