Author: hhubner Date: 2006-03-12 13:23:55 -0500 (Sun, 12 Mar 2006) New Revision: 1921
Added: branches/xml-class-rework/projects/bos/Back Office Interface.doc branches/xml-class-rework/projects/bos/payment-website/templates/login.xml Modified: branches/xml-class-rework/projects/bos/ branches/xml-class-rework/projects/bos/m2/allocation.lisp branches/xml-class-rework/projects/bos/m2/m2.lisp branches/xml-class-rework/projects/bos/m2/make-certificate.lisp branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp branches/xml-class-rework/projects/bos/worldpay-test/cms-links.lisp branches/xml-class-rework/projects/bos/worldpay-test/news-handlers.lisp branches/xml-class-rework/projects/bos/worldpay-test/poi-handlers.lisp branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp branches/xml-class-rework/projects/bos/worldpay-test/web-utils.lisp branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp Log: Various changes for the multi-lingual version.
Property changes on: branches/xml-class-rework/projects/bos ___________________________________________________________________ Name: svn:ignore + datastore web.rc m2.rc
Added: branches/xml-class-rework/projects/bos/Back Office Interface.doc =================================================================== (Binary files differ)
Property changes on: branches/xml-class-rework/projects/bos/Back Office Interface.doc ___________________________________________________________________ Name: svn:executable + * Name: svn:mime-type + application/octet-stream
Modified: branches/xml-class-rework/projects/bos/m2/allocation.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/allocation.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/m2/allocation.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -473,7 +473,6 @@ (right (+ left width)) (bottom (+ top height)) (vertices (allocation-area-vertices (stripe-area stripe)))) - (format t "right ~A bottom ~A~%" right bottom) (when (stripe-full-p stripe) ;; Gleich NIL liefern, und den Stripe beseitigen, damit wir ihn nicht ;; wieder antreffen in Zukunft.
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -179,10 +179,12 @@ (paidp :update) (m2s :read) (color :read) + (download-only :read) (cert-issued :read) (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil)) (:default-initargs :m2s nil + :download-only nil :color (random-elt *claim-colors*) :cert-issued nil :expires (+ (get-universal-time) *manual-contract-expiry-time*))) @@ -227,12 +229,13 @@ (* (length (contract-m2s contract)) +price-per-m2+))
(defmethod contract-download-only-p ((contract contract)) - (< (contract-price contract) *mail-amount*)) + (or (contract-download-only contract) + (< (contract-price contract) *mail-amount*)))
-(defmethod contract-fdf-pathname ((contract contract)) +(defmethod contract-fdf-pathname ((contract contract) language) (merge-pathnames (make-pathname :name (format nil "~D-~(~A~)" (store-object-id contract) - (or (sponsor-country (contract-sponsor contract)) "en")) + language) :type "fdf") (if (contract-download-only-p contract) *cert-download-directory* *cert-mail-directory*)))
@@ -246,11 +249,11 @@ (defmethod contract-pdf-url ((contract contract)) (format nil "/~:[~;print-~]certificate/~A" (not (contract-download-only-p contract)) (store-object-id contract)))
-(defmethod contract-issue-cert ((contract contract) name &optional address) +(defmethod contract-issue-cert ((contract contract) name &key address language) (if (contract-cert-issued contract) (warn "can't re-issue cert for ~A" contract) (progn - (make-certificate contract name :address address) + (make-certificate contract name :address address :language language) (unless (contract-download-only-p contract) (mail-certificate-to-office contract address)) (change-slot-values contract 'cert-issued t))))
Modified: branches/xml-class-rework/projects/bos/m2/make-certificate.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/make-certificate.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/m2/make-certificate.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -27,13 +27,13 @@ ;; bzw. im Dateisystem für den Download durch den Spender abgelegt ;; werden.
-(defun make-certificate (contract name &key (address "")) +(defun make-certificate (contract name &key (address "") (language "en")) "Erzeugen einer FDF-Datei für das Ausfüllen der Urkunde. Wenn das optionale address-Argument übergeben wird, wird die Urkunde per Post verschickt und entsprechend eine andere Vorlage ausgewählt als für den Download der Urkunde" (let ((sponsor (contract-sponsor contract))) - (make-fdf-file (contract-fdf-pathname contract) + (make-fdf-file (contract-fdf-pathname contract language) :datum (format-date-time (contract-date contract) :show-time nil) :name name :address address
Added: branches/xml-class-rework/projects/bos/payment-website/templates/login.xml =================================================================== --- branches/xml-class-rework/projects/bos/payment-website/templates/login.xml 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/payment-website/templates/login.xml 2006-03-12 18:23:55 UTC (rev 1921) @@ -0,0 +1,29 @@ +<?xml version="1.0" encoding="UTF-8"?> +<html> + <head> + <title>Please login in to the BOS CMS</title> + </head> + <body> + <h1>Login</h1> + + <p>Please log in to the BOS CMS</p> + + <form method="post"> + <table> + <tr> + <td>Username</td> + <td><input name="__username"/></td> + </tr> + <tr> + <td>Password</td> + <td><input name="__password" type="password"/></td> + </tr> + <tr> + <td colspan="2"> + <input type="submit" name="action" value="login"/> + </td> + </tr> + </table> + </form> + </body> +</html> \ No newline at end of file
Modified: branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/allocation-area-handlers.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -19,13 +19,13 @@ (loop for allocation-area in (all-allocation-areas) do (html (:tr - (:td (cmslink (format nil "/allocation-area/~D" (store-object-id allocation-area)) + (: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))) "%"))))) - (:p (cmslink "/create-allocation-area" "Create new allocation area"))))) + (:p (cmslink "create-allocation-area" "Create new allocation area")))))
(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req) (with-bos-cms-page (req :title "Allocation Area") @@ -197,12 +197,12 @@ (html (:p (:h2 "Polygon already imported") "The polygon " (:princ-safe vertices) " has already been " "imported as " - (cmslink (format nil "/allocation-area/~D" (store-object-id existing-area)) + (cmslink (format nil "allocation-area/~D" (store-object-id existing-area)) "allocation area " (:princ-safe (store-object-id existing-area))))) (let ((allocation-area (make-allocation-area vertices))) (html (:p (:h2 "Successfully imported polygon number " (:princ-safe i)) "The polygon " - (cmslink (format nil "/allocation-area/~D" (store-object-id allocation-area)) + (cmslink (format nil "allocation-area/~D" (store-object-id allocation-area)) (:princ-safe (store-object-id allocation-area))) " has been successfully imported"))))) (error (e)
Modified: branches/xml-class-rework/projects/bos/worldpay-test/cms-links.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/cms-links.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/cms-links.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -5,7 +5,7 @@
(defmethod html-edit-link ((sponsor sponsor)) (html - (cmslink (format nil "/edit-sponsor/~D" (store-object-id sponsor)) + (cmslink (format nil "edit-sponsor/~D" (store-object-id sponsor)) (:princ-safe (format nil "edit sponsor #~D" (store-object-id sponsor))))))
(defmethod html-link ((sponsor sponsor)) @@ -13,7 +13,7 @@
(defmethod html-link ((contract contract)) (html - (cmslink (format nil "/contract/~D" (store-object-id contract)) + (cmslink (format nil "contract/~D" (store-object-id contract)) (:princ-safe (format nil "contract #~D" (store-object-id contract))))))
(defmethod object-url ((poi poi))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/news-handlers.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/news-handlers.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/news-handlers.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -19,7 +19,7 @@ (:ul (dolist (news-item (all-news-items)) (let ((id (store-object-id news-item))) - (html (:li (cmslink #?"/edit-news/$(id)" + (html (:li (cmslink #?"edit-news/$(id)" (:princ-safe (format-date-time (news-item-time news-item))) " - " (:princ-safe (or (news-item-title news-item language) "[no title in this language]")))))))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/poi-handlers.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/poi-handlers.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/poi-handlers.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -93,12 +93,12 @@ (:td (cond ((poi-area poi) (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) - (cmslink (format nil "/map-browser/~A/~A?chosen-url=~A" + (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) "[relocate]")) (t - (cmslink (format nil "/map-browser/?chosen-url=~A" + (cmslink (format nil "map-browser/?chosen-url=~A" (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) "[choose]"))))) (:tr (:td "icon") @@ -127,7 +127,7 @@ (unless (eql 6 (length (poi-images poi))) (html :br - (cmslink (format nil "/edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) + (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) (:tr (:td "airal view") (:td (if (poi-airals poi) (html ((:a :href (format nil "/image/~D" (store-object-id (first (poi-airals poi))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -37,7 +37,7 @@ (when (or count (or (ignore-errors (scan regex (user-full-name sponsor))) (ignore-errors (scan regex (user-email sponsor))))) - (html (:tr (:td (cmslink #?"/edit-sponsor/$((store-object-id sponsor))" (:princ-safe (store-object-id sponsor)))) + (html (:tr (:td (cmslink #?"edit-sponsor/$((store-object-id sponsor))" (:princ-safe (store-object-id sponsor)))) (:td (:princ-safe (format-date-time (contract-date (first (sponsor-contracts sponsor))) :show-time nil))) (:td (:princ-safe (or (user-email sponsor) "<unknown>"))) (:td (:princ-safe (or (user-full-name sponsor) "<unknown>"))))) @@ -63,11 +63,16 @@ (:tr (:td "Date (DD.MM.YYYY)") (:td (text-field "date" :size 10 :value (format-date-time (get-universal-time) :show-time nil)))) (:tr (:td "Number of square meters") - (:td (text-field "numsqm" :size 5)) - (:tr (:td "Country code (2 chars)") - (:td (text-field "country" :size 2 :value "DE")))) + (:td (text-field "numsqm" :size 5))) + (:tr (:td "Country code (2 chars)") + (:td (text-field "country" :size 2 :value "DE"))) (:tr (:td "Email-Address") (:td (text-field "email" :size 40))) + (:tr (:td "Language for certificate") + (:td ((:select :name "language") + (loop + for (language-symbol language-name) in (website-languages) + do (html ((:option :value language-symbol) (:princ-safe language-name))))))) (:tr (:td "Name for certificate") (:td (text-field "name" :size 20))) (:tr (:td "Postal address for certificate" @@ -78,10 +83,10 @@ (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"." date-string))))
(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req) - (with-query-params (req numsqm country email name postaladdress date) + (with-query-params (req numsqm country email name postaladdress date language) (let* ((sponsor (make-sponsor :email email :country country)) (contract (make-contract sponsor (parse-integer numsqm) :paidp t :date (date-to-universal date)))) - (contract-issue-cert contract name postaladdress) + (contract-issue-cert contract name :address postaladdress :language language) (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req))))
(defun contract-checkbox-name (contract) @@ -121,7 +126,7 @@ (:td (:princ-safe (format-date-time (contract-date contract) :show-time nil))) (:td (:princ-safe (length (contract-m2s contract)))) (:td (:princ-safe (if (contract-paidp contract) "paid" "not paid"))) - (:td (cmslink (format nil "/cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") + (:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") (when (probe-file (contract-pdf-pathname contract)) (html :br (cmslink (contract-pdf-url contract) "Show Certificate")))))))) (:p (submit-button "save" "save") @@ -194,11 +199,11 @@ (html (:h2 "Completing square meter sale")) (sponsor-set-country (contract-sponsor contract) country) (contract-set-paidp contract t) - (contract-issue-cert contract name postaladdress) + (contract-issue-cert contract name :address postaladdress) (when email (html (:p "Sending instruction email to " (:princ-safe email))) (mail-instructions-to-sponsor contract email)))) - (:p (cmslink (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))) + (:p (cmslink (format nil "edit-sponsor/~D" (store-object-id (contract-sponsor contract))) "click here") " to edit the sponsor's database entry"))))
(defclass m2-javascript-handler (prefix-handler) @@ -266,25 +271,24 @@ ((:table) (:tr (:td "Name") (:td (text-field "name" :size 40))) - (if (contract-download-only-p contract) - (html - (:tr (:td (submit-button "make-download" "make-download")))) - (html + (:tr (:td "Language") + (:td ((:select :name "language") + (loop + for (language-symbol language-name) in (website-languages) + do (html ((:option :value language-symbol) (:princ-safe language-name))))))) + (unless (contract-download-only-p contract) + (html (:tr (:td "Address") - (:td (textarea-field "address"))) - (:tr (:td (submit-button "make-print" "make-print")))))))))) + (:td (textarea-field "address"))))) + (html + (:tr (:td (submit-button "regenerate" "regenerate")))))))))
(defun confirm-cert-regen (req) (with-bos-cms-page (req :title "Certificate generation request has been created") (html "Your certificate generation request has been created, please wait a few seconds before checking the PDF file")))
-(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :make-print)) (contract contract) req) - (with-query-params (req name address) - (bos.m2::make-certificate contract name :address address)) - (confirm-cert-regen req)) - -(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :make-download)) (contract contract) req) - (with-query-params (req name) - (bos.m2::make-certificate contract name)) +(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req) + (with-query-params (req name address language) + (bos.m2::make-certificate contract name :address address :language language)) (confirm-cert-regen req)) \ No newline at end of file
Modified: branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -38,7 +38,7 @@ (define-bknr-tag generate-cert () (with-template-vars (gift email name address) (let ((contract (find-store-object (parse-integer (get-template-var :contract-id))))) - (contract-issue-cert contract name address) + (contract-issue-cert contract name :address address) (bknr.web::redirect-request :target (if gift "index" (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A" (uriencode-string name) (uriencode-string email)
Modified: branches/xml-class-rework/projects/bos/worldpay-test/web-utils.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/web-utils.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/web-utils.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -16,7 +16,7 @@ (html "logged in as " (html-link (bknr-request-user *req*))) (html "not logged in")) " - current content language is " - (cmslink "/change-language" + (cmslink "change-language" (:princ-safe (current-website-language)) " (" (:princ-safe (language-name (current-website-language)))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp =================================================================== --- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-03-12 18:20:56 UTC (rev 1920) +++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-03-12 18:23:55 UTC (rev 1921) @@ -179,8 +179,6 @@ (when website-url (setf *website-url* website-url))
- (setf bknr.web::*login-default-url* "/admin") - (make-instance 'bos-website :name "BOS Website" :handler-definitions `(("/edit-poi" edit-poi-handler) @@ -217,13 +215,13 @@ :command-packages ((:bos . :worldpay-test) (:bknr . :bknr.web)))) :modules '(user images stats) - :admin-navigation '(("user" . "/user/") - ("sponsor" . "/edit-sponsor/") - ("news" . "/edit-news/") - ("poi" . "/edit-poi/") - ("languages" . "/languages") - ("allocation area" . "/allocation-area/") - ("logout" . "/logout")) + :admin-navigation '(("user" . "user/") + ("sponsor" . "edit-sponsor/") + ("news" . "edit-news/") + ("poi" . "edit-poi/") + ("languages" . "languages") + ("allocation area" . "allocation-area/") + ("logout" . "logout")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css")