Author: hhubner Date: 2006-10-22 12:50:56 -0400 (Sun, 22 Oct 2006) New Revision: 2028
Modified: branches/xml-class-rework/projects/bos/build.lisp branches/xml-class-rework/projects/bos/m2/bos.m2.asd branches/xml-class-rework/projects/bos/m2/config.lisp branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/m2/mail-generator.lisp branches/xml-class-rework/projects/bos/web/web.lisp branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp Log: web server restartable in debug mode vcard generation
Modified: branches/xml-class-rework/projects/bos/build.lisp =================================================================== --- branches/xml-class-rework/projects/bos/build.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/build.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -28,7 +28,7 @@
(defun start-webserver () (apply #'bos.m2::reinit (read-configuration "m2.rc")) - (apply #'bos.web::reinit (read-configuration "web.rc")) + (apply #'bos.web::init (read-configuration "web.rc")) (bknr.cron::start-cron))
(defun start-slime ()
Modified: branches/xml-class-rework/projects/bos/m2/bos.m2.asd =================================================================== --- branches/xml-class-rework/projects/bos/m2/bos.m2.asd 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/m2/bos.m2.asd 2006-10-22 16:50:56 UTC (rev 2028) @@ -1,7 +1,7 @@ (in-package :cl-user)
(asdf:defsystem :bos.m2 - :depends-on (:bknr :bknr-modules :net.post-office) + :depends-on (:bknr :bknr-modules :net.post-office :cl-mime) :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("config"))
Modified: branches/xml-class-rework/projects/bos/m2/config.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/config.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/m2/config.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -66,4 +66,6 @@
;; Vertraege (defparameter *manual-contract-expiry-time* (* 42 24 3600)) -(defparameter *online-contract-expiry-time* (* 3600)) \ No newline at end of file +(defparameter *online-contract-expiry-time* (* 3600)) + +(defvar *website-url* "http://change-me") \ No newline at end of file
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -363,9 +363,10 @@ #-(or allegro cmu) ...))
-(defun reinit (&key delete directory) +(defun reinit (&key delete directory website-url) (format t "~&; Startup Quadratmeterdatenbank...~%") (force-output) + (setf *website-url* website-url) (unless directory (error ":DIRECTORY parameter not set in m2.rc")) (when delete
Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -118,38 +118,37 @@ contract-id))))
(defun worldpay-callback-request-to-vcard (request) - (handler-case - (with-query-params (request cartId - transId - MC_sponsorid - MC_donationcert-yearly - MC_gift - name - address - postcode - countryString - email - tel) - (with-output-to-string (s) - (format s "BEGIN:VCARD~%") - (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t)) - (format s "VERSION:2.1~%") - (format s "FN:~A~%" name) - (format s "ADR;DOM;HOME;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%" (regex-replace-all #?r"\r?\n" address "=0D=0A") postcode countryString) - (when tel - (format s "TEL;WORK;HOME:~A~%" tel)) - (format s "EMAIL;PREF;INTERNET:~A~%" email) - (format s "URL;WORK:~A/edit-sponsor/~A~%" worldpay-test::*website-url* MC_sponsorid) - (format s "NOTE:Contract ID: ~A Sponsor ID: ~A WorldPay Transaction ID: ~A Donationcert yearly: ~A Gift: ~A~%" - cartId - MC_sponsorid - transId - (if MC_donationcert-yearly "Yes" "No") - (if MC_gift "Yes" "No")) - (format s "END:VCARD~%"))) - (error (e) - (warn "vcard could not be generated: ~A~%" e) - ""))) + (with-query-params (request cartId + transId + MC_sponsorid + MC_donationcert-yearly + MC_gift + name + address + postcode + country + email + tel) + (with-output-to-string (s) + (format s "BEGIN:VCARD~%") + (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t)) + (format s "VERSION:2.1~%") + (format s "FN;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A~%" (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" name))) + (format s "ADR;DOM;HOME;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%" + (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" address) :encode-newlines t) postcode country) + (when tel + (format s "TEL;WORK;HOME:~A~%" tel)) + (format s "EMAIL;PREF;INTERNET:~A~%" email) + (format s "URL;WORK:~A/edit-sponsor/~A~%" *website-url* MC_sponsorid) + (format s "NOTE;ENCODING=QUOTED-PRINTABLE:~A~%" + (cl-qprint:encode (format nil "Contract ID: ~A~%Sponsor ID: ~A~%WorldPay Transaction ID: ~A~%Donationcert yearly: ~A~%Gift: ~A~%" + cartId + MC_sponsorid + transId + (if MC_donationcert-yearly "Yes" "No") + (if MC_gift "Yes" "No")) + :encode-newlines t)) + (format s "END:VCARD~%"))))
(defun mail-request-parameters (req subject) (let ((mime (make-instance 'cl-mime:multipart-mime @@ -157,6 +156,8 @@ :content (list (make-instance 'cl-mime:text-mime :type "text" :subtype "html" + :charset "utf-8" + :encoding :quoted-printable :content (format nil " <table border="1"> <tr> @@ -170,8 +171,22 @@ (all-request-params req))))) (make-instance 'cl-mime:text-mime :type "text" + :subtype "xml; name="sponsor.xml"" + :charset "utf-8" + :encoding :quoted-printable + :content (format nil " +<sponsor> + ~{<~A>~A</~A>~} +</sponsor> +" + (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons) (car cons))) + (all-request-params req))))) + (make-instance 'cl-mime:text-mime + :type "text" :subtype "x-vcard; name="sponsor.vcf"" + :charset "utf-8" :content (worldpay-callback-request-to-vcard req)))))) + (format t "made mame~%") (send-system-mail :subject subject :content-type "multipart/mixed" :more-headers t
Modified: branches/xml-class-rework/projects/bos/web/web.lisp =================================================================== --- branches/xml-class-rework/projects/bos/web/web.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/web/web.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -9,18 +9,33 @@
(defvar *webserver* nil)
-(defun reinit (&key (port 8080) (listeners 1) (vhosts '("localhost")) website-directory website-url) +(defvar *port*) +(defvar *listeners*) +(defvar *vhosts*) +(defvar *website-directory*) +(defvar *website-url*) + +(defun init (&key (port 8080) (listeners 1) (vhosts '("localhost")) website-directory website-url) + (setf *port* port) + (setf *listeners* listeners) + (setf *vhosts* vhosts) + (setf *website-url* website-url) + (setf *website-directory* website-directory) + (unless *website-directory* + (error ":website-directory not specified")) + (reinit)) + +(defun reinit (&key debug) (format t "~&; Publishing BOS handlers.~%") - (cond - (website-directory) - ((probe-file *default-wd*) - (setf website-directory *default-wd*)) - (t - (error ":website-directory not specified"))) (unpublish :all t) - (worldpay-test::publish-worldpay-test :website-directory website-directory - :vhosts vhosts - :website-url website-url) - (format t "~&; Starting aserve.~%") + (worldpay-test::publish-worldpay-test :website-directory *website-directory* + :vhosts *vhosts* + :website-url *website-url*) + (format t "~&; Starting aserve~@[ in debug mode~].~%" debug) (force-output) - (setq *webserver* (net.aserve:start :port port :listeners listeners))) + (setq *webserver* + (if debug + (progn (net.aserve::debug-on :notrap) + (net.aserve:start :port *port* :listeners 0)) + (progn (net.aserve::debug-off :all) + (net.aserve:start :port *port* :listeners *listeners*)))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-22 16:45:33 UTC (rev 2027) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-22 16:50:56 UTC (rev 2028) @@ -24,7 +24,7 @@
(defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request) (when (scan #?r"(^|.*/)handle-sale" template-name) - (with-query-params (request cartId email name address country transStatus lang MC_gift MC_donationcert-yearly testMode) + (with-query-params (request cartId email name address country transStatus lang MC_gift MC_donationcert-yearly testMode) (unless (website-supports-language lang) (setf lang *default-language*)) (let ((contract (get-contract (parse-integer cartId))))