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

[bknr-cvs] ksprotte changed trunk/projects/bos/web/kml-handlers.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3620 Author: ksprotte URL: http://bknr.net/trac/changeset/3620 kml-upload-handler allows also for downloading the kml-root file U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 13:51:29 UTC (rev 3619) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 14:43:28 UTC (rev 3620) @@ -55,9 +55,20 @@ line column))))))))) ;; we want this after the processing (:p (:format "last-change: ~A" - (format-date-time (store-object-last-change kml-root-data 0))))))) + (format-date-time (store-object-last-change kml-root-data 0))) + (cmslink (format nil "/kml-upload?lang=~A&action=download" language) + "download current version"))))) (submit-button "upload" "upload")))))) +(defmethod handle-form ((handler kml-upload-handler) (action (eql :download))) + (with-query-params (lang) + (setf (hunchentoot:header-out :content-type) + "application/binary" + (hunchentoot:header-out :content-disposition) + (format nil "attachment; filename=kml-root-~A.kml" lang)) + (let ((kml-root-data (kml-root-data-with-language lang))) + (kml-string kml-root-data)))) + ;;; kml-format utils (defun kml-format-points (points stream) (mapc #'(lambda (point) (kml-format-point point stream)) points))

1 0

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

24 Jul '08

Revision: 3619 Author: hans URL: http://bknr.net/trac/changeset/3619 Send out contract mails asynchronously, from separate thread. U trunk/projects/bos/build.lisp U trunk/projects/bos/m2/mail-generator.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/sponsor-handlers.lisp U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/build.lisp =================================================================== --- trunk/projects/bos/build.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/build.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -71,6 +71,7 @@ (apply #'bos.m2::reinit (read-configuration "m2.rc")) (apply #'bos.web::init (read-configuration "web.rc")) (bos.web::start-contract-tree-image-update-daemon) + (bos.m2::start-postmaster) (bknr.cron::start-cron)) (defun start-cert-daemon () Modified: trunk/projects/bos/m2/mail-generator.lisp =================================================================== --- trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -2,6 +2,43 @@ (enable-interpol-syntax) +(defvar *postmaster-queue-lock* (bt:make-lock "Postmaster Queue Lock")) + +(defvar *postmaster-queue* (make-queue)) + +(defvar *postmaster* nil) + +(defun postmaster-loop () + (loop + (sleep 2) + (loop + (let ((entry (bt:with-lock-held (*postmaster-queue-lock*) + (peek-queue *postmaster-queue*)))) + (when (or (null entry) + (not (contract-certificates-generated-p (second entry)))) + (return))) + (let ((entry (bt:with-lock-held (*postmaster-queue-lock*) + (dequeue *postmaster-queue*)))) + (handler-case + (destructuring-bind (function contract args) entry + (apply function contract args)) + (error (e) + (warn "; could not send mail ~S: ~A" entry e))))))) + +(defun postmaster-running-p () + (and *postmaster* + (bt:thread-alive-p *postmaster*))) + +(defun start-postmaster () + (unless (postmaster-running-p) + (setq *postmaster* + (bt:make-thread #'postmaster-loop + :name "postmaster")))) + +(defun send-to-postmaster (function contract &rest args) + (bt:with-lock-held (*postmaster-queue-lock*) + (enqueue (list function contract args) *postmaster-queue*))) + (defvar *country->office-email* '(("DK" . "bosdanmark.regnskov(a)gmail.com") ("SE" . "bosdanmark.regnskov(a)gmail.com"))) @@ -251,9 +288,9 @@ (ignore-errors (delete-file (contract-pdf-pathname contract :print t)))) -(defun mail-backoffice-sponsor-data (contract) - (with-query-params (numsqm country email name address date language) - (let ((parts (list (make-html-part (format nil " +(defun mail-backoffice-sponsor-data (contract numsqm country email name address language request-params) + (let* ((contract-id (store-object-id contract)) + (parts (list (make-html-part (format nil " <html> <body> <h1>Manually entered sponsor data:</h1> @@ -268,36 +305,35 @@ </table> </body> </html>" - (store-object-id contract) - numsqm - name - address - email - country - language)) - (make-contract-xml-part (store-object-id contract) (all-request-params)) - (make-vcard-part (store-object-id contract) - (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) - :note (format nil "Paid-by: Back office + contract-id + numsqm + name + address + email + country + language)) + (make-contract-xml-part (store-object-id contract) request-params) + (make-vcard-part (store-object-id contract) + (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) + :note (format nil "Paid-by: Back office Contract ID: ~A Sponsor ID: ~A Number of sqms: ~A Amount: EUR~A.00 " - (store-object-id contract) - (store-object-id (contract-sponsor contract)) - numsqm - (* 3 (parse-integer numsqm))) - :name name - :address address - :email email))))) - (mail-contract-data contract "Manually entered sponsor" parts)))) + (store-object-id contract) + (store-object-id (contract-sponsor contract)) + numsqm + (* 3 (parse-integer numsqm))) + :name name + :address address + :email email))))) + (mail-contract-data contract "Manually entered sponsor" parts))) -(defun mail-manual-sponsor-data () - (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) - (let* ((contract (store-object-with-id (parse-integer contract-id))) - (sponsor-id (store-object-id (contract-sponsor contract))) - (parts (list (make-html-part (format nil " +(defun mail-manual-sponsor-data (contract vorname name strasse plz ort email telefon want-print donationcert-yearly request-params) + (let* ((sponsor-id (store-object-id (contract-sponsor contract))) + (contract-id (store-object-id contract)) + (parts (list (make-html-part (format nil " <html> <body> <h1>Sponsor data as entered by the sponsor:</h1> @@ -320,35 +356,35 @@ </body> </html> " - contract-id - (length (contract-m2s contract)) - (* 3.0 (length (contract-m2s contract))) - vorname name strasse plz ort email telefon - (if want-print "yes" "no") - (if donationcert-yearly "yes" "no") - *website-url* contract-id (or email ""))) - (make-contract-xml-part contract-id (all-request-params)) - (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id - :note (format nil "Paid-by: Manual money transfer + (store-object-id contract) + (length (contract-m2s contract)) + (* 3.0 (length (contract-m2s contract))) + vorname name strasse plz ort email telefon + (if want-print "yes" "no") + (if donationcert-yearly "yes" "no") + *website-url* contract-id (or email ""))) + (make-contract-xml-part contract-id request-params) + (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id + :note (format nil "Paid-by: Manual money transfer Contract ID: ~A Sponsor ID: ~A Number of sqms: ~A Amount: EUR~A.00 Donationcert yearly: ~A " - contract-id - sponsor-id - (length (contract-m2s contract)) - (* 3 (length (contract-m2s contract))) - (if donationcert-yearly "Yes" "No")) - :vorname vorname - :nachname name - :strasse strasse - :postcode plz - :ort ort - :email email - :tel telefon))))) - (mail-contract-data contract "Ueberweisungsformular" parts)))) + contract-id + sponsor-id + (length (contract-m2s contract)) + (* 3 (length (contract-m2s contract))) + (if donationcert-yearly "Yes" "No")) + :vorname vorname + :nachname name + :strasse strasse + :postcode plz + :ort ort + :email email + :tel telefon))))) + (mail-contract-data contract "Ueberweisungsformular" parts))) (defvar *worldpay-params-hash* (make-hash-table :test #'equal)) @@ -356,17 +392,16 @@ "Remember the parameters sent in a callback request from Worldpay so that they can be mailed to the BOS office later on" (setf (gethash contract-id *worldpay-params-hash*) params)) -(defun get-worldpay-params (contract-id) +(defun get-worldpay-params (contract) (or (prog1 - (gethash contract-id *worldpay-params-hash*) - (remhash contract-id *worldpay-params-hash*)) - (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) + (gethash contract *worldpay-params-hash*) + (remhash contract *worldpay-params-hash*)) + (error "cannot find WorldPay callback params for contract ~A~%" contract))) -(defun mail-worldpay-sponsor-data () - (with-query-params (contract-id) - (let* ((contract (store-object-with-id (parse-integer contract-id))) - (params (get-worldpay-params contract-id)) - (parts (list (make-html-part (format nil " +(defun mail-worldpay-sponsor-data (contract) + (let* ((contract-id (store-object-id contract)) + (params (get-worldpay-params contract)) + (parts (list (make-html-part (format nil " <table border=\"1\"> <tr> <th>Parameter</th> @@ -375,10 +410,10 @@ ~{<tr><td>~A</td><td>~A</td></tr>~} </table> " - (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) - (sort (copy-list params) - #'string-lessp - :key #'car))))) - (make-contract-xml-part contract-id params) - (make-vcard-part contract-id (worldpay-callback-params-to-vcard params))))) - (mail-contract-data contract "WorldPay" parts)))) + (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons))) + (sort (copy-list params) + #'string-lessp + :key #'car))))) + (make-contract-xml-part contract-id params) + (make-vcard-part contract-id (worldpay-callback-params-to-vcard params))))) + (mail-contract-data contract "WorldPay" parts))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/m2/packages.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -251,6 +251,7 @@ #:news-item-title #:news-item-text + #:send-to-postmaster #:mail-fiscal-certificate-to-office #:mail-instructions-to-sponsor #:mail-info-request Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -114,7 +114,7 @@ (user-login (bknr.web:bknr-session-user))) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) - (mail-backoffice-sponsor-data contract) + (send-to-postmaster #'mail-backoffice-sponsor-data contract numsqm country email name address language (all-request-params)) (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)))))) (defun contract-checkbox-name (contract) Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/tags.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -42,7 +42,7 @@ (when (equal want-print "no") (contract-set-download-only-p contract t)) (contract-issue-cert contract name :address address :language (request-language)) - (mail-worldpay-sponsor-data) + (send-to-postmaster #'mail-worldpay-sponsor-data contract) (bknr.web::redirect-request :target (if gift "index" (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" (encode-urlencoded name) (encode-urlencoded email) @@ -122,7 +122,8 @@ (define-bknr-tag mail-transfer () (with-query-params (country contract-id - name vorname strasse plz ort) + name vorname strasse plz ort telefon want-print + email donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (download-only (< (contract-price contract) *mail-certificate-threshold*))) (with-transaction (:prepare-before-mail) @@ -134,7 +135,9 @@ strasse plz ort) :language (request-language)) - (mail-manual-sponsor-data)))) + (send-to-postmaster #'mail-manual-sponsor-data + contract vorname name strasse plz ort email telefon want-print donationcert-yearly + (all-request-params))))) (define-bknr-tag when-certificate () (let ((sponsor (bknr-session-user))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 13:44:53 UTC (rev 3618) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 13:51:29 UTC (rev 3619) @@ -29,8 +29,8 @@ (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)))) + (bos.m2::remember-worldpay-params contract (all-request-params)) (sponsor-set-language (contract-sponsor contract) lang) (cond ((not (typep contract 'contract))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3618 Author: ksprotte URL: http://bknr.net/trac/changeset/3618 tuned min lod for small-contracts, so that placemarks should be visible again on close-up U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-24 13:12:57 UTC (rev 3617) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-24 13:44:53 UTC (rev 3618) @@ -190,7 +190,7 @@ :key #'contract-area))) (when small-contracts (with-element "Folder" - (kml-region rect `(:min ,(* 6 (getf lod :min)) :max -1)) + (kml-region rect `(:min ,(* 3 (getf lod :min)) :max -1)) (dolist (c small-contracts) (write-contract-placemark-kml c lang)))) (when big-contracts

