[bknr-cvs] r1921 - in branches/xml-class-rework/projects/bos: . m2 payment-website/templates worldpay-test
bknr at bknr.net
bknr at bknr.net
Sun Mar 12 18:23:55 UTC 2006
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")
More information about the Bknr-cvs
mailing list