[bknr-cvs] r2028 - in branches/xml-class-rework/projects/bos: . m2 web worldpay-test
bknr at bknr.net
bknr at bknr.net
Sun Oct 22 16:50:56 UTC 2006
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))))
More information about the Bknr-cvs
mailing list