1 0

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

24 Jul '08

Revision: 3617 Author: ksprotte URL: http://bknr.net/trac/changeset/3617 made search-adjacent more robust for the (pathological) cases of the test-suite U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 12:46:58 UTC (rev 3616) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 13:12:57 UTC (rev 3617) @@ -304,10 +304,12 @@ (setf (gethash m2 allocated) t) (enqueue m2 border-queue)) (try-get (x y) - (let ((m2 (ensure-m2 x y))) - (when (and (not (gethash m2 allocated)) - (funcall pred m2)) - m2))) + (when (and (<= 0 x (1- +width+)) + (<= 0 y (1- +width+))) + (let ((m2 (ensure-m2 x y))) + (when (and (not (gethash m2 allocated)) + (funcall pred m2)) + m2)))) (get-next-neighbor (m2) (let ((x (m2-x m2)) (y (m2-y m2)))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/contract-tree.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3616 Author: ksprotte URL: http://bknr.net/trac/changeset/3616 lets again have only 9 contract-tree layers U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-24 11:42:29 UTC (rev 3615) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-24 12:46:58 UTC (rev 3616) @@ -39,7 +39,7 @@ (defparameter *contract-tree-images-size* 128) ; was 256 (defmethod leaf-node-p ((node contract-node)) - (= 10 (depth node))) + (= 9 (depth node))) (defun contract-geo-box (contract) (destructuring-bind (x y width height)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3615 Author: hans URL: http://bknr.net/trac/changeset/3615 Replace a COND by an UNLESS to save two more lines and improve readability a little bit. U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:37 UTC (rev 3614) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:42:29 UTC (rev 3615) @@ -323,12 +323,10 @@ (if (queue-empty-p border-queue) (return nil) (let ((next (get-next-neighbor (peek-queue border-queue)))) - (cond - (next - (to-border-queue next)) - (t - (push (dequeue border-queue) completely-checked) - (go check-next))))))))))) + (unless next + (push (dequeue border-queue) completely-checked) + (go check-next)) + (to-border-queue next))))))))) (defun allocate-in-area (area n) (let* ((area-left (allocation-area-left area))

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3614 Author: hans URL: http://bknr.net/trac/changeset/3614 LET* -> LET U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:12 UTC (rev 3613) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:39:37 UTC (rev 3614) @@ -296,9 +296,9 @@ returns a true value if the argument specifies an allocatable square meter." (when (funcall pred m2) - (let* ((allocated (make-hash-table :test #'eq)) - (border-queue (make-queue)) - completely-checked) + (let ((allocated (make-hash-table :test #'eq)) + (border-queue (make-queue)) + completely-checked) (labels ((to-border-queue (m2) (setf (gethash m2 allocated) t)

