| 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") |
|---|
| 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 "range" (text "11000")) |
|---|
| 233 |
(with-element "tilt" (text "0")) |
|---|
| 234 |
(with-element "heading" (text "0"))) |
|---|
| 235 |
(with-element "Folder" |
|---|
| 236 |
(attribute "name" (dictionary-entry "Sat-Images" lang)) |
|---|
| 237 |
(attribute "open" "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") |
|---|
| 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") |
|---|
| 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)))) |
|---|
