- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] ksprotte changed trunk/projects/bos/test/allocation.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3570 Author: ksprotte URL: http://bknr.net/trac/changeset/3570 added a test allocation.disconnected-m2s.1 that should fail U trunk/projects/bos/test/allocation.lisp Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-23 08:34:26 UTC (rev 3569) +++ trunk/projects/bos/test/allocation.lisp 2008-07-23 09:27:20 UTC (rev 3570) @@ -210,4 +210,24 @@ (test validate-allocation-area-inclusion-cache (with-fixture initial-bos-store () (let ((area1 (make-allocation-rectangle 0 0 8 8))) - (finishes (bos.m2::validate-allocation-area-inclusion-cache))))) \ No newline at end of file + (finishes (bos.m2::validate-allocation-area-inclusion-cache))))) + +(test allocation.disconnected-m2s.1 + (with-fixture initial-bos-store (:delete-store t) + (let ((area (make-allocation-area #((7193 . 5195) (7351 . 5193) (7340 . 5377) (7185 . 5390) (7174 . 5385) + (7166 . 5387) (7156 . 5381) (7150 . 5379) (7143 . 5374) (7136 . 5368) + (7135 . 5364) (7135 . 5359) (7140 . 5347) (7145 . 5342) (7148 . 5329) + (7156 . 5329) (7157 . 5334) (7166 . 5331) (7170 . 5329) (7171 . 5327) + (7174 . 5316) (7184 . 5306) (7185 . 5291) (7196 . 5286) (7197 . 5287) + (7200 . 5287) (7201 . 5284) (7203 . 5275) (7201 . 5264) (7191 . 5249) + (7203 . 5237) (7199 . 5235) (7195 . 5233) (7198 . 5222) (7202 . 5219) + (7202 . 5214) (7204 . 5205) (7195 . 5197)))) + (sponsor (make-sponsor :login "test-sponsor")) + (m2-counts '(12 43 29 3))) + (dolist (m2-count m2-counts) + (let ((contract (make-contract sponsor m2-count))) + (print (list 'make-contract-returned contract)))) + ;; This following check reported: + ;; WARNING: #<CONTRACT ID: 32131, unpaid> has m2s that are not + ;; connected + (is (bos.m2::consistent-p))))) \ No newline at end of file

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/m2.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3569 Author: ksprotte URL: http://bknr.net/trac/changeset/3569 added new function m2s-connected-p for debugging purposes U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-23 08:24:33 UTC (rev 3568) +++ trunk/projects/bos/m2/m2.lisp 2008-07-23 08:34:26 UTC (rev 3569) @@ -111,6 +111,21 @@ (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) polygon))) +(defun m2s-connected-p (m2s) + "Is this region of m2 objects geographically connected? We do + not care about associated contracts or anything else." + (labels ((m2-neighbours (m2) + (let ((x (m2-x m2)) + (y (m2-y m2))) + (delete-if (lambda (m2) (not (member m2 m2s))) + (list (get-m2 (1- x) y) + (get-m2 (1+ x) y) + (get-m2 x (1- y)) + (get-m2 x (1+ y))))))) + (geometry:nodes-connected-p m2s + #'m2-neighbours + #'eq))) + ;;;; SPONSOR ;;; Exportierte Funktionen:

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3568 Author: hans URL: http://bknr.net/trac/changeset/3568 add cert-issued handler just in case U trunk/projects/bos/web/contract-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/contract-handlers.lisp =================================================================== --- trunk/projects/bos/web/contract-handlers.lisp 2008-07-23 07:40:34 UTC (rev 3567) +++ trunk/projects/bos/web/contract-handlers.lisp 2008-07-23 08:24:33 UTC (rev 3568) @@ -34,3 +34,14 @@ (:tr (:td "cert issued?") (:td (:princ-safe (if (contract-cert-issued contract) "yes" "no"))))))) +(defclass cert-issued-handler (object-handler) + () + (:default-initargs :class 'contract)) + +(defmethod handle-object ((handler cert-issued-handler) contract) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () + (:princ (if (and (contract-certificates-generated-p contract) + (not (contract-tree-needs-update-p))) + "READY" + "PROCESSING"))))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-23 07:40:34 UTC (rev 3567) +++ trunk/projects/bos/web/webserver.lisp 2008-07-23 08:24:33 UTC (rev 3568) @@ -226,6 +226,7 @@ ("/allocation-cache" allocation-cache-handler) ("/certificate" certificate-handler) ("/cert-regen" cert-regen-handler) + ("/cert-issued" cert-issued-handler) ("/admin" admin-handler) ("/languages" languages-handler) ("/overview" image-tile-handler)

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3567 Author: hans URL: http://bknr.net/trac/changeset/3567 Warn using FORMAT *TRACE-OUTPUT*, not WARN. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-23 07:10:34 UTC (rev 3566) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-23 07:40:34 UTC (rev 3567) @@ -54,8 +54,8 @@ (when (and (boundp '*store*) *store*) (update-instances-for-changed-class (class-name class)) (unless *suppress-schema-warnings* - (warn "Class ~A has been changed. To ensure correct schema evolution, please snapshot your datastore." - (class-name class))))) + (format *trace-output* "Class ~A has been changed. To ensure correct schema evolution, please snapshot your datastore." + (class-name class))))) (defclass persistent-direct-slot-definition (index-direct-slot-definition) ((transient :initarg :transient :initform nil)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/website/static/javascript.js
by BKNR Commits 23 Jul '08

