contract-tree.lisp

Revision 3871, 20.7 kB (checked in by ksprotte, 2 months ago)
added handlers /sitemap.xml and /contract-placemark for Google crawler

Line
1	(in-package :bos.web)
2
3	;;; contract-node
4	(defclass contract-node (node-extension)
5	((name :allocation :class :initform 'contract-node)
6	(timestamp :accessor timestamp :initform 0) ; timestamp initially "very old"
7	(placemark-contracts :initform nil :accessor placemark-contracts)
8	(image :initform nil :accessor image)))
9
10	(defun contract-node-invalidate-timestamp (node)
11	(let ((image (contract-node-find-corresponding-store-image node)))
12	(when (and image (probe-file (blob-pathname image)))
13	(setf (timestamp node) (1+ (blob-timestamp image))))))
14
15	(defun contract-node-timestamp-updater (contract)
16	(lambda (node) (setf (timestamp node)
17	(max (timestamp node) (contract-date contract)))))
18
19	(defun contract-node-find-corresponding-store-image (node)
20	(let ((store-images (get-keyword-store-images (contract-node-keyword node))))
21	(if (alexandria:length= 1 store-images)
22	;; good, there is only one
23	(first store-images)
24	;; We will just return NIL, if we cannot find one.
25	;; If there are too many, we will return the newest one and delete the rest.
26	(let ((store-images-newest-first
27	(sort (copy-list store-images) #'> :key #'blob-timestamp)))
28	(mapc #'delete-object (rest store-images-newest-first))
29	(first store-images-newest-first)))))
30
31	(defmethod initialize-instance :after ((node contract-node) &key args)
32	(declare (ignore args))
33	(let ((image (contract-node-find-corresponding-store-image node)))
34	(when (and image (probe-file (blob-pathname image)))
35	(setf (image node) image
36	(timestamp node) (blob-timestamp image)))))
37
38	(defvar contract-tree nil)
39	(defparameter contract-tree-images-size 128) ; was 256
40
41	(defmethod leaf-node-p ((node contract-node))
42	(= 9 (depth node)))
43
44	(defun contract-geo-box (contract)
45	(destructuring-bind (x y width height)
46	(contract-bounding-box contract) ; XXX
47	(let ((x2 (+ x width))
48	(y2 (+ y height)))
49	(destructuring-bind (west north)
50	(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t)
51	(destructuring-bind (east south)
52	(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x2) (- +nw-utm-y+ y2) +utm-zone+ t)
53	(make-geo-box west north east south))))))
54
55	(defun contract-geo-center (contract)
56	(destructuring-bind (x y)
57	(geometry:rectangle-center (contract-largest-rectangle contract))
58	(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t)))
59
60	(defun contract-placemark-at-node-p (node contract)
61	"Returns T if CONTRACT is large enough at the LOD of NODE to be
62	displayed with its center placemark.
63
64	This predicate is called by INSERT-CONTRACT. We assume that for
65	bulk-insertions contracts with larger area are inserted first."
66	(cond
67	((not (node-has-children-p node))
68	t)
69	;; let's fill nodes to a very low minimum - as noted above, larger
70	;; contracts are inserted first
71	((and (> (depth node) 3)
72	(< (length (placemark-contracts node)) 2))
73	t)
74	(t (let ((geo-box (geo-box node)))
75	(destructuring-bind (geo-box-utm-west geo-box-utm-north &rest _)
76	(geo-utm:lon-lat-to-utm-x-y (geo-box-west geo-box) (geo-box-north geo-box))
77	(declare (ignore _))
78	(destructuring-bind (geo-box-utm-east geo-box-utm-south &rest _)
79	(geo-utm:lon-lat-to-utm-x-y (geo-box-east geo-box) (geo-box-south geo-box))
80	(declare (ignore _))
81	(let* ((output-images-size contract-tree-images-size)
82	(rect (contract-largest-rectangle contract))
83	(contract-width (third rect))
84	(contract-height (fourth rect))
85	(geo-width (- geo-box-utm-east geo-box-utm-west))
86	(geo-height (- geo-box-utm-north geo-box-utm-south))
87	(contract-pixel-size (min (* contract-width (/ output-images-size geo-width))
88	(* contract-height (/ output-images-size geo-height)))))
89	(cond
90	((< (contract-area contract) 4)
91	nil)
92	((< (depth node) 4)
93	(> contract-pixel-size 5))
94	(t (> contract-pixel-size 10))))))))))
95
96	(defun find-contract-node (node contract)
97	(find-node-if (lambda (node) (member contract (placemark-contracts node))) node))
98
99	(defun insert-contract (contract-tree contract)
100	(let ((geo-box (contract-geo-box contract))
101	(geo-center (contract-geo-center contract)))
102	(ensure-intersecting-children contract-tree geo-box
103	(contract-node-timestamp-updater contract))
104	(let ((placemark-node (find-node-if
105	(lambda (node) (contract-placemark-at-node-p node contract))
106	contract-tree
107	:prune-test (lambda (node)
108	(not (geo-point-in-box-p (geo-box node) geo-center))))))
109	(assert placemark-node)
110	(push contract (placemark-contracts placemark-node)))))
111
112	(defun remove-contract (contract-tree contract)
113	(let ((geo-box (contract-geo-box contract))
114	(node (find-contract-node contract-tree contract)))
115	;; if CONTRACT is not in CONTRACT-TREE this is a noop
116	(when node
117	(setf (placemark-contracts node)
118	(delete contract (placemark-contracts node)))
119	;; mark intersecting children as dirty
120	(ensure-intersecting-children contract-tree geo-box #'contract-node-invalidate-timestamp))))
121
122	(defun contract-tree-changed (contract-tree contract &key type)
123	(case type
124	(delete (remove-contract contract-tree contract))
125	(t (if (contract-published-p contract)
126	(insert-contract contract-tree contract)
127	(remove-contract contract-tree contract)))))
128
129	(defmacro handle-if-node-modified (&body body)
130	`(let* ((path (parse-path path))
131	(node (find-node-with-path contract-tree path)))
132	(hunchentoot:handle-if-modified-since (timestamp node))
133	,@body))
134
135	;;; contract-placemark-handler
136	(defclass contract-placemark-handler (object-handler)
137	()
138	(:default-initargs :object-class 'contract)
139	(:documentation "Publishes a contract as a kml placemark to be
140	crawled by Google."))
141
142	(defmethod handle-object ((handler contract-placemark-handler) contract
143	&aux (last-change (store-object-last-change contract 0)))
144	(hunchentoot:handle-if-modified-since last-change)
145	(setf (hunchentoot:header-out :last-modified)
146	(hunchentoot:rfc-1123-date last-change))
147	(let ((name (user-full-name (contract-sponsor contract))))
148	(with-xml-response (:content-type "application/vnd.google-earth.kml+xml")
149	(with-namespace (nil "http://www.opengis.net/kml/2.2")
150	(with-namespace ("atom" "http://www.w3.org/2005/Atom")
151	(with-element "kml"
152	(with-element "Document"
153	(when name (with-element "name" (text name)))
154	(with-element* ("atom" "author")
155	(with-element* ("atom" "name")
156	(text "BOS Deutschland e.V. - Borneo Orangutan Survival Deutschland")))
157	(with-element* ("atom" "link")
158	(attribute "href" (format nil "http://~A" (website-host))))
159	(with-element "Placemark"
160	(when name (with-element "name" (text name)))
161	(with-element "Snippet"
162	(attribute "maxLines" "2")
163	(text (format-date-time (contract-date contract) :show-time nil))
164	(with-element "br")
165	(text (format nil "~D mÂ²" (contract-area contract))))
166	(with-element "description" (cdata (contract-description contract "en")))
167	(with-element "Point"
168	(with-element "coordinates"
169	(destructuring-bind (x y)
170	(contract-center contract)
171	(text (with-output-to-string (out)
172	(kml-format-point (make-point :x x :y y) out))))))))))))))
173
174	;;; sitemap-handler
175	(defclass sitemap-handler (page-handler)
176	())
177
178	(defmethod handle ((handler sitemap-handler))
179	(with-xml-response ()
180	(with-namespace (nil "http://www.sitemaps.org/schemas/sitemap/0.9")
181	(with-namespace ("geo" "http://www.google.com/geo/schemas/sitemap/1.0")
182	(with-element "urlset"
183	(dolist (contract (class-instances 'contract))
184	(when (user-full-name (contract-sponsor contract))
185	(with-element "url"
186	(with-element "loc"
187	(text (format nil "http://~A/contract-placemark/~D"
188	(website-host) (store-object-id contract))))
189	(with-element* ("geo" "geo")
190	(with-element* ("geo" "format") (text "kml")))))))))))
191
192	;;; contract-tree-kml-handler
193	(defclass contract-tree-kml-handler (page-handler)
194	()
195	(:documentation "Generates a kml representation of the queried
196	contract-node. For existing children, corresponding network
197	links are created."))
198
199	(defun write-contract-placemark-kml (c language)
200	(let ((name (user-full-name (contract-sponsor c))))
201	(with-element "Placemark"
202	(when name (with-element "name" (text name)))
203	(with-element "styleUrl" (text "#contractPlacemarkIcon"))
204	(with-element "description" (cdata (contract-description c language)))
205	(with-element "Point"
206	(with-element "coordinates"
207	(destructuring-bind (x y)
208	(contract-center c)
209	(text (with-output-to-string (out)
210	(kml-format-point (make-point :x x :y y) out)))))))))
211
212	(defun parse-path (path)
213	(loop for i from 0 below (length path)
214	collect (parse-integer path :start i :end (1+ i))))
215
216	(defmethod handle ((handler contract-tree-kml-handler))
217	(with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml"
218	:root-element "kml")
219	(with-query-params ((lang "en") (path)
220	(rmcpath) (rmcid))
221	(handle-if-node-modified
222	(setf (hunchentoot:header-out :last-modified)
223	(hunchentoot:rfc-1123-date (timestamp node)))
224	(let* ((lod (node-lod node))
225	(box (geo-box node))
226	(rect (geo-box-rectangle box))
227	(rmcid (when rmcid (parse-integer rmcid)))
228	(rmcpath (parse-path rmcpath)))
229	(with-element "Document"
230	(when (null path)
231	;; for the toplevel
232	(with-element "LookAt"
233	(with-element "longitude" (text "116.987378"))
234	(with-element "latitude" (text "-1.045410"))
235	(with-element "range" (text "2531"))
236	(with-element "tilt" (text "0"))
237	(with-element "heading" (text "0"))))
238	(with-element "Style"
239	(attribute "id" "contractPlacemarkIcon")
240	(with-element "IconStyle"
241	;; (with-element "color" (text "ffffffff"))
242	(with-element "scale" (text "0.8"))
243	(with-element "Icon"
244	(with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host)))))))
245	(kml-region rect lod)
246	;; overlay
247	(kml-overlay (format nil "http://~a/contract-tree-image?path=~{~d~}" (website-host) path)
248	rect
249	:draw-order (compute-draw-order node (1- +max-num-of-local-draw-order-levels+))
250	;; :absolute 0
251	;; GroundOverlay specific LOD
252	:lod lod)
253	;; placemark-contracts
254	(let ((placemark-contracts
255	(if (and rmcid (null rmcpath))
256	(remove rmcid (placemark-contracts node) :key #'store-object-id)
257	(placemark-contracts node))))
258	(cond
259	;; we deal with small-contracts differently at last layer
260	((not (node-has-children-p node))
261	(let* ((predicate #'(lambda (area) (< area 5)))
262	(big-contracts (remove-if predicate placemark-contracts
263	:key #'contract-area))
264	(small-contracts (remove-if-not predicate placemark-contracts
265	:key #'contract-area)))
266	(when small-contracts
267	(with-element "Folder"
268	(kml-region rect `(:min ,(* 3 (getf lod :min)) :max -1))
269	(dolist (c small-contracts)
270	(write-contract-placemark-kml c lang))))
271	(when big-contracts
272	(with-element "Folder"
273	(kml-region rect `(:min ,(getf lod :min) :max -1))
274	(dolist (c big-contracts)
275	(write-contract-placemark-kml c lang))))))
276	;; on all other layers
277	(t (when placemark-contracts
278	(with-element "Folder"
279	(kml-region rect `(:min ,(getf lod :min) :max -1))
280	(dolist (c placemark-contracts)
281	(write-contract-placemark-kml c lang)))))))
282	;; network-links
283	(dotimes (i 4)
284	(let ((child (child node i)))
285	(when child
286	(kml-network-link
287	(if (and rmcpath
288	(= (car rmcpath) i))
289	(format nil "http://~A/contract-tree-kml?path=~{~D~}~d&rmcid=~D&rmcpath=~{~D~}&lang=~A"
290	(website-host) path i rmcid (cdr rmcpath) lang)
291	(format nil "http://~A/contract-tree-kml?path=~{~D~}~D&lang=~A" (website-host) path i lang))
292	:rect (geo-box-rectangle (geo-box child))
293	:lod (node-lod child)))))))))))
294
295
296	;;; image
297
298	;; contract-images are stored as store-images. The image slot of
299	;; contract-node points to the current store-image.
300
301	(defun contract-node-keyword (node)
302	"Used to relate NODE to its store-image."
303	(intern (format nil "CONTRACT-NODE~{~D~}" (node-path node)) #.(find-package "KEYWORD")))
304
305	(defun contract-node-store-image-name (node old-store-image)
306	"Used only as a placeholder for store-image-name that always
307	has to be unique."
308	(let ((next-internal-id (if old-store-image
309	(store-object-id old-store-image)
310	0)))
311	(format nil "contract-node~{~d~}_~D" (node-path node) next-internal-id)))
312
313	(defun contract-node-update-image (node)
314	(labels ((find-contract-color (contract)
315	(destructuring-bind (r g b)
316	(contract-color contract)
317	(cl-gd:find-color r g b :alpha (if (node-has-children-p node)
318	40
319	0)))))
320	(let ((box (geo-box node))
321	(image-size contract-tree-images-size))
322	;; (warn "will update image for ~a" node)
323	(cl-gd:with-image (cl-gd:default-image image-size image-size t)
324	(setf (cl-gd:save-alpha-p) t
325	(cl-gd:alpha-blending-p) nil)
326	(let ((transparent (cl-gd:find-color 255 255 255 :alpha 127))
327	(subbox (make-geo-box 0d0 0d0 0d0 0d0)))
328	(cl-gd:do-rows (y)
329	(cl-gd:do-pixels-in-row (x)
330	(let ((subbox (geo-subbox box x y image-size subbox)))
331	(multiple-value-bind (m2x m2y)
332	(geo-box-middle-m2coord subbox)
333	(setf (cl-gd:raw-pixel)
334	(let* ((m2 (ignore-errors (get-m2 m2x m2y)))
335	(contract (and m2 (m2-contract m2))))
336	(if (and contract (contract-paidp contract))
337	(find-contract-color contract)
338	transparent))))))))
339	(let* ((keyword (contract-node-keyword node))
340	(old-store-image (contract-node-find-corresponding-store-image node))
341	(new-store-image (make-store-image :name (contract-node-store-image-name node old-store-image)
342	:type :png
343	:keywords (list keyword))))
344	;; activate new-store-image
345	(setf (image node) new-store-image)
346	;; delete the old one
347	(when old-store-image
348	(if (probe-file (blob-pathname old-store-image))
349	(delete-file (blob-pathname old-store-image))
350	(warn "Intended to delete ~A of ~A.~%But it already does not exist."
351	(blob-pathname old-store-image) old-store-image))
352	(delete-object old-store-image)))))))
353
354	(defun contract-node-update-image-needed-p (node)
355	(or (null (image node))
356	(> (timestamp node) (blob-timestamp (image node)))))
357
358	(defun contract-node-update-image-if-needed (node)
359	(when (contract-node-update-image-needed-p node)
360	(contract-node-update-image node)))
361
362	(defun contract-tree-update-images-if-needed ()
363	;; I did not see an easy way to avoid that
364	;; CONTRACT-NODE-UPDATE-IMAGE-NEEDED-P is called twice for every
365	;; node. Once inside CONTRACT-NODE-UPDATE-IMAGE-IF-NEEDED and once
366	;; for the prune-test.
367
368	;; Let's hope we are lucky and there is nothing to do by inspecting
369	;; contract-tree at first only once.
370	(when (contract-node-update-image-needed-p contract-tree)
371	(map-nodes #'contract-node-update-image-if-needed contract-tree
372	:prune-test (lambda (node) (not (contract-node-update-image-needed-p node))))))
373
374	(defun contract-tree-force-update-images ()
375	(map-nodes #'contract-node-update-image contract-tree))
376
377	(defun contract-tree-needs-update-p ()
378	(contract-node-update-image-needed-p contract-tree))
379
380	;;; image handler
381	(defclass contract-tree-image-handler (page-handler)
382	())
383
384	(defmethod handle ((handler contract-tree-image-handler))
385	(with-query-params (path)
386	(let* ((path (parse-path path))
387	(node (find-node-with-path contract-tree path))
388	(image (image node)))
389	(assert image nil "contract-tree node ~{~D~} does not have an image" path)
390	(hunchentoot:handle-if-modified-since (blob-timestamp image))
391	(with-store-image* (image)
392	(emit-image-to-browser cl-gd:default-image :png
393	:date (blob-timestamp image)
394	:max-age 600)))))
395
396	;; contract-tree image update daemon
397	(defvar contract-tree-image-update-daemon nil)
398	(defvar contract-tree-image-update-daemon-halt)
399
400	(defun contract-tree-image-update-daemon-loop ()
401	(loop (when contract-tree-image-update-daemon-halt (return))
402	(contract-tree-update-images-if-needed)
403	(sleep 10)))
404
405	(defun contract-tree-image-update-daemon-running-p ()
406	(and contract-tree-image-update-daemon
407	(bt:thread-alive-p contract-tree-image-update-daemon)))
408
409	(defun start-contract-tree-image-update-daemon ()
410	(unless (contract-tree-image-update-daemon-running-p)
411	(setq contract-tree-image-update-daemon-halt nil)
412	(setq contract-tree-image-update-daemon
413	(bt:make-thread #'contract-tree-image-update-daemon-loop
414	:name "contract-tree-image-update-daemon"))))
415
416	(defun stop-contract-tree-image-update-daemon (&key wait)
417	(when (contract-tree-image-update-daemon-running-p)
418	(setq contract-tree-image-update-daemon-halt t)
419	(warn "contract-tree-image-update-daemon will stop soon")
420	(when wait
421	(loop repeat 20
422	do (progn (sleep 1)
423	(when (not (contract-tree-image-update-daemon-running-p))
424	(return))))
425	(if (contract-tree-image-update-daemon-running-p)
426	(error "Failed to stop contract-tree-image-update-daemon")
427	(warn "contract-tree-image-update-daemon stopped")))))
428
429	;;; make-contract-tree-from-m2
430	(defun make-contract-tree-from-m2 ()
431	(when contract-tree
432	(map-nodes #'delete-node-extension contract-tree))
433	(setq contract-tree (make-instance 'contract-node
434	;; we know that MAKE-QUAD-TREE
435	;; has already been called
436	:base-node quad-tree
437	:name 'contract-tree))
438	(dolist (contract (sort (copy-list (all-contracts)) #'> :key #'contract-area))
439	(when (contract-published-p contract)
440	(insert-contract contract-tree contract)))
441	(geometry:register-rect-subscriber geometry:rect-publisher contract-tree
442	(list 0 0 +width+ +width+)
443	#'contract-tree-changed))
444
445	(register-transient-init-function 'make-contract-tree-from-m2
446	'make-quad-tree
447	'geometry:make-rect-publisher)

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format