1 0

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

24 Jul '08

Revision: 3613 Author: ksprotte URL: http://bknr.net/trac/changeset/3613 added new handler look-at-allocation-area U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/allocation-area-handlers.lisp =================================================================== --- trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -15,16 +15,19 @@ (:th "active?") (:th "total") (:th "free") - (:th "%used")) + (:th "%used") + (:th "Google Earth view")) (loop for allocation-area in (all-allocation-areas) - do (html - (:tr - (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) - (:princ-safe (store-object-id allocation-area)))) - (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) - (:td (:princ-safe (allocation-area-total-m2s allocation-area))) - (:td (:princ-safe (allocation-area-free-m2s allocation-area))) - (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) + do (html + (:tr + (:td (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) + (:princ-safe (store-object-id allocation-area)))) + (:td (if (allocation-area-active-p allocation-area) (html "yes") (html "no"))) + (:td (:princ-safe (allocation-area-total-m2s allocation-area))) + (:td (:princ-safe (allocation-area-free-m2s allocation-area))) + (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%") + (:td (cmslink (format nil "look-at-allocation-area/~D" (store-object-id allocation-area)) + "fly to view")))))) (:p (cmslink "create-allocation-area" "Create new allocation area"))))) (defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -243,3 +243,15 @@ +(defclass look-at-allocation-area-handler (object-handler) + ()) + +(defmethod handle-object ((handler look-at-allocation-area-handler) + (area allocation-area)) + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" + :root-element "kml") + (with-element "Document" + (with-element "name" (text (format nil "allocation-area ~D" (store-object-id area)))) + (kml-region (make-rectangle2 (allocation-area-bounding-box2 area)) + nil)))) + Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-24 11:37:33 UTC (rev 3612) +++ trunk/projects/bos/web/webserver.lisp 2008-07-24 11:39:12 UTC (rev 3613) @@ -208,6 +208,7 @@ ("/contract" contract-handler) ("/sat-tree-kml" sat-tree-kml-handler) ("/sat-root-kml" sat-root-kml-handler) + ("/look-at-allocation-area" look-at-allocation-area-handler) ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/allocation.lisp
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3612 Author: hans URL: http://bknr.net/trac/changeset/3612 Fix docstring of SEARCH-ADJACENT. U trunk/projects/bos/m2/allocation.lisp Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:11:05 UTC (rev 3611) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-24 11:37:33 UTC (rev 3612) @@ -292,9 +292,9 @@ (defun search-adjacent (n m2 pred) "Try to find N free square meters that are adjacent and that begin -at square meter M2. PRED is a predicate function of two arguments that -returns a true value if the arguments specify the coordinates of an -allocatable square meter." +at square meter M2. PRED is a predicate function of one argument that +returns a true value if the argument specifies an allocatable square +meter." (when (funcall pred m2) (let* ((allocated (make-hash-table :test #'eq)) (border-queue (make-queue))

1 0

[bknr-cvs] ksprotte changed trunk/thirdparty/cl-unicode/
by BKNR Commits 24 Jul '08

24 Jul '08

Revision: 3611 Author: ksprotte URL: http://bknr.net/trac/changeset/3611 set property ignore for files auto-generated by the BUILD-CL-UNICODE system _U trunk/thirdparty/cl-unicode/ _U trunk/thirdparty/cl-unicode/test/ Property changes on: trunk/thirdparty/cl-unicode ___________________________________________________________________ Name: svn:ignore + hash-tables.lisp lists.lisp methods.lisp Property changes on: trunk/thirdparty/cl-unicode/test ___________________________________________________________________ Name: svn:ignore + derived-properties

1 0