23 Jul '08

Revision: 3566 Author: hans URL: http://bknr.net/trac/changeset/3566 snapshot t-shirt buy widget U trunk/projects/quickhoney/website/static/javascript.js Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-22 19:26:59 UTC (rev 3565) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-23 07:10:34 UTC (rev 3566) @@ -1260,6 +1260,22 @@ NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))); }, 'buy-t-shirt' : function () { + make_overlay('buy-t-shirt', 'Buy Art on T-Shirt', 426, + FORM({ method: 'POST', action: '#' }, + SPACER("Artwork ", ARTWORK_NAME(current_image.name), " in colored flocked foil ", + "hot pressed on an American Apparel T-Shirt." + NOTICE('These Tees are custom made, so please allow 4-6 days for production in addition to the shipping time')), + SPACER(TABLE(null, + TBODY(null, + TR(null, + TD({ id: 't-shirt-sample' }, INPUT({ type: "radio", name: "size", value: "small"})), + TD(null, + "Small 20cm x 30cm (7.8'' x 11.8'')", BR(), + PRICE('150 €'), NOTICE(' (inside EU, incl. tax)*'), BR(), + PRICE('128.32 €'), NOTICE(' (outside EU, tax free)*'), BR())),)), + BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), + BR(), BR(), + NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))) } };

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3565 Author: hans URL: http://bknr.net/trac/changeset/3565 Don't use ICONV to convert UTF-8 string to ISO-8859-1 before using cl-qprint to encode the string. This should work fine as long as the string only contains characters from ISO-8859-1. U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/mail-generator.lisp Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-22 18:49:39 UTC (rev 3564) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-22 19:26:59 UTC (rev 3565) @@ -2,7 +2,7 @@ (asdf:defsystem :bos.m2 :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime - :iconv :kmrcl :iterate :arnesi + :kmrcl :iterate :arnesi :cl-pdf :screamer :cl-fad) :components ((:file "packages") (:file "geo-utm" :depends-on ("packages")) Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2008-07-22 18:49:39 UTC (rev 3564) +++ trunk/projects/bos/m2/mail-generator.lisp 2008-07-22 19:26:59 UTC (rev 3565) @@ -81,8 +81,7 @@ (if (listp thing) thing (list thing))) (vcard-field (field-spec &rest values) (let* ((values (mapcar (lambda (value) (or value "")) (ensure-list values))) - (encoded-values (mapcar (lambda (string) (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" (or string "")) - :encode-newlines t)) values))) + (encoded-values (mapcar (lambda (string) (cl-qprint:encode (or string "") :encode-newlines t)) values))) (format s "~{~A~^;~}:~{~@[~A~]~^;~}~%" (append (ensure-list field-spec) (unless (equal values encoded-values)

1 0

[bknr-cvs] hans changed trunk/thirdparty/drakma/request.lisp
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3564 Author: hans URL: http://bknr.net/trac/changeset/3564 When the caller wants text, always return a string. U trunk/thirdparty/drakma/request.lisp Modified: trunk/thirdparty/drakma/request.lisp =================================================================== --- trunk/thirdparty/drakma/request.lisp 2008-07-22 17:03:24 UTC (rev 3563) +++ trunk/thirdparty/drakma/request.lisp 2008-07-22 18:49:39 UTC (rev 3564) @@ -146,7 +146,7 @@ #+:clisp (setf (flexi-stream-element-type stream) element-type) (multiple-value-prog1 - (values (cond ((eql content-length 0) nil) + (values (cond ((eql content-length 0) (if textp "" nil)) (content-length (when chunkedp ;; see RFC 2616, section 4.4

