webserver.lisp

Revision 3966, 12.4 kB (checked in by ksprotte, 1 month ago)
removed module stats from bos-website as it does not exist anymore
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `author date id revision`

Line
1	(in-package :bos.web)
2
3	(enable-interpol-syntax)
4
5	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7
8	;;; web handlers
9
10	(defvar website-directory)
11
12	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14
15	(defclass worldpay-template-handler (template-handler)
16	())
17
18	;; find-template-pathname handles the junctioning between the
19	;; different pages which need to be displayed when WorldPay fetches
20	;; the sale completion page. The implementation is kind of hackish:
21	;; If the requested URL is /handle-sale, we do the sales processing
22	;; and change the template name according to the outcome.
23
24	(defmethod find-template-pathname ((handler worldpay-template-handler) template-name)
25	(call-next-method handler
26	(cond
27	((scan #?r"(^\|.*/)handle-sale" template-name)
28	(with-query-params (cartId name address country transStatus lang MC_gift)
29	(unless (website-supports-language lang)
30	(setf lang default-language))
31	(let ((contract (get-contract (parse-integer cartId))))
32	(bos.m2::remember-worldpay-params contract (all-request-params))
33	(sponsor-set-language (contract-sponsor contract) lang)
34	(cond
35	((not (typep contract 'contract))
36	(user-error "Error: Invalid transaction ID."))
37	((contract-paidp contract)
38	(user-error "Error: Transaction already processed."))
39	((equal "C" transStatus)
40	#?"/$(lang)/sponsor_canceled")
41	((< (contract-price contract) mail-certificate-threshold)
42	#?"/$(lang)/quittung")
43	(t
44	(when (<= mail-fiscal-certificate-threshold (contract-price contract))
45	(mail-fiscal-certificate-to-office contract name address country))
46	(if (and MC_gift (equal MC_gift "1"))
47	#?"/$(lang)/versand_geschenk"
48	#?"/$(lang)/versand_info"))))))
49	((equal "" template-name)
50	"de/index")
51	(t
52	template-name))))
53
54	(defmethod initial-template-environment ((expander worldpay-template-handler))
55	(append (list (cons :website-url website-url)
56	(cons :language (request-language)))
57	(call-next-method)))
58
59	(defclass index-handler (page-handler)
60	())
61
62	(defmethod handle ((handler index-handler))
63	(redirect (format nil "/~A/index" (or (find-browser-prefered-language)
64	default-language))
65	:code hunchentoot:+http-moved-permanently+))
66
67	(defclass certificate-handler (object-handler)
68	()
69	(:default-initargs :class 'contract))
70
71	(defmethod handle-object ((handler certificate-handler) contract)
72	(unless contract
73	(setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr.web:bknr-session-user)))))
74	(if (contract-certificates-generated-p contract)
75	(redirect (format nil "/certificates/~D.pdf" (store-object-id contract)))
76	(with-http-response (:content-type "text/html; charset=UTF-8")
77	(with-http-body ()
78	(html
79	(:html
80	(:head
81	(:title "Waiting for certificate generation...")
82	((:meta :http-equiv "Refresh" :content (format nil "3; ~A" (hunchentoot:script-name*)))))
83	(:body
84	"Please wait, certificate is being generated")))))))
85
86	(defclass statistics-handler (editor-only-handler prefix-handler)
87	())
88
89	(defmethod handle ((handler statistics-handler))
90	(let ((stats-name (parse-url)))
91	(cond
92	(stats-name
93	(redirect (format nil "~A.svg" stats-name)))
94	(t
95	(with-bos-cms-page (:title "Statistics browser")
96	(:p
97	((:select :id "selector" :onchange "return statistic_selected()")
98	(dolist (file (directory (merge-pathnames #p"images/statistics/.svg" website-directory*)))
99	(html ((:option :value (pathname-name file))
100	(:princ-safe (pathname-name file)))))))
101	((:p :id "stats"))
102	((:script :type "text/javascript") "statistic_selected()"))))))
103
104	(defclass admin-handler (editor-only-handler page-handler)
105	())
106
107	(defmethod handle ((handler admin-handler))
108	(with-bos-cms-page (:title "CMS and Administration")
109	"Please choose an administration activity from the menu above"))
110
111	(defclass bos-authorizer (bknr-authorizer)
112	())
113
114	(defmethod authorize ((authorizer bos-authorizer))
115	(with-query-params (__sponsorid __password)
116	(if (and __sponsorid __password)
117	(handler-case
118	(let ((sponsor (find-store-object (parse-integer __sponsorid) :class 'sponsor)))
119	(if (and sponsor
120	(or (eql (sponsor-master-code sponsor)
121	(ignore-errors (parse-integer __password)))
122	(verify-password sponsor __password)))
123	sponsor
124	(warn "login failure for sponsor ~a~%" sponsor)))
125	(error (e)
126	(declare (ignore e))
127	(call-next-method)))
128	(call-next-method))))
129
130	(defun request-language ()
131	(or (hunchentoot:aux-request-value :language)
132	default-language))
133
134	(defmethod handle :before ((handler page-handler))
135	(setf (hunchentoot:aux-request-value :language)
136	(or (query-param "language")
137	(query-param "lang")
138	(language-from-url (hunchentoot:request-uri*))
139	(hunchentoot:session-value :language)
140	(find-browser-prefered-language)
141	default-language)))
142
143	;;; TODOreorg
144	(defun publish-directory (&key prefix destination)
145	(push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:dispatch-table))
146
147	(defun publish-website (&key website-directory website-url (worldpay-test-mode t))
148	(setf website-directory website-directory)
149
150	(when website-url
151	(setf website-url website-url))
152
153	(setf worldpay-test-mode worldpay-test-mode)
154	(setf bknr.web:upload-file-size-limit 20000000)
155	(setf hunchentoot::hunchentoot-default-external-format (flex:make-external-format :utf-8 :eol-style :lf))
156
157	(make-instance 'bos-website
158	:name "create-rainforest.org CMS"
159	:handler-definitions `(("/edit-poi-medium" edit-poi-medium-handler)
160	("/edit-poi" edit-poi-handler)
161	("/edit-sponsor" edit-sponsor-handler)
162	("/kml-upload" kml-upload-handler)
163	("/kml-root-dynamic" kml-root-dynamic-handler)
164	("/kml-root" kml-root-handler)
165	("/country-stats" country-stats-handler)
166	("/sitemap.xml" sitemap-handler)
167	("/contract-placemark" contract-placemark-handler)
168	("/contract-tree-kml" contract-tree-kml-handler)
169	("/contract-tree-image" contract-tree-image-handler)
170	("/contract-image" contract-image-handler)
171	("/contract" contract-handler)
172	("/sat-tree-kml" sat-tree-kml-handler)
173	("/sat-root-kml" sat-root-kml-handler)
174	("/look-at-allocation-area" look-at-allocation-area-handler)
175	("/reports-xml" reports-xml-handler)
176	("/complete-transfer" complete-transfer-handler)
177	("/edit-news" edit-news-handler)
178	("/make-poi" make-poi-handler)
179	("/poi-image" poi-image-handler)
180	("/poi-xml" poi-xml-handler)
181	("/poi-kml-all" poi-kml-all-handler)
182	("/poi-kml-look-at" poi-kml-look-at-handler)
183	("/poi-kml" poi-kml-handler)
184	("/map-browser" map-browser-handler)
185	("/poi-javascript" poi-javascript-handler)
186	("/m2-javascript" m2-javascript-handler)
187	("/sponsor-login" sponsor-login-handler)
188	("/create-allocation-area" create-allocation-area-handler)
189	("/allocation-area" allocation-area-handler)
190	("/allocation-cache" allocation-cache-handler)
191	("/certificate" certificate-handler)
192	("/cert-regen" cert-regen-handler)
193	("/cert-issued" cert-issued-handler)
194	("/admin" admin-handler)
195	("/languages" languages-handler)
196	("/overview" image-tile-handler)
197	("/enlarge-overview" enlarge-tile-handler)
198	("/create-contract" create-contract-handler)
199	("/pay-contract" pay-contract-handler)
200	("/cancel-contract" cancel-contract-handler)
201	("/statistics" statistics-handler)
202	("/rss" rss-handler)
203	("/handler-statistics" bknr.web::handler-statistics-handler)
204	("/favicon.ico"
205	file-handler
206	:destination ,(merge-pathnames #p"static/favicon.ico" website-directory)
207	:content-type "image/x-icon")
208	("/index" index-handler)
209	user
210	images
211	("/" worldpay-template-handler
212	:destination ,(namestring (merge-pathnames #p"templates/" website-directory))
213	:command-packages (("http://headcraft.de/bos" . :bos.web)
214	("http://bknr.net" . :bknr.web))))
215	:navigation '(("sponsor" . "edit-sponsor/")
216	("statistics" . "statistics/")
217	("news" . "edit-news/")
218	("poi" . "edit-poi/")
219	("logout" . "logout"))
220	:admin-navigation '(("user" . "user/")
221	("languages" . "languages")
222	("allocation area" . "allocation-area/")
223	("allocation cache" . "allocation-cache")
224	("kml-upload" . "kml-upload"))
225	:authorizer (make-instance 'bos-authorizer)
226	:site-logo-url "/images/bos-logo.gif"
227	:style-sheet-urls '("/static/cms.css")
228	:javascript-urls '("/static/cms.js" "/static/tiny_mce/tiny_mce.js" "/static/MochiKit/MochiKit.js"))
229
230	(publish-directory :prefix "/static/"
231	:destination (merge-pathnames "static/" website-directory))
232	(publish-directory :prefix "/ge/"
233	:destination (merge-pathnames "ge/" website-directory))
234	(publish-directory :prefix "/images/"
235	:destination (merge-pathnames "images/" website-directory))
236	(publish-directory :prefix "/infosystem/"
237	:destination (merge-pathnames "infosystem/" website-directory))
238	(publish-directory :prefix "/certificates/"
239	:destination cert-download-directory))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format