tags.lisp

Revision 4022, 10.8 kB (checked in by hans, 3 weeks ago)
Set download-only flag in contracts when creating, don't compare price after it has been created.
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	(defun emit-without-quoting (str)
6	;; das ist fuer WPDISPLAY
7	(cxml::maybe-close-tag html-sink)
8	(map nil (lambda (c) (cxml::sink-write-rune c html-sink)) str))
9
10	(defun language-options-1 (current-language)
11	(loop for (language-symbol language-name) in (website-languages)
12	do (if (equal language-symbol current-language)
13	(html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " "))
14	(html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " ")))))
15
16	(define-bknr-tag language-chooser (name)
17	(html ((:select :name name)
18	(language-options-1 (request-language)))))
19
20	(define-bknr-tag language-options ()
21	(language-options-1 (request-language)))
22
23	(define-bknr-tag worldpay-receipt ()
24	(emit-without-quoting "<WPDISPLAY ITEM=banner>"))
25
26	(define-bknr-tag process-payment ()
27	(with-template-vars (cartId transId email country)
28	(let* ((contract (get-contract (parse-integer cartId)))
29	(sponsor (contract-sponsor contract)))
30	(change-slot-values sponsor 'bknr.web::email email)
31	(change-slot-values contract 'bos.m2::worldpay-trans-id transId)
32	(sponsor-set-country sponsor country)
33	(contract-set-paidp contract (format nil "~A: paid via worldpay" (format-date-time)))
34	(setf (get-template-var :master-code) (sponsor-master-code sponsor))
35	(setf (get-template-var :sponsor-id) (sponsor-id sponsor))))
36	(emit-tag-children))
37
38	(define-bknr-tag generate-cert ()
39	(bknr-session)
40	(with-template-vars (gift email name address want-print)
41	(let ((contract (find-store-object (parse-integer (get-template-var :contract-id)))))
42	(when (equal want-print "no")
43	(contract-set-download-only-p contract t))
44	(contract-issue-cert contract name :address address :language (request-language))
45	(send-to-postmaster #'mail-worldpay-sponsor-data contract)
46	(bknr.web::redirect-request :target (if gift "index"
47	(format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
48	(encode-urlencoded name) (encode-urlencoded email)
49	(store-object-id (contract-sponsor contract))))))))
50
51	(define-bknr-tag urkunde-per-post (&key contract-id min-amount message)
52	(let ((contract (get-contract (parse-integer contract-id))))
53	(when (>= (contract-price contract) (parse-integer min-amount))
54	(html (checkbox-field "mail-certificate" message :checked nil)))))
55
56	(define-bknr-tag only-if-print ()
57	(with-template-vars (want-print)
58	(when (equal want-print "yes")
59	(emit-tag-children))))
60
61	(define-bknr-tag maybe-base (&key href)
62	(when (and href
63	(not (equal "" href)))
64	(html ((:base "href" href)))))
65
66	(define-bknr-tag buy-sqm ()
67	(handler-case
68	(with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only)
69	(let* ((numsqm (parse-integer (or numsqm numsqm1)))
70	;; Wer ueber dieses Formular bestellt, ist ein neuer
71	;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine
72	;; Profil-ID wird automatisch zugewiesen, sonstige Daten
73	;; haben wir zu diesem Zeitpunkt noch nicht.
74	;; Ãberweisung wird nur fÃŒr die deutsche und dÃ€nische
75	;; Website angeboten, was passenderweise durch die folgende
76	;; ÃberprÃŒfung auch sicher gestellt wurde. Sollte man aber
77	;; eventuell noch mal prÃŒfen und sicher stellen.
78	(manual-transfer (or (scan #?r"rweisen" action)
79	(scan #?r"rweisung" action)
80	(scan #?r"verf" action)))
81	(language (request-language))
82	(sponsor (make-sponsor :language language))
83	(contract (make-contract sponsor numsqm
84	:download-only (or (< (* +price-per-m2+ numsqm) mail-amount)
85	download-only)
86	:expires (+ (if manual-transfer
87	bos.m2::manual-contract-expiry-time
88	bos.m2::online-contract-expiry-time)
89	(get-universal-time)))))
90	(destructuring-bind (price currency)
91	(case (make-keyword-from-string language)
92	(:da (list (* numsqm 24) "DKK"))
93	(t (list (* numsqm 3) "EUR")))
94	(setf (get-template-var :worldpay-url)
95	(if manual-transfer
96	(format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]"
97	(store-object-id contract)
98	price
99	numsqm
100	donationcert-yearly)
101	(format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&currency=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]"
102	worldpay-installation-id
103	(store-object-id contract)
104	price
105	currency
106	language
107	(encode-urlencoded (format nil "~A ~A Samboja Lestari"
108	numsqm
109	(case (make-keyword-from-string language)
110	(:de "qm Regenwald in")
111	(:da "m2 Regnskov i")
112	(t "sqm rain forest in"))))
113	(store-object-id sponsor)
114	(sponsor-master-code sponsor)
115	(if donationcert-yearly "1" "0")
116	(if gift "1" "0")
117	(when worldpay-test-mode "&testMode=100"))))))
118	(emit-tag-children))
119	(bos.m2::allocation-areas-exhausted (e)
120	(declare (ignore e))
121	(bknr.web::redirect-request :target "allocation-areas-exhausted"))))
122
123	(define-bknr-tag mail-transfer ()
124	(with-query-params (country
125	contract-id
126	name vorname strasse plz ort telefon want-print
127	email donationcert-yearly)
128	(let* ((contract (store-object-with-id (parse-integer contract-id)))
129	(download-only (or (< (contract-price contract) mail-certificate-threshold)
130	(not want-print))))
131	(with-transaction (:prepare-before-mail)
132	(setf (contract-download-only contract) download-only)
133	(setf (sponsor-country (contract-sponsor contract)) country))
134	(contract-issue-cert contract (format nil "~A ~A" vorname name)
135	:address (format nil "~A ~A~%~A~%~A ~A"
136	vorname name
137	strasse
138	plz ort)
139	:language (request-language))
140	(send-to-postmaster #'mail-manual-sponsor-data
141	contract vorname name strasse plz ort email telefon want-print donationcert-yearly
142	(all-request-params)))))
143
144	(define-bknr-tag when-certificate ()
145	(let ((sponsor (bknr-session-user)))
146	(when (some #'contract-pdf-pathname (sponsor-contracts sponsor))
147	(emit-tag-children))))
148
149	(define-bknr-tag send-info-request (&key email country)
150	(mail-info-request email (or country "DE"))
151	(emit-tag-children))
152
153	(define-bknr-tag save-profile ()
154	(let* ((sponsor (bknr-session-user))
155	(contract (first (sponsor-contracts sponsor))))
156	(with-template-vars (email name password infotext anonymize)
157	(when anonymize
158	(change-slot-values sponsor
159	'full-name nil
160	'info-text nil
161	'email nil))
162	(when name
163	(change-slot-values sponsor 'full-name name))
164	(when email
165	(change-slot-values sponsor 'bknr.web::email email))
166	(when password
167	(set-user-password sponsor password))
168	(when infotext
169	(change-slot-values sponsor 'info-text infotext)))
170	(setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor)))
171	(setf (get-template-var :sponsor-language) (format nil "~D" (sponsor-language sponsor)))
172	(setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract)))
173	(setf (get-template-var :country) (sponsor-country sponsor))
174	(setf (get-template-var :infotext) (sponsor-info-text sponsor))
175	(setf (get-template-var :name) (user-full-name sponsor))
176	(setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract)))))
177	(setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract)))))
178	(setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore)
179	(contract-bounding-box contract)
180	(declare (ignore ignore))
181	(apply #'geometry:format-lon-lat nil
182	(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
183	(- +nw-utm-y+ top) +utm-zone+ t))))
184	(setf (get-template-var :numsqm)
185	(format nil "~D"
186	(apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))
187	(emit-tag-children))
188
189	(define-bknr-tag admin-login-page ()
190	(if (editor-p (bknr-session-user))
191	(html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin"))))
192	(emit-tag-children)))
193
194	(define-bknr-tag google-analytics-track ()
195	(html ((:script :type "text/javascript")
196	"var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.');
197	document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));")
198	((:script :type "text/javascript")
199	(:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(google-analytics-account)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))
200
201	(define-bknr-tag set-cachable ()
202	(setf (hunchentoot:header-out :cache-control) "max-age=300"))
203
204	(define-bknr-tag maybe-redirect ()
205	(when (equal (hunchentoot:script-name*) "/")
206	(html (:head ((:meta :http-equiv "refresh" :content "0; url=/index"))))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format