1 0

[bknr-cvs] hans changed trunk/projects/bos/payment-website/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3563 Author: hans URL: http://bknr.net/trac/changeset/3563 Formulardaten nur ein mal abschicken. U trunk/projects/bos/payment-website/static/bos.js U trunk/projects/bos/payment-website/templates/da/ueberweisung.xml U trunk/projects/bos/payment-website/templates/de/ueberweisung.xml Modified: trunk/projects/bos/payment-website/static/bos.js =================================================================== --- trunk/projects/bos/payment-website/static/bos.js 2008-07-22 16:37:55 UTC (rev 3562) +++ trunk/projects/bos/payment-website/static/bos.js 2008-07-22 17:03:24 UTC (rev 3563) @@ -96,6 +96,8 @@ alert("Den Geschenkservice können wir nur bei Online-Überweisungen anbieten"); return false; } + + return true; } function check_online() { @@ -224,3 +226,38 @@ if (s!=''){alert('Die benötigten Informationen sind unvollständig oder fehlerhaft:\t\t\t\t\t\n\n'+s)} document.MM_returnValue = (s==''); } + +function check_ueberweisung_da() +{ + YY_checkform('mailtransfer', + 'vorname','#q','0','Anuller venligst dette felt \'Fornavn\'.', + 'name','#q','0','Anuller venligst dette felt \'Efternavn\'.', + 'strasse','#q','0','Anuller venligst dette felt \'Gade/Nr.\'.', + 'plz','#q','0','Anuller venligst dette felt \'Postnummer\'.', + 'ort','#q','0','Anuller venligst dette felt \'Kommune\'.'); + document.getElementById('submit_button').disabled = true; + if (document.MM_returnValue) { + document.getElementById('submit_button').disabled = true; + document.getElementById('submit_button').value = "Data is being transmitted..."; + return true; + } else { + return false; + } +} + +function check_ueberweisung_de() +{ + YY_checkform('mailtransfer', + 'vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.', + 'name','#q','0','Bitte das Feld \'Name\' ausfuellen.', + 'strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.', + 'plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.', + 'ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.'); + if (document.MM_returnValue) { + document.getElementById('submit_button').disabled = true; + document.getElementById('submit_button').value = "Daten werden verschickt..."; + return true; + } else { + return false; + } +} \ No newline at end of file Modified: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2008-07-22 16:37:55 UTC (rev 3562) +++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2008-07-22 17:03:24 UTC (rev 3563) @@ -40,7 +40,7 @@ enctype="application/x-www-form-urlencoded" name="mailtransfer" id="mailtransfer" - onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Anuller venligst dette felt \'Fornavn\'.','name','#q','0','Anuller venligst dette felt \'Efternavn\'.','strasse','#q','0','Anuller venligst dette felt \'Gade/Nr.\'.','plz','#q','0','Anuller venligst dette felt \'Postnummer\'.','ort','#q','0','Anuller venligst dette felt \'Kommune\'.');return document.MM_returnValue"> + onsubmit="check_ueberweisung_da()"> <input type="hidden" name="country" value="DK" /> <input type="hidden" name="contract-id" value="$(contract-id)" /> <input type="hidden" name="sponsor-id" value="$(sponsor-id)" /> @@ -112,7 +112,7 @@ </tr> <tr> <td align="right" colspan="3"> - <input type="submit" class="form_big" name="action" value="Oplysninger til BOS" /> + <input type="submit" class="form_big" id="submit_button" name="action" value="Oplysninger til BOS" /> </td> </tr> </table> Modified: trunk/projects/bos/payment-website/templates/de/ueberweisung.xml =================================================================== --- trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2008-07-22 16:37:55 UTC (rev 3562) +++ trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2008-07-22 17:03:24 UTC (rev 3563) @@ -40,7 +40,7 @@ enctype="application/x-www-form-urlencoded" name="mailtransfer" id="mailtransfer" - onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue"> + onsubmit="return check_ueberweisung_de()"> <input type="hidden" name="contract-id" value="$(contract-id)" /> <input type="hidden" name="sponsor-id" value="$(sponsor-id)" /> <input type="hidden" name="amount" value="$(amount)" /> @@ -117,7 +117,7 @@ </tr> <tr> <td align="right" colspan="3"> - <input type="submit" class="form_big" name="action" value="Angaben an BOS mailen" /> + <input type="submit" id="submit_button" class="form_big" name="action" value="Angaben an BOS mailen" /> </td> </tr> </table>

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3562 Author: ksprotte URL: http://bknr.net/trac/changeset/3562 added kml-upload facility - no handler yetz U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 16:37:36 UTC (rev 3561) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 16:37:55 UTC (rev 3562) @@ -1,6 +1,64 @@ ;;; -*- coding: utf-8 -*- (in-package :bos.web) +(defpersistent-class kml-root-data () + ((language :initarg :language :reader language :type string + :index-type string-unique-index + :index-reader kml-root-data-with-language) + (kml-string :accessor kml-string))) + +(defun ensure-kml-root-data-for-language (language) + (or (kml-root-data-with-language language) + (make-object 'kml-root-data :language language))) + +(defun kml-root-data-validate-file-upload (file-upload) + (cxml:parse-file (upload-pathname file-upload) + (cxml-dom:make-dom-builder))) + +(defclass kml-upload-handler (admin-only-handler form-handler) + ()) + +(defmethod handle-form ((handler kml-upload-handler) action) + (dolist (language (class-instances 'website-language)) + (ensure-kml-root-data-for-language (website-language-code language))) + (labels ((xml-parse-error-context (xml-parse-error) + (ppcre:register-groups-bind (line column) + ("Line +(\\d+).*column +(\\d+)" + (princ-to-string xml-parse-error)) + (when (and line column) + (values (parse-integer line) (parse-integer column)))))) + (with-bos-cms-page (:title "KML Upload") + (html ((:form + :method "POST" :enctype "multipart/form-data") + (dolist (kml-root-data (class-instances 'kml-root-data)) + (let ((language (language kml-root-data))) + (html (:h2 (:princ language)) + (:p ((:input :type "file" :name language)) + " " + (let ((file-upload (request-uploaded-file language))) + (when file-upload + (handler-case + (progn + (kml-root-data-validate-file-upload file-upload) + (with-transaction ("update kml-string") + (setf (kml-string kml-root-data) + (arnesi:read-string-from-file (upload-pathname file-upload) + :external-format :utf-8))) + (html (:princ "updated successfully"))) + (cxml:xml-parse-error (c) + (multiple-value-bind (line column) + (xml-parse-error-context c) + (print (list line column)) + (html ((:span :class "error") + (:format "there was a xml parse error ~:[~;near line ~D, column ~D~]" + (and line column) + line column))))))))) + ;; we want this after the processing + (:p (:format "last-change: ~A" + (format-date-time (store-object-last-change kml-root-data 0))))))) + (submit-button "upload" "upload")))))) + +;;; kml-format utils (defun kml-format-points (points stream) (mapc #'(lambda (point) (kml-format-point point stream)) points)) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-22 16:37:36 UTC (rev 3561) +++ trunk/projects/bos/web/webserver.lisp 2008-07-22 16:37:55 UTC (rev 3562) @@ -199,6 +199,7 @@ :handler-definitions `(("/edit-poi" edit-poi-handler) ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) + ("/kml-upload" kml-upload-handler) ("/kml-root" kml-root-handler) ("/country-stats" country-stats-handler) ("/contract-tree-kml" contract-tree-kml-handler) @@ -255,7 +256,8 @@ :admin-navigation '(("user" . "user/") ("languages" . "languages") ("allocation area" . "allocation-area/") - ("allocation cache" . "allocation-cache")) + ("allocation cache" . "allocation-cache") + ("kml-upload" . "kml-upload")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css")

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 22 Jul '08

