sponsor-handlers.lisp

Revision 4023, 18.2 kB (checked in by hans, 3 weeks ago)
Convert numsqm to integer before using it for calculations.
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	(defclass search-sponsors-handler (editor-only-handler form-handler)
6	())
7
8	(defmethod handle-form ((handler search-sponsors-handler) action)
9	(with-bos-cms-page (:title "Search for sponsor")))
10
11	(defclass edit-sponsor-handler (editor-only-handler edit-object-handler)
12	())
13
14	(defmethod object-handler-get-object ((handler edit-sponsor-handler))
15	(let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler)))))))
16	(typecase object
17	(sponsor object)
18	(contract (contract-sponsor object))
19	(otherwise nil))))
20
21	(defmethod language-selector ((language string))
22	(html
23	((:select :name "language")
24	(loop
25	for (language-symbol language-name) in (website-languages)
26	do (if (string-equal language-symbol language)
27	(html ((:option :value language-symbol :selected "selected")
28	(:princ-safe language-name)))
29	(html ((:option :value language-symbol)
30	(:princ-safe language-name))))))))
31
32	(defmethod language-selector ((sponsor sponsor))
33	(language-selector (sponsor-language sponsor)))
34
35	(defmethod language-selector ((contract contract))
36	(language-selector (contract-sponsor contract)))
37
38	(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)))
39	(with-query-params (id key count)
40	(format t "id ~A key ~A count ~A~%" id key count)
41	(when id
42	(redirect #?"/edit-sponsor/$(id)"))
43	(if (or key count)
44	(let ((regex (format nil "(?i)~A" key))
45	(found 0))
46	(when count
47	(setf count (parse-integer count)))
48	(with-bos-cms-page (:title "Sponsor search results")
49	((:table :border "1")
50	(:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Country") (:th "Cert-Type") (:th "Paid by"))
51	(dolist (sponsor (sort (remove-if-not #'sponsor-contracts (class-instances 'sponsor))
52	#'> :key #'(lambda (sponsor) (contract-date (first (sponsor-contracts sponsor))))))
53	(when (or count
54	(or (ignore-errors (scan regex (user-full-name sponsor)))
55	(ignore-errors (scan regex (user-email sponsor)))))
56	(let ((contract (first (sponsor-contracts sponsor))))
57	(html (:tr (:td (cmslink #?"edit-sponsor/$((store-object-id sponsor))" (:princ-safe (store-object-id sponsor))))
58	(:td (:princ-safe (format-date-time (contract-date contract) :show-time nil)))
59	(:td (:princ-safe (or (user-email sponsor) "<unknown>")))
60	(:td (:princ-safe (or (user-full-name sponsor) "<unknown>")))
61	(:td (:princ-safe (length (contract-m2s contract))))
62	(:td (:princ-safe (sponsor-country sponsor)))
63	(:td (:princ-safe (if (contract-download-only-p contract) "Download" "Print")))
64	(:td (:princ-safe (contract-paidp contract))))))
65	(when (eql (incf found) count)
66	(return))))
67	(:tr ((:th :colspan "7") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found"))))))))
68	(with-bos-cms-page (:title "Find or Create Sponsor")
69	(html
70	((:form :name "form")
71	((:table)
72	(:tr ((:td :colspan "2")
73	(:h2 "Search for sponsor")))
74	(:tr (:td "Sponsor- or Contract-ID")
75	(:td (text-field "id" :size 7)))
76	(:tr (:td "Email-Adress or name")
77	(:td (text-field "key")))
78	(:tr (:td "Show new sponsors (enter count)")
79	(:td (text-field "count" :size 4)))
80	(:tr (:td (submit-button "search" "search")))
81	(:tr (:td "") (:td ((:a :class "cmslink"
82	:href "/reports-xml/all-contracts?download=contracts.xls")
83	"Download complete sponsor DB in XML format")))
84	(:tr ((:th :colspan "2" :align "left")
85	(:h2 "Create sponsor")))
86	(:tr (:td "Date (DD.MM.YYYY)")
87	(:td (text-field "date" :size 10 :value (format-date-time (get-universal-time) :show-time nil))))
88	(:tr (:td "Number of square meters")
89	(:td (text-field "numsqm" :size 5)))
90	(:tr (:td "Country code (2 chars)")
91	(:td (text-field "country" :size 2 :value "DE")))
92	(:tr (:td "Email-Address")
93	(:td (text-field "email" :size 40)))
94	(:tr (:td "Language for communication and certificate")
95	(:td (language-selector "de")))
96	(:tr (:td "Name for certificate")
97	(:td (text-field "name" :size 20)))
98	(:tr (:td "Postal address for certificate")
99	(:td (textarea-field "address" :rows 5 :cols 40)))
100	(:tr (:td "Issue donation cert at the end of the year")
101	(:td (checkbox-field "donationcert-yearly" "" :checked nil)))
102	(:tr (:td "Sponsor wants a printed certificate")
103	(:td (checkbox-field "want-print" "" :checked nil)))
104	(:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()"))))))))))
105
106	(defun date-to-universal (date-string)
107	(apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string))))
108
109	(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)))
110	(with-query-params (numsqm country email name address date language want-print)
111	(let* ((sponsor (make-sponsor :email email :country country :language language))
112	(numsqm (parse-integer numsqm))
113	(contract (make-contract sponsor numsqm
114	:paidp (format nil "~A: manually created by ~A"
115	(format-date-time (get-universal-time))
116	(user-login (bknr.web:bknr-session-user)))
117	:date (date-to-universal date)
118	:download-only (or (< (* +price-per-m2+ numsqm) mail-amount)
119	(not want-print)))))
120	(contract-issue-cert contract name :address address :language language)
121	(send-to-postmaster #'mail-backoffice-sponsor-data contract numsqm country email name address language (all-request-params))
122	(when (and email
123	(length email))
124	(mail-instructions-to-sponsor contract email))
125	(redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor))))))
126
127	(defun contract-checkbox-name (contract)
128	(format nil "contract-~D-paid" (store-object-id contract)))
129
130	(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor)
131	(with-bos-cms-page (:title "Edit Sponsor")
132	(html
133	((:form :method "post")
134	(:h2 "Sponsor Data")
135	((:table)
136	(:tr (:td "sponsor-id")
137	(:td (:princ-safe (store-object-id sponsor))))
138	(:tr (:td "master-code")
139	(:td (:princ-safe (sponsor-master-code sponsor))))
140	(:tr (:td "name")
141	(:td (text-field "full-name" :value (user-full-name sponsor))))
142	(:tr (:td "email")
143	(:td (text-field "email" :value (user-email sponsor))))
144	(:tr (:td "password")
145	(:td (text-field "password" :size 20))
146	(:td "(Password is never displayed)"))
147	(:tr (:td "country")
148	(:td (text-field "country"
149	:value (sponsor-country sponsor)
150	:size 2)))
151	(:tr (:td "language")
152	(:td (language-selector sponsor)))
153	(:tr (:td "info-text")
154	(:td (textarea-field "info-text"
155	:value (sponsor-info-text sponsor)
156	:rows 5
157	:cols 40))))
158	(:p (cmslink (format nil "kml-root/~A?lang=~A" (store-object-id sponsor) (sponsor-language sponsor)) "Google Earth"))
159	(:h2 "Contracts")
160	((:table :border "1")
161	(:tr (:th "ID") (:th "date") (:th "# of sqm") (:th "UTM coordinate")(:th "paid?") (:th))
162	(dolist (contract (sort (copy-list (sponsor-contracts sponsor)) #'> :key #'contract-date))
163	(html (:tr (:td (:princ-safe (store-object-id contract)))
164	(:td (:princ-safe (format-date-time (contract-date contract) :show-time nil)))
165	(:td (:princ-safe (length (contract-m2s contract))))
166	(:td (:princ (format nil "~,3f<br/>~,3f"
167	(m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor)))))
168	(m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor))))))))
169	(:td (:princ-safe (if (contract-paidp contract) "paid" "not paid")))
170	(:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
171	(when (probe-file (contract-pdf-pathname contract))
172	(html :br (cmslink (contract-pdf-url contract) "Show Certificate")))
173	(when (contract-worldpay-trans-id contract)
174	(html :br ((:a :class "cmslink"
175	:target "_new"
176	:href (format nil "https://select.worldpay.com/merchant/orderList/showOrderDetailMerchant.html?orderCode=~A"
177	(contract-worldpay-trans-id contract)))
178	"Show WorldPay transaction"))))))))
179	(:p (submit-button "save" "save")
180	(submit-button "delete" "delete" :confirm "Really delete this sponsor?"))))))
181
182	(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor)
183	(let (changed)
184	(with-bos-cms-page (:title "Saving sponsor data")
185	(dolist (field-name '(full-name email password country language info-text))
186	(let ((field-value (query-param (string-downcase (symbol-name field-name)))))
187	(when (and field-value
188	(not (equal field-value (slot-value sponsor field-name))))
189	(case field-name
190	(password (set-user-password sponsor field-value))
191	(t (change-slot-values sponsor field-name field-value)))
192	(setf changed t)
193	(html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
194	(dolist (contract (sponsor-contracts sponsor))
195	(when (and (query-param (contract-checkbox-name contract))
196	(not (contract-paidp contract)))
197	(change-slot-values contract 'paidp t)
198	(setf changed t)
199	(html (:p "Changed contract status to \"paid\""))))
200	(unless changed
201	(html (:p "No changes have been made")))
202	(html (cmslink (hunchentoot:request-uri*)
203	"Return to sponsor profile")))))
204
205	(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor)
206	(with-bos-cms-page (:title "Sponsor deleted")
207	(delete-object sponsor)
208	(html (:p "The sponsor has been deleted"))))
209
210	(defclass complete-transfer-handler (editor-only-handler edit-object-handler)
211	()
212	(:default-initargs :object-class 'contract))
213
214	(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)))
215	(with-bos-cms-page (:title "Invalid contract ID")
216	(html "Invalid contract ID, maybe the sponsor or the contract has been deleted")))
217
218	(defmethod handle-object-form ((handler complete-transfer-handler) action contract)
219	(if (contract-paidp contract)
220	(redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))))
221	(let ((numsqm (length (contract-m2s contract))))
222	(with-query-params (email)
223	(with-bos-cms-page (:title "Complete square meter sale with wire transfer payment")
224	(html
225	((:form :name "form")
226	((:input :type "hidden" :name "numsqm" :value #?"$(numsqm)"))
227	((:table)
228	(:tr (:td "Number of square meters")
229	(:td (:princ-safe numsqm)))
230	(:tr (:td "Bought on")
231	(:td (:princ-safe (format-date-time (contract-date contract)))))
232	(:tr (:td "Country code (2 chars)")
233	(:td (text-field "country" :size 2 :value "DE")))
234	(:tr (:td "Language")
235	(:td (:princ-safe (sponsor-language (contract-sponsor contract)))))
236	(:tr (:td "Email-Address")
237	(:td (text-field "email" :size 20 :value email)))
238	(:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()")))))))))))
239
240	(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract)
241	(with-query-params (email country)
242	(with-bos-cms-page (:title "Square meter sale completion")
243	(if (contract-paidp contract)
244	(html (:h2 "This sale has already been completed"))
245	(progn
246	(html (:h2 "Completing square meter sale"))
247	(sponsor-set-country (contract-sponsor contract) country)
248	(contract-set-paidp contract (format nil "~A: wire transfer processed by ~A"
249	(format-date-time) (user-login (bknr.web:bknr-session-user))))
250	(when email
251	(html (:p "Sending instruction email to " (:princ-safe email)))
252	(mail-instructions-to-sponsor contract email))))
253	(:p (cmslink (format nil "edit-sponsor/~D" (store-object-id (contract-sponsor contract)))
254	"click here") " to edit the sponsor's database entry"))))
255
256	(defclass m2-javascript-handler (prefix-handler)
257	())
258
259	(defmethod handle ((handler m2-javascript-handler))
260	(multiple-value-bind (sponsor-id-or-x y) (parse-url)
261	(let ((sponsor (cond
262	(y
263	(let ((m2 (get-m2 (parse-integer sponsor-id-or-x) (parse-integer y))))
264	(when (and m2 (m2-contract m2))
265	(contract-sponsor (m2-contract m2)))))
266	(sponsor-id-or-x
267	(find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor))
268	(t
269	(and (typep (bknr-session-user) 'sponsor)
270	(bknr-session-user))))))
271	(with-http-response (:content-type "text/html; charset=UTF-8")
272	(with-http-body ()
273	(html
274	((:script :language "JavaScript")
275	(:princ "var profil;")
276	(when (and sponsor (find-if #'contract-paidp (sponsor-contracts sponsor)))
277	(html (:princ (make-m2-javascript sponsor))))
278	(:princ "parent.qm_fertig(profil);"))))))))
279
280	(defclass sponsor-login-handler (page-handler)
281	())
282
283	(defmethod handle ((handler sponsor-login-handler))
284	(with-query-params (__sponsorid)
285	(with-http-response (:content-type "text/html")
286	(setf (hunchentoot:header-out :cache-control) "no-cache")
287	(setf (hunchentoot:header-out :pragma) "no-cache")
288	(setf (hunchentoot:header-out :expires) "-1")
289	(with-http-body ()
290	(html
291	((:script :language "JavaScript")
292	(:princ (format nil "parent.set_loginstatus('~A');"
293	(cond
294	((typep (bknr-session-user) 'sponsor)
295	"logged-in")
296	(__sponsorid
297	"login-failed")
298	(t
299	"not-logged-in"))))))))))
300
301	(defclass cert-regen-handler (editor-only-handler edit-object-handler)
302	()
303	(:default-initargs :class 'contract))
304
305	(defmethod object-handler-get-object ((handler cert-regen-handler))
306	(let* ((object-id-string (first (decoded-handler-path handler)))
307	(object (store-object-with-id (parse-integer object-id-string))))
308	(cond
309	((contract-p object)
310	object)
311	((sponsor-p object)
312	(first (sponsor-contracts object)))
313	(t (error "invalid sponsor or contract id ~A" object-id-string)))))
314
315	(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract))
316	(with-bos-cms-page (:title (format nil "Re-generate Certificate~@[~*s~]"
317	(not (contract-download-only-p contract))))
318	(html
319	((:form :name "form")
320	((:table)
321	(:tr (:td "Name")
322	(:td (text-field "name" :size 40)))
323	(:tr (:td "Language")
324	(:td (language-selector contract)))
325	(unless (contract-download-only-p contract)
326	(html
327	(:tr (:td "Address")
328	(:td (textarea-field "address")))))
329	(html
330	(:tr (:td (submit-button "regenerate" "regenerate")))))))))
331
332	(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract))
333	(with-query-params (name address language)
334	(contract-issue-cert contract name :address address :language language))
335	(redirect #?"/cert-regen/$((store-object-id contract))?action=wait"))
336
337	(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :wait)) (contract contract))
338	(if (not (and (contract-certificates-generated-p contract)
339	(not (contract-tree-needs-update-p))))
340	(with-http-response (:content-type "text/html; charset=UTF-8")
341	(with-http-body ()
342	(html
343	(:html
344	(:head ((:meta :http-equiv "refresh"
345	:content #?"2; url=/cert-regen/$((store-object-id contract))?action=wait")))
346	(:body (:p "waiting for certificate to be regenerated..."))))))
347	(with-bos-cms-page (:title "Certificate has been recreated")
348	(html "The certificates for the sponsor have been re-generated." :br)
349	(unless (contract-download-only-p contract)
350	(mail-print-pdf contract)
351	(html "The print certificate has been sent to the relevant BOS office address by email." :br))
352	(let ((sponsor (contract-sponsor contract)))
353	(cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor")))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format