poi-handlers.lisp

Revision 4035, 33.9 kB (checked in by hans, 1 week ago)
Save work before extracting JSON library into a separate package.
Property svn:eol-style set to `native` Property svn:keywords set to `author date id revision`

Line
1	(in-package :bos.web)
2
3	(enable-interpol-syntax)
4
5	;;; make-poi-handler
6	(defclass make-poi-handler (page-handler)
7	())
8
9	(defmethod handle ((handler make-poi-handler))
10	(with-query-params (name)
11	(cond
12	((find-store-object name :class 'poi)
13	(with-bos-cms-page (:title "Duplicate POI name")
14	(html (:h2 "Duplicate POI name")
15	"A POI with that name exists already, please choose a unique name")))
16	((not (scan #?r"(?i)^[a-z][-a-z0-9_]+$" name))
17	(with-bos-cms-page (:title "Bad technical name")
18	(html (:h2 "Bad technical name")
19	"Please use only alphanumerical characters, - and _ for technical POI names")))
20	(t
21	(redirect (edit-object-url (make-poi name)))))))
22
23	;;; edit-poi-handler
24	(defclass edit-poi-handler (editor-only-handler edit-object-handler)
25	()
26	(:default-initargs :object-class 'poi :query-function #'find-poi))
27
28	(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)))
29	(with-bos-cms-page (:title "Choose POI")
30	(if (store-objects-with-class 'poi)
31	(html
32	(:h2 "Choose a POI to edit")
33	(:ul
34	(loop for poi in (sort (store-objects-with-class 'poi) #'string-lessp :key #'poi-name)
35	do (html (:li (cmslink (edit-object-url poi)
36	(:princ-safe (poi-name poi))
37	" - "
38	(:princ-safe (slot-string poi 'title (request-language)))))))))
39	(html (:h2 "No POIs created yet")))
40	((:form :method "post" :action "/make-poi")
41	"Make new POI named "
42	((:input :type "text" :size "20" :name "name")))))
43
44	(defun icon-chooser (name current-icon-name)
45	(unless current-icon-name
46	(setf current-icon-name "palme"))
47	(dolist (icon '("palme" "punkt"))
48	(if (equal current-icon-name icon)
49	(html ((:input :type "radio" :name name :value icon :checked "checked")))
50	(html ((:input :type "radio" :name name :value icon))))
51	(html ((:img :src #?"/images/$(icon).gif")))))
52
53	(defmethod handle-object-form ((handler edit-poi-handler)
54	action (poi poi))
55	(with-query-params (language shift shift-id)
56	(unless language (setq language (request-language)))
57	(when shift
58	(let ((shift (parse-integer shift))
59	(shift-id (parse-integer shift-id)))
60	;; only if this exchange has not already happened
61	(when (= shift-id (store-object-id (nth shift (poi-sat-images poi))))
62	(poi-sat-images-exchange-neighbours poi shift))))
63	(with-bos-cms-page (:title "Edit POI")
64	(content-language-chooser)
65	(unless (poi-complete poi language)
66	(html (:h2 "This POI is not complete in the current language - Please check that "
67	"the location and all text fields are set and that at least 6 images "
68	"have been uploaded.")))
69	(:p (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language)
70	(:format "show this POI in ~A microsite" (string-upcase language))))
71	((:form :method "POST" :enctype "multipart/form-data")
72	((:table :border "1")
73	(:tr (:td "name")
74	(:td (:princ-safe (poi-name poi))))
75	(:tr (:td "published")
76	(:td (checkbox-field "published-web" "published-web" :checked (poi-published-web poi)) " "
77	(checkbox-field "published-earth" "published-earth" :checked (poi-published-earth poi))
78	" with lod-min "
79	(text-field "lod-min" :size 5 :value (poi-lod-min poi))))
80	(:tr (:td "title")
81	(:td (text-field "title"
82	:value (slot-string poi 'title language))))
83	(:tr (:td "subtitle")
84	(:td (text-field "subtitle"
85	:value (slot-string poi 'subtitle language))))
86	(:tr (:td "description")
87	(:td (textarea-field "description"
88	:value (slot-string poi 'description language)
89	:rows 6
90	:cols 60)))
91	(:tr (:td "location")
92	(:td (flet ((format-chosen-url ()
93	(encode-urlencoded
94	(format nil "~A?action=save&language=~A&~
95	~:[~;published-web=on~]&~:[~;published-earth=on~]"
96	(hunchentoot:script-name*)
97	language
98	(poi-published-web poi)
99	(poi-published-earth poi)))))
100	(cond
101	((poi-area poi)
102	(html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi)))))
103	(cmslink (format nil "map-browser/~A/~A?chosen-url=~A"
104	(first (poi-area poi)) (second (poi-area poi)) (format-chosen-url))
105	"[relocate]"))
106	(t
107	(cmslink (format nil "map-browser/?chosen-url=~A"
108	(format-chosen-url))
109	"[choose]"))))))
110	(:tr (:td "icon")
111	(:td (icon-chooser "icon" (poi-icon poi))))
112	(:tr (:td "images for sat-app")
113	(:td
114	((:table)
115	(:tr
116	(loop for image in (poi-sat-images poi)
117	for index upfrom 0
118	do (html (:td ((:a :href (format nil "/edit-poi-medium/~a?poi=~A"
119	(store-object-id image) (store-object-id poi)))
120	((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55"
121	(store-object-id image)))))
122	:br
123	(if (zerop index)
124	(html ((:img :src "/images/trans.gif" :width "16")))
125	(html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D"
126	(store-object-id poi) (1- index)
127	(store-object-id (nth (1- index)
128	(poi-sat-images poi)))))
129	((:img :border "0" :src "/images/pfeil-l.gif")))))
130	((:img :src "/images/trans.gif" :width "23"))
131	(unless (eql index (length (poi-sat-images poi)))
132	(html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D"
133	(store-object-id poi) index
134	(store-object-id image)))
135	((:img :border "0" :src "/images/pfeil-r.gif"))))))))))
136	(unless (= 6 (length (poi-sat-images poi)))
137	(html
138	(:p "You may add to these by uploading a new medium of type 'poi-image' below.")))))
139	(:tr (:td (submit-button "save" "save")
140	(submit-button "delete" "delete" :confirm "Really delete the POI?")))))
141	(:h2 "Upload new medium")
142	((:form :id "upload_new_medium_form"
143	:method "post" :action "/edit-poi-medium" :enctype "multipart/form-data")
144	(:table
145	((:input :type "hidden" :name "poi" :value (store-object-id poi)))
146	(:tr (:td "Type")
147	(:td ((:select :name "new-medium-type" :size "1"
148	:onchange "upload_new_medium_input_toggle(this.value);")
149	((:option :value "poi-image" :selected "selected") "poi-image")
150	((:option :value "poi-airal") "poi-airal")
151	((:option :value "poi-panorama") "poi-panorama")
152	((:option :value "poi-movie") "poi-movie"))))
153	(:tr
154	((:td :id "upload_new_medium_input_label") "File")
155	(:td ((:input :id "upload_new_medium_input" :type "file" :size "60" :name "image-file"))))
156	(:tr ((:td :colspan "2") (submit-button "upload" "upload")))))
157	(:h2 "Attached POI media")
158	((:table :border "1")
159	(dolist (medium (poi-media poi))
160	(html (:tr (:td (:princ-safe (medium-pretty-type-string medium)))
161	(:td (:table
162	(:colgroup ((:col :width "80")) ((:col :width "400")))
163	(:tr (:td)
164	(:td (:b (:princ-safe (slot-string medium 'title language "[no title]"))))
165	(:td (:princ-safe (format-date-time (poi-medium-creation-time medium)))))
166	(:tr (:td ((:p :style "text-align:center;")
167	(cmslink (format nil "/edit-poi-medium/~D?poi=~D"
168	(store-object-id medium) (store-object-id poi))
169	"edit"))
170	((:p :style "text-align:center;")
171	(cmslink (format nil "/edit-poi-medium/~D?action=delete&ask-for-confirmation=on&poi=~D"
172	(store-object-id medium) (store-object-id poi))
173	"delete")))
174	((:td :colspan "2") (medium-handler-preview medium :small t))))))))))))
175
176	(defmethod handle-object-form ((handler edit-poi-handler)
177	(action (eql :save)) (poi poi))
178	(with-query-params ((published-web nil boolean)
179	(published-earth nil boolean)
180	title subtitle description language
181	(x nil integer)
182	(y nil integer)
183	icon
184	(lod-min nil integer))
185	(unless language (setq language (request-language)))
186	(update-textual-attributes poi language
187	:title title
188	:subtitle subtitle
189	:description description)
190	(update-poi poi
191	:published-web published-web
192	:published-earth published-earth
193	:area (when (and x y) (list x y))
194	:icon icon
195	:lod-min lod-min)
196	(with-bos-cms-page (:title "POI has been updated")
197	(html (:h2 "Your changes have been saved")
198	"You may " (cmslink (format nil "~A?language=~A" (edit-object-url poi) language)
199	"continue editing the POI") "."))))
200
201	(defmethod handle-object-form ((handler edit-poi-handler)
202	(action (eql :delete)) (poi poi))
203	(delete-object poi)
204	(with-bos-cms-page (:title "POI has been deleted")
205	(html (:h2 "POI has been deleted")
206	"The POI has been deleted")))
207
208
209	;;; edit-poi-medium-handler
210	(defclass edit-poi-medium-handler (editor-only-handler edit-object-handler)
211	()
212	(:default-initargs :object-class 'poi-medium))
213
214	(defmethod handle-object-form ((handler edit-poi-medium-handler) action (medium poi-medium))
215	(with-query-params (language poi)
216	(assert poi nil "POI id should have been given as a GET param")
217	(unless language (setq language (request-language)))
218	(with-bos-cms-page (:title (format nil "Edit ~A" (medium-pretty-type-string medium)))
219	(html
220	(cmslink (edit-object-url (poi-medium-poi medium)) "Back to POI")
221	(content-language-chooser)
222	(:table (:tr (:td) (:td (medium-handler-preview medium)))
223	(:tr ((:td :colspan "2" :height "10")))
224	((:form :method "post" :enctype "multipart/form-data")
225	((:input :type "hidden" :name "poi" :value poi))
226	(:tr (:td "upload new image")
227	(:td ((:input :type "file" :name "image-file"))
228	:br
229	(submit-button "upload" "upload"))))
230	(:tr ((:td :colspan "2" :height "10")))
231	(:tr (:td "web link")
232	(:td (:princ-safe (medium-web-link medium))))
233	(:tr ((:td :colspan "2" :height "10")))
234	((:form :method "post")
235	(:tr (:td "title")
236	(:td (text-field "title"
237	:value (slot-string medium 'title language))))
238	(:tr (:td "subtitle")
239	(:td (text-field "subtitle"
240	:value (slot-string medium 'subtitle language))))
241	(:tr (:td "description")
242	(:td (textarea-field "description"
243	:value (slot-string medium 'description language)
244	:rows 5
245	:cols 40)))
246	(:tr (:td (submit-button "save" "save")
247	(submit-button "delete" "delete" :confirm "Really delete?")))))))))
248
249	(defgeneric medium-pretty-type-string (medium)
250	(:method ((medium poi-image)) "Image")
251	(:method ((medium poi-panorama)) "Panorama")
252	(:method ((medium poi-airal)) "Airal")
253	(:method ((medium poi-movie)) "Movie"))
254
255	(defgeneric medium-web-link (medium)
256	(:method ((medium store-image))
257	(format nil "http://~A/image/~A"
258	(website-host) (store-object-id medium)))
259	(:method ((medium poi-movie))
260	(poi-movie-url medium)))
261
262	(defgeneric medium-handler-preview (medium &key small)
263	(:method ((medium poi-medium) &key small)
264	(declare (ignore small))
265	(html "No preview"))
266	(:method ((medium store-image) &key small)
267	"The default method for store-images."
268	(html
269	((:a :href (format nil "/edit-poi-medium/~A?poi=~A"
270	(store-object-id medium) (store-object-id (poi-medium-poi medium))))
271	((:img :src (format nil "/image/~A/thumbnail,,70,70" (store-object-id medium)))))
272	(unless small
273	(html
274	(:p "Full size:"
275	(:br)
276	((:img :src (format nil "/image/~A" (store-object-id medium)))))))))
277	(:method ((medium poi-panorama) &key small)
278	(if small
279	(html
280	((:a :href (format nil "/edit-poi-medium/~A?poi=~A"
281	(store-object-id medium) (store-object-id (poi-medium-poi medium))))
282	((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))
283	(html
284	((:applet :archive "/static/ptviewer.jar"
285	:code "ptviewer.class"
286	:width "300"
287	:height "150")
288	((:param :name "file"
289	:value (format nil "/image/~A" (store-object-id medium))))
290	((:param :name "quality" :value "3"))))))
291	(:method ((medium poi-movie) &key small)
292	(if small
293	(call-next-method)
294	(html
295	((:embed :src (poi-movie-url medium)
296	:type "application/x-shockwave-flash"
297	:allowFullScreen "true"
298	:width "425" :height "344"))))))
299
300	(defgeneric medium-handler-validate-image-size (medium-or-type width height)
301	(:method (medium-or-type width height)
302	(declare (ignore medium-or-type width height))
303	t)
304	(:method ((medium standard-object) width height)
305	(medium-handler-validate-image-size (type-of medium) width height))
306	(:method ((type (eql 'poi-image)) width height)
307	(and (= width poi-image-width)
308	(= height poi-image-height)))
309	(:method ((type (eql 'poi-airal)) width height)
310	(and (= width poi-image-width)
311	(= height poi-image-height))))
312
313	(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :save)) (medium poi-medium))
314	(with-query-params (title subtitle description language poi)
315	(unless language (setq language (request-language)))
316	(update-textual-attributes medium language
317	:title title
318	:subtitle subtitle
319	:description description)
320	(let ((type-string (medium-pretty-type-string medium)))
321	(with-bos-cms-page (:title (format nil "~A has been updated" type-string))
322	(:h2 (format nil "The ~A information has been updated" type-string))
323	"You may " (cmslink (format nil "~A?language=~A&poi=~A"
324	(edit-object-url medium) language poi)
325	(:princ-safe (format nil "continue editing the ~A" type-string)))))))
326
327	(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :delete)) (medium poi-medium))
328	(with-query-params ((ask-for-confirmation nil boolean))
329	(let ((poi (poi-medium-poi medium))
330	(type-string (medium-pretty-type-string medium)))
331	(cond
332	(ask-for-confirmation
333	(with-bos-cms-page (:title (format nil "Really delete ~A?" type-string))
334	(:h2 (format nil "Really delete ~A?" type-string))
335	(:p "Yes, " (cmslink (format nil "/edit-poi-medium/~D?action=delete&poi=~D"
336	(store-object-id medium) (store-object-id poi))
337	"delete it."))
338	(:p "No, take me " (cmslink (edit-object-url poi) "back to the POI"))))
339	(t
340	(delete-object medium)
341	(with-bos-cms-page (:title (format nil "~A has been deleted" type-string))
342	(:h2 (format nil "The ~A has been deleted" type-string))
343	"You may " (cmslink (edit-object-url poi) "continue editing the POI")))))))
344
345	(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :upload)) medium)
346	(flet ((make-new-medium (new-medium-type poi)
347	(case new-medium-type
348	(poi-movie
349	(make-instance 'poi-movie :poi poi :url (query-param "url")))
350	(otherwise
351	(let ((upload (request-uploaded-file "image-file")))
352	(unless upload
353	(error "no file uploaded in upload handler"))
354	(bknr.web:with-image-from-upload* (upload)
355	(unless (medium-handler-validate-image-size new-medium-type
356	(cl-gd:image-width) (cl-gd:image-height))
357	(error "Invalid image size. The image needs to be ~D pixels wide and ~D pixels high. Your uploaded ~
358	image is ~D pixels wide and ~D pixels high. Please use an image editor to resize the image ~
359	and upload it again."
360	poi-image-width poi-image-height
361	(cl-gd:image-width) (cl-gd:image-height)))
362	(import-image upload
363	:class-name new-medium-type
364	:initargs `(:poi ,poi))))))))
365	(with-query-params ((poi nil integer)
366	new-medium-type)
367	(setq poi (find-store-object poi :class 'poi))
368	(let* ((new-medium-type (if medium
369	(type-of medium)
370	(intern (string-upcase new-medium-type))))
371	(new-medium (make-new-medium new-medium-type poi)))
372	(when medium
373	(very-shallow-copy-textual-attributes medium new-medium)
374	(delete-object medium))
375	(redirect (format nil "/edit-poi-medium/~D?poi=~D"
376	(store-object-id new-medium)
377	(store-object-id poi)))))))
378
379	;;; poi-javascript-handler
380	(defclass poi-javascript-handler (page-handler)
381	())
382
383	(defun contract-js (contract)
384	(format nil "{ id: ~A, date: ~A, name: ~S, country: ~S, count: ~A }"
385	(store-object-id contract)
386	(format-date-time (contract-date contract) :js-style t)
387	(or (user-full-name (contract-sponsor contract)) "anonymous")
388	(or (sponsor-country (contract-sponsor contract)) "de")
389	(length (contract-m2s contract))))
390
391	(defmethod handle ((handler poi-javascript-handler))
392	(let* ((last-paid-contracts (last-paid-contracts))
393	(timestamp (max (reduce #'max (class-instances 'poi)
394	:key (lambda (poi) (store-object-last-change poi 1)))
395	(reduce #'max last-paid-contracts
396	:key (lambda (contract) (store-object-last-change contract 0))))))
397	(hunchentoot:handle-if-modified-since timestamp)
398	(setf (hunchentoot:header-out :last-modified)
399	(hunchentoot:rfc-1123-date timestamp))
400	(with-http-response (:content-type "text/html; charset=UTF-8")
401	(with-http-body ()
402	(html
403	((:script :language "JavaScript")
404	(:princ (make-poi-javascript (request-language)))
405	(:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);")
406	(:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);"
407	(mapcar #'contract-js last-paid-contracts)))))))))
408
409	;;; poi-xml-handler
410	(defun write-poi-xml (poi language)
411	"Writes the poi xml format for one specific language. This is used
412	to generate the POI microsite using XSLT (client side)."
413	(macrolet ((with-media ((type title &optional (subtitle "")) &body body)
414	`(with-element "media"
415	(attribute "type" ,type)
416	(attribute "title" ,title)
417	(attribute "subtitle" ,subtitle)
418	,@body)))
419	(labels ((poi-string (slot-name)
420	(slot-string poi slot-name language))
421	(format-image (image)
422	(with-element "image"
423	(attribute "id" (princ-to-string (store-object-id image)))
424	(when (typep image 'poi-image)
425	(attribute "title" (slot-string image 'title language))
426	(attribute "subtitle" (slot-string image 'subtitle language))
427	(with-element "description" (text (slot-string image 'description language))))
428	(with-element "url" (text (format nil "http://~A/image/~D"
429	(website-host) (store-object-id image))))
430	(with-element "width" (text (princ-to-string (store-image-width image))))
431	(with-element "height" (text (princ-to-string (store-image-height image)))))))
432	(with-accessors ((id store-object-id)
433	(name poi-name)
434	(title poi-title)
435	(subtitle poi-subtitle)
436	(description poi-description)
437	(airals poi-airals)
438	(images poi-sat-images)
439	(panoramas poi-panoramas)
440	(movies poi-movies)) poi
441	(with-element "poi"
442	(attribute "id" (princ-to-string id))
443	(attribute "title" (poi-string 'title))
444	(attribute "subtitle" (poi-string 'subtitle))
445	(with-element "menu"
446	(with-element "entry" (attribute "title" "Impressum")
447	(attribute "onclick" (format nil "window_extra('/~A/impressum')" language)))
448	(with-element "entry" (attribute "title" "Spenden")
449	(attribute "onclick"
450	(format nil "window.location.href = '/~A/bestellung'; return false;"
451	language))))
452	(with-element "description" (text (poi-string 'description)))
453	(with-media ("image_gallery" "Bildergalerie")
454	(mapc #'format-image images))
455	(dolist (airal airals)
456	(with-media ("airal" "Luftbild")
457	(format-image airal)))
458	#+(or)
459	(dolist (panorama panoramas)
460	(with-media ("panorama" "Panorama" (store-image-name panorama))
461	(format-image panorama)))
462	(dolist (movie movies)
463	(with-media ("movie" "Video")
464	(with-element "url" (text (poi-movie-url movie))))))))))
465
466	(defun find-poi-or-ptdefault (string)
467	(if (string= string "PTDefault.html")
468	:ptdefault
469	(find-poi string)))
470
471	(defclass poi-xml-handler (object-handler)
472	()
473	(:default-initargs :query-function #'find-poi-or-ptdefault))
474
475
476	(defmethod handle-object ((handler poi-xml-handler) poi)
477	(let ((timestamp (store-object-last-change poi 1)))
478	(hunchentoot:handle-if-modified-since timestamp)
479	(setf (hunchentoot:header-out :last-modified)
480	(hunchentoot:rfc-1123-date timestamp))
481	(with-query-params ((lang "en"))
482	(with-xml-response (:xsl-stylesheet-name "/static/poi.xsl")
483	(write-poi-xml poi lang)))))
484
485	(defmethod handle-object ((handler poi-xml-handler) (poi (eql :ptdefault)))
486	"ptviewer will request /poi-xml/PTDefault.html"
487	)
488
489	;;; poi-kml-handler
490	(defun poi-description-google-earth (poi language &key (image-width 120))
491	(labels ((website-path (path &rest args)
492	(format nil "http://~a~a" (website-host)
493	(apply #'format nil path args)))
494	(poi-xml-path ()
495	(website-path "/poi-xml/~D?lang=~A" (store-object-id poi) language))
496	(img-thumbnail (image)
497	(let* ((id (store-object-id image))
498	(height (store-image-height image))
499	(width (store-image-width image))
500	(aspect-ratio (floor width height))
501	(h (* aspect-ratio image-width))
502	(w image-width))
503	(with-element "img"
504	(attribute "height" (prin1-to-string h))
505	(attribute "width" (prin1-to-string w))
506	(attribute "src" (website-path "/image/~D/thumbnail,,~D,~D" id w h)))))
507	(img-td (image)
508	(with-element "td"
509	(with-element "a"
510	(attribute "href" (poi-xml-path))
511	(img-thumbnail image))))
512	(img-td-title (image)
513	(with-element "td"
514	(attribute "valign" "top")
515	(with-element "span"
516	(attribute "style" "font-size: small;")
517	(text (slot-string image 'title language)))))
518	(images-2trs (images)
519	;; images
520	(with-element "tr"
521	(dolist (image images)
522	(img-td image)))
523	;; titles
524	(with-element "tr"
525	(dolist (image images)
526	(img-td-title image)))))
527	(handler-case
528	(with-xml-output (make-string-sink)
529	(with-element "html"
530	(with-element "head")
531	(with-element "body"
532	(with-element "table"
533	(attribute "cellspacing" "0") (attribute "width" "500")
534	(attribute "cellpadding" "5") (attribute "border" "0")
535	(attribute "style" "background-color: rgb(186, 186, 186);")
536	(with-element "tbody"
537	(with-element "tr"
538	(with-element "td"
539	(attribute "style" "width: 99px; text-align: left;")
540	(attribute "colspan" "3")
541	(with-element "img"
542	(attribute "width" "400")
543	(attribute "alt" "create rainforest banner / bos logo")
544	(attribute "src" (website-path "/images/google-header-~A.gif"
545	(if (equal "de" language) "de" "en"))))))
546	(with-element "tr"
547	(with-element "td"
548	(attribute "style" "width: 100px;")
549	(with-element "h1" (text (slot-string poi 'title language)))
550	(with-element "h2" (text (slot-string poi 'subtitle language)))
551	(with-element "table"
552	(attribute "width" "400")
553	(with-element "tr" (with-element "td" (text (slot-string poi 'description language)))))
554	(cond
555	((= 1983023 (store-object-id poi))
556	(with-element "p" (with-element "a"
557	(attribute "href" (website-path "/~a/bestellung" language))
558	(text (dictionary-entry "Join in!" language)))))
559	(t
560	(with-element "br")
561	(with-element "br")))
562	(with-element "table"
563	(with-element "tbody"
564	(let ((images (poi-sat-images poi)))
565	(images-2trs (subseq images 0 (min 3 (length images))))
566	(when (> (length images) 3)
567	(images-2trs (subseq images 3 (min 6 (length images))))))))))
568	(with-element "tr"
569	(with-element "td"
570	(attribute "colspan" "3")
571	(attribute "align" "center")
572	(with-element "a"
573	(attribute "href" (poi-xml-path))
574	(attribute "target" "POI-micro-site")
575	(text (dictionary-entry "learn more" language)))))
576	(with-element "tr"
577	(with-element "td"
578	(attribute "valign" "middle")
579	(attribute "align" "center")
580	(attribute "colspan" "3")
581	(attribute "style" "width: 99px;")
582	(with-element "font"
583	(attribute "color" "#999999")
584	(with-element "a"
585	(attribute "href" (website-path "/~A/index" language))
586	(text "create rainforest"))))))))))
587	(error (c) (error "while generating poi-description-google-earth for ~s:~%~a" poi c)))))
588
589	(defun write-poi-kml (poi language)
590	(with-element "Placemark"
591	(with-element "name" (text (or (slot-string poi 'title language nil)
592	(slot-string poi 'title "en"))))
593	(kml-region (make-rectangle2 (list 0 0 +width+ +width+)) `(:min ,(poi-lod-min poi) :max -1))
594	(with-element "styleUrl" (text "#poiPlacemarkIcon"))
595	(with-element "description"
596	(cdata (poi-description-google-earth poi language)))
597	(with-element "Snippet"
598	(text (slot-string poi 'subtitle language)))
599	(with-element "Point"
600	(with-element "coordinates"
601	(text (format nil "~{~,20F,~}0" (poi-center-lon-lat poi)))))))
602
603	(defclass poi-kml-handler (object-handler)
604	()
605	(:default-initargs :object-class 'poi :query-function #'find-poi))
606
607
608	(defmethod handle-object ((handler poi-kml-handler) poi)
609	(with-query-params ((lang "en"))
610	(with-xml-response ()
611	(with-namespace (nil "http://earth.google.com/kml/2.1")
612	(with-element "kml"
613	(write-poi-kml poi lang))))))
614
615	;;; poi-kml-all-handler
616	(defclass poi-kml-all-handler (page-handler)
617	())
618
619	(defmethod handle ((handler poi-kml-all-handler))
620	(let* ((relevant-pois (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published-earth poi)))
621	(class-instances 'poi)))
622	(pois-last-change (reduce #'max relevant-pois :key (lambda (poi) (store-object-last-change poi 1))
623	:initial-value 0)))
624	(hunchentoot:handle-if-modified-since pois-last-change)
625	(setf (hunchentoot:header-out :last-modified)
626	(hunchentoot:rfc-1123-date pois-last-change))
627	(with-query-params ((lang "en"))
628	(with-xml-response ()
629	;; (sax:processing-instruction cxml::sink "xml-stylesheet" "href=\"/static/tri.xsl\" type=\"text/xsl\"")
630	(with-namespace (nil "http://earth.google.com/kml/2.1")
631	(with-element "kml"
632	(with-element "Document"
633	(with-element "Style"
634	(attribute "id" "poiPlacemarkIcon")
635	(with-element "IconStyle"
636	;; (with-element "color" (text "ffffffff"))
637	(with-element "scale" (text "0.8"))
638	(with-element "Icon"
639	(with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host)))))))
640	(mapc #'(lambda (poi) (write-poi-kml poi lang)) relevant-pois))))))))
641
642	;;; poi-kml-look-at-handler
643	(defclass poi-kml-look-at-handler (object-handler)
644	()
645	(:default-initargs :object-class 'poi :query-function #'find-poi))
646
647	(defmethod handle-object ((handler poi-kml-look-at-handler) poi)
648	(let ((poi-last-change (store-object-last-change poi 0)))
649	(hunchentoot:handle-if-modified-since poi-last-change)
650	(setf (hunchentoot:header-out :last-modified)
651	(hunchentoot:rfc-1123-date poi-last-change)
652	(hunchentoot:header-out :content-disposition)
653	(format nil "attachment; filename=look-at-~A.kml" (store-object-id poi)))
654	(destructuring-bind (lon lat)
655	(poi-center-lon-lat poi)
656	(with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8")
657	(with-namespace (nil "http://earth.google.com/kml/2.1")
658	(with-element "kml"
659	(with-element "Document"
660	(with-element "LookAt"
661	(with-element "longitude" (text (format nil "~,20F" lon)))
662	(with-element "latitude" (text (format nil "~,20F" lat)))
663	(with-element "range" (text "253"))
664	(with-element "tilt" (text "0"))
665	(with-element "heading" (text "0"))))))))))
666
667	;;; poi-image-handler
668	(defclass poi-image-handler (object-handler)
669	()
670	(:default-initargs :object-class 'poi :query-function #'find-poi))
671
672	(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)))
673	(error "poi not found"))
674
675	(defmethod handle-object ((handler poi-image-handler) poi)
676	(destructuring-bind (poi-name image-index-string &rest imageproc-arguments)
677	(multiple-value-list (parse-handler-url handler))
678	(declare (ignore poi-name))
679	(let ((image-index (1- (parse-integer image-index-string))))
680	(if (and (not (minusp image-index))
681	(< image-index (length (poi-sat-images poi))))
682	(redirect (format nil "/image/~D~@[~{/~a~}~]"
683	(store-object-id (nth image-index (poi-sat-images poi)))
684	imageproc-arguments))
685	(error "image index ~a out of bounds for poi ~a" image-index poi)))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format