22 Jul '08

Revision: 3561 Author: hans URL: http://bknr.net/trac/changeset/3561 Improve redirection mechanism so that robots will see a real page under / and browser users will be properly redirected. U trunk/bknr/web/src/web/template-handler.lisp U trunk/projects/bos/payment-website/templates/de/toplevel_main.xml U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-07-22 16:07:52 UTC (rev 3560) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-07-22 16:37:36 UTC (rev 3561) @@ -306,7 +306,7 @@ (defmethod handler-matches-p ((handler template-handler)) (handler-case - (find-template-pathname handler (script-name*)) + (find-template-pathname handler (subseq (script-name*) 1)) (template-not-found (c) (declare (ignore c)) nil))) Modified: trunk/projects/bos/payment-website/templates/de/toplevel_main.xml =================================================================== --- trunk/projects/bos/payment-website/templates/de/toplevel_main.xml 2008-07-22 16:07:52 UTC (rev 3560) +++ trunk/projects/bos/payment-website/templates/de/toplevel_main.xml 2008-07-22 16:37:36 UTC (rev 3561) @@ -11,10 +11,9 @@ <link rel="stylesheet" href="/static/content_style.css" /> <link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/news" /> - <script src="/static/bos.js" type="text/javascript"> - </script> -  + <script src="/static/bos.js" type="text/javascript"> </script> <link rel="shortcut icon" type="image/x-icon" href="/favicon.ico" /> + <bos:maybe-redirect/> <title>$(title)</title> </head> <body bos:lang="$(language)"> Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-07-22 16:07:52 UTC (rev 3560) +++ trunk/projects/bos/web/tags.lisp 2008-07-22 16:37:36 UTC (rev 3561) @@ -194,4 +194,8 @@ (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))) (define-bknr-tag set-cachable () - (setf (hunchentoot:header-out :cache-control) "max-age=300")) \ No newline at end of file + (setf (hunchentoot:header-out :cache-control) "max-age=300")) + +(define-bknr-tag maybe-redirect () + (when (equal (hunchentoot:script-name*) "/") + (html (:head ((:meta :http-equiv "refresh" :content "0; url=/index")))))) \ No newline at end of file Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-22 16:07:52 UTC (rev 3560) +++ trunk/projects/bos/web/webserver.lisp 2008-07-22 16:37:36 UTC (rev 3561) @@ -23,35 +23,34 @@ ;; and change the template name according to the outcome. (defmethod find-template-pathname ((handler worldpay-template-handler) template-name) - (cond - ((scan #?r"(^|.*/)handle-sale" template-name) - (with-query-params (cartId name address country transStatus lang MC_gift) - (unless (website-supports-language lang) - (setf lang *default-language*)) - (bos.m2::remember-worldpay-params cartId (all-request-params)) - (let ((contract (get-contract (parse-integer cartId)))) - (sponsor-set-language (contract-sponsor contract) lang) - (cond - ((not (typep contract 'contract)) - (user-error "Error: Invalid transaction ID.")) - ((contract-paidp contract) - (user-error "Error: Transaction already processed.")) - ((equal "C" transStatus) - (setf template-name #?"/$(lang)/sponsor_canceled")) - ((< (contract-price contract) *mail-certificate-threshold*) - (setf template-name #?"/$(lang)/quittung")) - (t - (when (<= *mail-fiscal-certificate-threshold* (contract-price contract)) - (mail-fiscal-certificate-to-office contract name address country)) - (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) - ((and (not (scan "/" template-name)) - (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") - (bknr.web::template-expander-destination handler))))) - (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language) - *default-language*) - (if (equal "" template-name) - "index" template-name))))) - (call-next-method handler template-name)) + (call-next-method handler + (cond + ((scan #?r"(^|.*/)handle-sale" template-name) + (with-query-params (cartId name address country transStatus lang MC_gift) + (unless (website-supports-language lang) + (setf lang *default-language*)) + (bos.m2::remember-worldpay-params cartId (all-request-params)) + (let ((contract (get-contract (parse-integer cartId)))) + (sponsor-set-language (contract-sponsor contract) lang) + (cond + ((not (typep contract 'contract)) + (user-error "Error: Invalid transaction ID.")) + ((contract-paidp contract) + (user-error "Error: Transaction already processed.")) + ((equal "C" transStatus) + #?"/$(lang)/sponsor_canceled") + ((< (contract-price contract) *mail-certificate-threshold*) + #?"/$(lang)/quittung") + (t + (when (<= *mail-fiscal-certificate-threshold* (contract-price contract)) + (mail-fiscal-certificate-to-office contract name address country)) + (if (and MC_gift (equal MC_gift "1")) + #?"/$(lang)/versand_geschenk" + #?"/$(lang)/versand_info")))))) + ((equal "" template-name) + "de/index") + (t + template-name)))) (defmethod initial-template-environment ((expander worldpay-template-handler)) (append (list (cons :website-url *website-url*) @@ -240,8 +239,6 @@ file-handler :destination ,(merge-pathnames #p"static/favicon.ico" website-directory) :content-type "image/x-icon") - ("/" redirect-handler - :to "/index") ("/index" index-handler) user images

1 0