September 2007 - bknr-cvs@common-lisp.net

[bknr-cvs] r2175 - in branches/bos: bknr/src bknr/src/data bknr/src/sysclasses bknr/src/web projects/bos/m2 projects/bos/payment-website/templates/da projects/bos/payment-website/templates/de projects/bos/payment-website/templates/en projects/bos/worldpay-test thirdparty/iconv
by bknr＠bknr.net 28 Sep '07

28 Sep '07

Author: hhubner Date: 2007-09-28 13:16:21 -0400 (Fri, 28 Sep 2007) New Revision: 2175 Added: branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml Modified: branches/bos/bknr/src/data/object.lisp branches/bos/bknr/src/data/package.lisp branches/bos/bknr/src/packages.lisp branches/bos/bknr/src/sysclasses/user.lisp branches/bos/bknr/src/web/user-handlers.lisp branches/bos/bknr/src/web/user-tags.lisp branches/bos/bknr/src/web/web-visitor.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp branches/bos/projects/bos/worldpay-test/boi-handlers.lisp branches/bos/projects/bos/worldpay-test/contract-handlers.lisp branches/bos/projects/bos/worldpay-test/news-handlers.lisp branches/bos/projects/bos/worldpay-test/poi-handlers.lisp branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp branches/bos/projects/bos/worldpay-test/tags.lisp branches/bos/projects/bos/worldpay-test/worldpay-test.lisp branches/bos/thirdparty/iconv/iconv.lisp Log: Add better error message when the requested number of square meters cannot be allocated. Add :EDITOR user flag to control access to content editing functions. :ADMIN is now required to add or delete users, languages and allocation areas. The other CMS functions may be accessed by users having the :EDITOR flag. Change user flag handling so that an explicit list of legal flags is maintained within the source code, as opposed to generating the list on the fly from those flags that have been created using the user editor. Display all system users in the user maintenance CMS form, together with the most important attributes. Enhance user deletion: Implement confirmation dialog, cascading delete any existing event log entries that referenced the deleted users. The cascaded deletion is implemented by a general mechanism and an addition to the store API, CASCADING-DELETE-OBJECT. This function does a full traversal of the datastore to find any references to the object that is being deleted. For each object found, the generic function CASCADE-DELETE-P is called to determine whether the referencing object can be deleted, too. If any objects are found for that CASCADE-DELETE-P returns NIL, an error is generated. Modified: branches/bos/bknr/src/data/object.lisp =================================================================== --- branches/bos/bknr/src/data/object.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/data/object.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -607,6 +607,27 @@ :timestamp (get-universal-time) :args (mapcar #'store-object-id objects))))) +(defgeneric cascade-delete-p (object referencing-object) + (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted")) + +(defmethod cascade-delete-p (object referencing-object) + nil) + +(defun cascading-delete-object (object) + "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by +the result of calling CASCADE-DELETE-P. Generate error if there are references to the objects that are not eligible +to cascading deletes." + (let (cascading-delete-refs + remaining-refs) + (dolist (referencing-object (find-refs object)) + (if (cascade-delete-p object referencing-object) + (push referencing-object cascading-delete-refs) + (push referencing-object remaining-refs))) + (when remaining-refs + (error "Cannot delete object ~A because there are references to this object in the system, please consult a system administrator!" + object)) + (apply #'delete-objects object cascading-delete-refs))) + (deftransaction change-slot-values (object &rest slots-and-values) (when object (loop for (slot value) on slots-and-values by #'cddr @@ -655,4 +676,17 @@ (deftransaction store-object-set-keywords (object slot keywords) (setf (slot-value object slot) keywords)) +(defmethod find-refs ((object store-object)) + "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots." + (remove-if-not + (lambda (candidate) + (find-if (lambda (slotd) + (and (slot-boundp candidate (slot-definition-name slotd)) + (let ((slot-value (slot-value candidate (slot-definition-name slotd)))) + (or (eq object slot-value) + (and (listp slot-value) + (find object slot-value)))))) + (class-slots (class-of candidate)))) + (class-instances 'store-object))) + (pushnew :mop-store cl:*features*) Modified: branches/bos/bknr/src/data/package.lisp =================================================================== --- branches/bos/bknr/src/data/package.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/data/package.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -52,6 +52,8 @@ #:delete-object #:delete-objects + #:cascade-delete-p + #:cascading-delete-object #:initialize-persistent-instance #:initialize-transient-instance @@ -108,4 +110,6 @@ #:store-blob-root-tempdir #:store-object-subsystem - #:blob-subsystem)) + #:blob-subsystem + + #:find-refs)) Modified: branches/bos/bknr/src/packages.lisp =================================================================== --- branches/bos/bknr/src/packages.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/packages.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -130,6 +130,7 @@ #:user-flags #:user-preferences #:user-subscriptions + #:user-editable-p ;; Export slot names so that derived classes can overload ;; slots (e.g. to add XML impex attributes) @@ -152,6 +153,7 @@ #:user-add-flags #:user-remove-flags #:all-user-flags + #:define-user-flag #:user-reachable-by-mail-p #:user-mail-error-p @@ -163,6 +165,7 @@ #:all-users #:get-flag-users #:make-user + #:delete-user #:set-user-password #:set-user-last-login Modified: branches/bos/bknr/src/sysclasses/user.lisp =================================================================== --- branches/bos/bknr/src/sysclasses/user.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/sysclasses/user.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -13,8 +13,7 @@ :index-values all-users) (flags :update :initform nil :index-type hash-list-index - :index-reader get-flag-users - :index-keys all-user-flags) + :index-reader get-flag-users) (email :update :initform "" :documentation "Email Address, must be unique") @@ -30,6 +29,15 @@ (defconstant +salt-length+ 8) +(defgeneric user-editable-p (user) + (:documentation "Return non-nil if the given user can be edited through the administration interface. The USER class +is frequently subclassed to implement special user accounts that are self-registered and that cannot be edited through +the standard user administration interface. It would be better if the ``real'' system users would live in a seperate base +class that would be editable and have the USER class be non-editable.")) + +(defmethod user-editable-p ((user user)) + t) + (defun make-salt () (coerce (loop for i from 1 upto +salt-length+ @@ -91,6 +99,14 @@ (defmethod user-has-flag ((user user) flag) (find flag (user-flags user))) +(defvar *user-flags* '(:admin)) + +(defun define-user-flag (keyword) + (pushnew keyword *user-flags*)) + +(defun all-user-flags () + (copy-list *user-flags*)) + (defmethod verify-password ((user user) password) (when password (let ((upw (user-password user))) @@ -149,6 +165,14 @@ (set-user-password user password)) user)) +(defmethod cascade-delete-p ((user user) (event event)) + t) + +(defmethod delete-user ((user user)) + (when (eq user (find-user "anonymous")) + (error "Can't delete system user ``anonymous''")) + (cascading-delete-object user)) + (deftransaction set-user-full-name (user full-name) (setf (user-full-name user) full-name)) Modified: branches/bos/bknr/src/web/user-handlers.lisp =================================================================== --- branches/bos/bknr/src/web/user-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/user-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -59,13 +59,21 @@ (defmethod handle-object-form ((handler user-handler) action (user (eql nil)) req) (with-bknr-page (req :title "Manage users") - #+(or) - (:ul (loop for user in (remove :registered (all-users) :key #'user-flags :test #'member) - do (html (:li ((:a :href (object-url user)) - (:princ-safe (user-login user))))))) - ((:form :method "POST") - (:h2 "Search for user") - "Login: " ((:input :type "text" :name "login" :size "20")) (submit-button "search" "search")) + ((:table :border "1") + (:tr (:th "Login") + (:th "Real name") + (:th "Privileges") + (:th "Last login")) + (dolist (user (sort (remove-if-not #'user-editable-p (all-users)) + #'string-lessp :key #'user-login)) + (html (:tr (:td ((:a :href (object-url user)) + (:princ-safe (user-login user)))) + (:td (:princ-safe (user-full-name user))) + (:td (:princ-safe (format nil "~{~A~^, ~}" (user-flags user)))) + (:td (:princ-safe (if (and (user-last-login user) + (plusp (user-last-login user))) + (format-date-time (user-last-login user)) + "<never logged in>"))))))) (:h2 "Create new user") (user-form))) @@ -90,25 +98,27 @@ (when password (set-user-password user password)) (change-slot-values user 'email email 'full-name full-name))) + + (when (admin-p (bknr-request-user req)) + (let* ((all-flags (all-user-flags)) + (set-flags (keywords-from-query-param-list (query-param-list req "flags"))) + (unset-flags (set-difference all-flags set-flags))) + (user-add-flags user set-flags) + (user-remove-flags user unset-flags))) + (call-next-method)) +(define-condition unauthorized-error (simple-error) + () + (:report "You are not authorized to perform this operation")) + (defmethod handle-object-form ((handler user-handler) (action (eql :delete)) user req) + (unless (admin-p (bknr-request-user req)) + (error 'unauthorized-error)) (when user - (delete-object user)) + (delete-user user)) (redirect "/user" req)) -(defmethod handle-object-form ((handler user-handler) (action (eql :add-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-add-flags user flags))) - (call-next-method)) - -(defmethod handle-object-form ((handler user-handler) (action (eql :remove-flags)) user req) - (when user - (let ((flags (keywords-from-query-param-list (query-param-list req "keyword")))) - (user-remove-flags user flags))) - (call-next-method)) - (defmethod handle-object-form ((handler user-handler) (action (eql :create)) user req) (with-query-params (req login email full-name password password-repeat) (if (and password @@ -116,11 +126,11 @@ (error "please enter the same password twice") (if login (let* ((flags (keywords-from-query-param-list (query-param-list req "keyword"))) - (user (make-object 'user :login login - :email email - :full-name full-name - :password password - :flags flags))) + (user (make-user login + :email email + :full-name full-name + :password password + :flags flags))) (redirect (edit-object-url user) req)) (error "please enter a login"))))) Modified: branches/bos/bknr/src/web/user-tags.lisp =================================================================== --- branches/bos/bknr/src/web/user-tags.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/user-tags.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -2,20 +2,15 @@ (enable-interpol-syntax) -(define-bknr-tag user-flag-choose-dialog (&key (size "4") (name "keyword") (create nil)) - (let ((size (or (parse-integer size :junk-allowed t) 1))) - (loop for i from 1 to size - do (html ((:div :class "keyword-choose") - (when (> size 1) - (html (:princ-safe i) ". ")) - (select-box name - (loop for flag in - (sort (all-user-flags) #'string<) - collect (list (string-downcase flag) flag))) - (when create - (html ((:input :type "text" :length "20" :name name))))))))) +(define-bknr-tag user-flag-choose-dialog (&key enabled) + (dolist (flag (sort (all-user-flags) #'string<)) + (html + ((:div :class "user-flag-choose") + (if (find flag enabled) + (html ((:input :type "checkbox" :name "flags" :value flag :checked "checked"))) + (html ((:input :type "checkbox" :name "flags" :value flag)))) + (:princ-safe flag))))) - (define-bknr-tag user-form (&key user-id) (let ((user (when user-id (store-object-with-id (if (numberp user-id) @@ -36,11 +31,7 @@ (:td (html (text-field "email" :value (user-email user))))) (when (admin-p *user*) (html (:tr (:td "flags") - (:td (dolist (flag (user-flags user)) - (html (:princ-safe flag) " ")))) - (:tr (:td "new flags") - (:td (user-flag-choose-dialog :create t - :size "2"))))) + (:td (user-flag-choose-dialog :enabled (user-flags user)))))) (:tr (:td "new password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat new password") @@ -48,9 +39,7 @@ (:tr ((:td :colspan "2") (submit-button "save" "save") (when (admin-p *user*) - (submit-button "add-flags" "add flags") - (submit-button "remove-flags" "remove flags") - (submit-button "delete" "delete"))))))) + (submit-button "delete" "delete" :confirm "Really delete this user account? The operation cannot be undone."))))))) (html ((:form :method "post") (:table (:tr (:td "login") @@ -60,7 +49,7 @@ (:tr (:td "email") (:td ((:input :type "text" :name "email" :size "40")))) (:tr (:td "flags") - (:td (user-flag-choose-dialog :create t :size "2"))) + (:td (user-flag-choose-dialog))) (:tr (:td "password") (:td ((:input :type "password" :name "password" :size "8")))) (:tr (:td "repeat password") Modified: branches/bos/bknr/src/web/web-visitor.lisp =================================================================== --- branches/bos/bknr/src/web/web-visitor.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/bknr/src/web/web-visitor.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -16,12 +16,15 @@ (host-ip-address (web-visitor-event-host event)))) (defmethod print-object ((event web-visitor-event) stream) - (format stream "#<~a at ~a user ~a from ~a [~a]>" - (class-of event) (format-date-time (event-time event)) - (when (web-visitor-event-user event) - (user-login (web-visitor-event-user event))) - (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event))) + (print-unreadable-object (event stream :type t :identity t) + (format stream "at ~A user ~A" + (format-date-time (event-time event)) + (and (web-visitor-event-user event) + (user-login (web-visitor-event-user event)))) + (when (web-visitor-event-host event) + (format stream " from ~a [~a]" + (host-name (web-visitor-event-host event)) + (host-ip-address (web-visitor-event-host event)))))) event) #+(or) Modified: branches/bos/projects/bos/m2/m2.lisp =================================================================== --- branches/bos/projects/bos/m2/m2.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/m2/m2.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -123,6 +123,9 @@ (contracts :update :initform nil)) (:default-initargs :full-name nil :email nil)) +(defmethod user-editable-p ((sponsor sponsor)) + nil) + (defun sponsor-p (object) (equal (class-of object) (find-class 'sponsor))) @@ -146,6 +149,18 @@ (defmethod sponsor-id ((sponsor sponsor)) (store-object-id sponsor)) +(define-user-flag :editor) + +(defmethod editor-p ((user user)) + (or (admin-p user) + (user-has-flag user :editor))) + +(defclass editor-only-handler () + ()) + +(defmethod bknr.web:authorized-p ((handler editor-only-handler) req) + (editor-p (bknr-request-user req))) + ;;;; CONTRACT ;;; Exportierte Funktionen: @@ -308,6 +323,12 @@ contract) (warn "can't create contract, ~A square meters for ~A could not be allocated" m2-count sponsor)))) +(define-condition allocation-areas-exhausted (simple-error) + ((numsqm :initarg :numsqm :reader numsqm)) + (:report (lambda (condition stream) + (format stream "Could not satisfy your request for ~A sqms, please contact the BOS office" + (numsqm condition))))) + (defun make-contract (sponsor m2-count &key (date (get-universal-time)) paidp @@ -316,7 +337,11 @@ (unless (and (integerp m2-count) (plusp m2-count)) (error "number of square meters must be a positive integer")) - (let ((contract (do-make-contract sponsor m2-count :date date :paidp paidp :expires expires :download-only download-only))) + (let ((contract (do-make-contract sponsor m2-count + :date date + :paidp paidp + :expires expires + :download-only download-only))) (unless contract (send-system-mail :subject "Contact creation failed - Allocation areas exhaused" :text (format nil "A contract for ~A square meters could not be created, presumably because no @@ -326,7 +351,7 @@ Sponsor-ID: ~A " m2-count (store-object-id sponsor))) - (error "could not create contract, allocation areas exhausted?")) + (error 'allocation-areas-exhausted :numsqm m2-count)) contract)) (defvar *last-contracts-cache* nil) Modified: branches/bos/projects/bos/m2/packages.lisp =================================================================== --- branches/bos/projects/bos/m2/packages.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/m2/packages.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -91,6 +91,9 @@ #:country #:info-text + #:editor-only-handler + #:editor-p + #:contract #:make-contract #:contract-p Added: branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/da/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Großspende" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Anfrage zu groß für Online-Spende</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>Kontakt BOS Danmark med eventuelle spørgsmål.<br></br> + Vi modtager også gerne ideer til forbedringer at denne hjemmeside. + <br></br><br></br> + BOS Danmark.<br></br> + Økologihuset<br></br> + Blegdamsvej 4b<br></br> + 2200 København N + <br></br><br></br> + Telefon: 70 203 206<br></br> + Fax: 3537 3636<br></br><br></br> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img> + <a href="mailto:bos@orangutang.dk" class="more"> + bos(a)orangutang.dk + </a> + <br></br><br></br><br></br><br></br><br></br><br></br> + Vi besvarer alle henvendelser hurtigst muligt. + <br></br> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Added: branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/de/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,84 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Großspende" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Anfrage zu groß für Online-Spende</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>Leider konnten wir Ihre Spende nicht online verarbeiten, bitte nehmen Sie direkt + mit uns Kontakt auf:<br /> + <br /><br /> + BOS Deutschland e.V.<br /> + Böckhstr. 39<br /> + D - 10967 Berlin + <br /><br /> + Telefon: +49.30.26 36 78 33<br /> + Fax: +49.30.26 36 78 15<br /><br /> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="mailto:info@bos-deutschland.de" class="more"> + info(a)bos-deutschland.de + </a> + <br /><br /><br /><br /><br /><br /> + Wir werden Ihre Anfrage baldmöglichst beantworten. Bitte haben Sie etwas Geduld. + <br /> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Added: branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml =================================================================== --- branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/payment-website/templates/en/allocation-areas-exhausted.xml 2007-09-28 17:16:21 UTC (rev 2175) @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<bknr:toplevel + template="toplevel_main" + title="REGENWALD für SAMBOJA LESTARI - Large donation" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:bos="http://headcraft.de/bos" + > + <div id="content_main"> + <div id="textbox_content"> + <table border="0" cellpadding="0" cellspacing="0"> + <tr> + <td colspan="3"><span class="headline">Your donation is too large to be processed online at this time!</span> + </td> + <td> + </td> + </tr> + <tr> + <td height="15"> + </td> + </tr> + <tr> + <td>We're sorry, but your donorship request is too large to be processed online at + this time. Please get in touch with us directly! Thank you! + <br /> + <br /><br /> + BOS Deutschland e.V.<br /> + Böckhstr. 39<br /> + D - 10967 Berlin + <br /><br /> + Telefon: +49.30.26 36 78 33<br /> + Fax: +49.30.26 36 78 15<br /><br /> + E-Mail: + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="mailto:info@bos-deutschland.de" class="more"> + info(a)bos-deutschland.de + </a> + <br /><br /><br /><br /><br /><br /> + Wir werden Ihre Anfrage baldmöglichst beantworten. Bitte haben Sie etwas Geduld. + <br /> + </td> + </tr> + </table> + </div> + </div> + <div id="content_right"> + <div id="textbox_right_top"> + <table id="rightTable" border="0" cellpadding="0" cellspacing="0"> + <tr> + <td height="30"> + </td> + </tr> + <tr> + <td colspan="2"><img src="/images/bos-logo.gif" width="116" height="85" alt="" /> + </td> + </tr> + <tr> + <td height="10"> + </td> + </tr> + <tr> + <td colspan="2">Möchten Sie gern mehr über die Projekte von BOS erfahren? + <br /><br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.bos-deutschland.de" target="_blank" class="more"> + bos-deutschland.de + </a> + <br /> + <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" /> + <a href="http://www.savetheorangutan.info" target="_blank" class="more"> + savetheorangutan.info + </a> + <br /><br /> + </td> + </tr> + <tr> + <td>Dort finden Sie auch Links zu unseren BOS- Schwesterorganisationen weltweit. + </td> + </tr> + </table> + </div> + </div> +</bknr:toplevel> Modified: branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -80,7 +80,7 @@ (with-bos-cms-page (req :title "Allocation area has been deleted") (:h2 "The allocation area has been deleted"))) -(defclass allocation-area-gfx-handler (admin-only-handler object-handler) +(defclass allocation-area-gfx-handler (editor-only-handler object-handler) ()) (defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) Modified: branches/bos/projects/bos/worldpay-test/boi-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/boi-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/boi-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -31,9 +31,7 @@ ()) (defmethod authorized-p ((handler boi-handler) req) - (let ((user (bknr-request-user req))) - (or (admin-p user) - (user-has-flag user :boi)))) + (bos.m2:editor-p (bknr-request-user req))) (defclass create-contract-handler (boi-handler) ()) Modified: branches/bos/projects/bos/worldpay-test/contract-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/contract-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/contract-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -3,7 +3,7 @@ (enable-interpol-syntax) -(defclass contract-handler (admin-only-handler object-handler) +(defclass contract-handler (editor-only-handler object-handler) () (:default-initargs :class 'contract)) Modified: branches/bos/projects/bos/worldpay-test/news-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/news-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/news-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -6,7 +6,7 @@ (defmethod edit-object-url ((news-item news-item)) (format nil "/edit-news/~A" (store-object-id news-item))) -(defclass edit-news-handler (admin-only-handler edit-object-handler) +(defclass edit-news-handler (editor-only-handler edit-object-handler) ()) (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) Modified: branches/bos/projects/bos/worldpay-test/poi-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/poi-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/poi-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -20,7 +20,7 @@ (t (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) -(defclass edit-poi-handler (admin-only-handler edit-object-handler) +(defclass edit-poi-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -262,7 +262,7 @@ ;; edit-poi-image -(defclass edit-poi-image-handler (admin-only-handler edit-object-handler) +(defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi-image)) Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -3,13 +3,13 @@ (enable-interpol-syntax) -(defclass search-sponsors-handler (admin-only-handler form-handler) +(defclass search-sponsors-handler (editor-only-handler form-handler) ()) (defmethod handle-form ((handler search-sponsors-handler) action req) (with-bos-cms-page (req :title "Search for sponsor"))) -(defclass edit-sponsor-handler (admin-only-handler edit-object-handler) +(defclass edit-sponsor-handler (editor-only-handler edit-object-handler) ()) (defmethod object-handler-get-object ((handler edit-sponsor-handler) req) @@ -182,7 +182,7 @@ (delete-object sponsor) (html (:p "The sponsor has been deleted")))) -(defclass complete-transfer-handler (admin-only-handler edit-object-handler) +(defclass complete-transfer-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'contract)) @@ -276,7 +276,7 @@ (t "not-logged-in"))))))) -(defclass cert-regen-handler (admin-only-handler edit-object-handler) +(defclass cert-regen-handler (editor-only-handler edit-object-handler) () (:default-initargs :class 'contract)) Modified: branches/bos/projects/bos/worldpay-test/tags.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/tags.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/tags.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -57,56 +57,60 @@ (html ((:base "href" href))))) (define-bknr-tag buy-sqm (&key children) - (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) - (let* ((numsqm (parse-integer (or numsqm numsqm1))) - ;; Wer ueber dieses Formular bestellt, ist ein neuer - ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine - ;; Profil-ID wird automatisch zugewiesen, sonstige Daten - ;; haben wir zu diesem Zeitpunkt noch nicht. XXX - ;; Überweisung wird nur für die deutsche und dänische - ;; Website angeboten, was passenderweise durch die folgende - ;; Überprüfung auch sicher gestellt wurde. Sollte man aber - ;; eventuell noch mal prüfen und sicher stellen. - (manual-transfer (or (scan #?r"rweisen" action) - (scan #?r"rweisung" action) - (scan #?r"verf" action))) - (sponsor (make-sponsor)) - (contract (make-contract sponsor numsqm - :download-only download-only - :expires (+ (if manual-transfer - bos.m2::*manual-contract-expiry-time* - bos.m2::*online-contract-expiry-time*) - (get-universal-time)))) - (language (session-variable :language))) - (destructuring-bind (price currency) - (case (make-keyword-from-string language) - (:da (list (* numsqm 24) "DKK")) - (t (list (* numsqm 3) "EUR"))) - (setf (get-template-var :worldpay-url) - (if manual-transfer - (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" - (store-object-id contract) - price - numsqm - donationcert-yearly) - (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" - *worldpay-installation-id* - (store-object-id contract) - price - currency - language - (encode-urlencoded (format nil "~A ~A Samboja Lestari" - numsqm - (case (make-keyword-from-string language) - (:de "qm Regenwald in") - (:da "m2 Regnskov i") - (t "sqm rain forest in")))) - (store-object-id sponsor) - (sponsor-master-code sponsor) - (if donationcert-yearly "1" "0") - (if gift "1" "0") - (when *worldpay-test-mode* "&testMode=100")))))) - (mapc #'emit-template-node children))) + (handler-case + (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only) + (let* ((numsqm (parse-integer (or numsqm numsqm1))) + ;; Wer ueber dieses Formular bestellt, ist ein neuer + ;; Sponsor, also ein neues Sponsorenobjekt anlegen. Eine + ;; Profil-ID wird automatisch zugewiesen, sonstige Daten + ;; haben wir zu diesem Zeitpunkt noch nicht. + ;; Überweisung wird nur für die deutsche und dänische + ;; Website angeboten, was passenderweise durch die folgende + ;; Überprüfung auch sicher gestellt wurde. Sollte man aber + ;; eventuell noch mal prüfen und sicher stellen. + (manual-transfer (or (scan #?r"rweisen" action) + (scan #?r"rweisung" action) + (scan #?r"verf" action))) + (sponsor (make-sponsor)) + (contract (make-contract sponsor numsqm + :download-only download-only + :expires (+ (if manual-transfer + bos.m2::*manual-contract-expiry-time* + bos.m2::*online-contract-expiry-time*) + (get-universal-time)))) + (language (session-variable :language))) + (destructuring-bind (price currency) + (case (make-keyword-from-string language) + (:da (list (* numsqm 24) "DKK")) + (t (list (* numsqm 3) "EUR"))) + (setf (get-template-var :worldpay-url) + (if manual-transfer + (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]" + (store-object-id contract) + price + numsqm + donationcert-yearly) + (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&curr…" + *worldpay-installation-id* + (store-object-id contract) + price + currency + language + (encode-urlencoded (format nil "~A ~A Samboja Lestari" + numsqm + (case (make-keyword-from-string language) + (:de "qm Regenwald in") + (:da "m2 Regnskov i") + (t "sqm rain forest in")))) + (store-object-id sponsor) + (sponsor-master-code sponsor) + (if donationcert-yearly "1" "0") + (if gift "1" "0") + (when *worldpay-test-mode* "&testMode=100")))))) + (mapc #'emit-template-node children)) + (bos.m2::allocation-areas-exhausted (e) + (declare (ignore e)) + (bknr.web::redirect-request :target "allocation-areas-exhausted")))) (define-bknr-tag mail-transfer () (with-query-params ((get-template-var :request) @@ -163,6 +167,6 @@ (mapc #'emit-template-node children)) (define-bknr-tag admin-login-page (&key children) - (if (admin-p (bknr-request-user (get-template-var :request))) + (if (editor-p (bknr-request-user (get-template-var :request))) (html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin")))) (mapc #'emit-template-node children))) \ No newline at end of file Modified: branches/bos/projects/bos/worldpay-test/worldpay-test.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/worldpay-test.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/projects/bos/worldpay-test/worldpay-test.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -115,7 +115,7 @@ (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req))))) (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req)) -(defclass statistics-handler (admin-only-handler prefix-handler) +(defclass statistics-handler (editor-only-handler prefix-handler) ()) (defmethod handle ((handler statistics-handler) req) @@ -133,11 +133,11 @@ ((:p :id "stats")) ((:script :type "text/javascript") "statistic_selected()")))))) -(defclass admin-handler (admin-only-handler page-handler) +(defclass admin-handler (editor-only-handler page-handler) ()) (defmethod handle ((handler admin-handler) req) - (with-bos-cms-page (req :title "BOS CMS and Administration") + (with-bos-cms-page (req :title "CMS and Administration") "Please choose an administration activity from the menu above")) (defclass bos-authorizer (bknr-authorizer) @@ -183,7 +183,7 @@ (setf bknr.web:*upload-file-size-limit* 20000000) (make-instance 'bos-website - :name "BOS Website" + :name "create-rainforest.org CMS" :handler-definitions `(("/edit-poi" edit-poi-handler) ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) @@ -221,14 +221,14 @@ :command-packages ((:bos . :worldpay-test) (:bknr . :bknr.web)))) :modules '(user images stats) + :navigation '(("sponsor" . "edit-sponsor/") + ("statistics" . "statistics/") + ("news" . "edit-news/") + ("poi" . "edit-poi/") + ("logout" . "logout")) :admin-navigation '(("user" . "user/") - ("sponsor" . "edit-sponsor/") - ("statistics" . "statistics/") - ("news" . "edit-news/") - ("poi" . "edit-poi/") ("languages" . "languages") - ("allocation area" . "allocation-area/") - ("logout" . "logout")) + ("allocation area" . "allocation-area/")) :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css") Modified: branches/bos/thirdparty/iconv/iconv.lisp =================================================================== --- branches/bos/thirdparty/iconv/iconv.lisp 2007-09-11 08:41:27 UTC (rev 2174) +++ branches/bos/thirdparty/iconv/iconv.lisp 2007-09-28 17:16:21 UTC (rev 2175) @@ -9,11 +9,11 @@ (in-package :iconv) -(cffi-uffi-compat:load-foreign-library "/usr/lib/libc.so") -(cffi-uffi-compat:load-foreign-library "/usr/local/lib/libiconv.so") +(load-foreign-library "/usr/lib/libc.so") +(load-foreign-library "/usr/local/lib/libiconv.so") #-sbcl -(cffi-uffi-compat:def-foreign-var ("errno" errno) :int "iconv") +(def-foreign-var ("errno" errno) :int "iconv") (defun get-errno () #-(or sbcl cmu19c) @@ -24,23 +24,23 @@ (sb-alien:get-errno) ) -(cffi-uffi-compat:def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte -(cffi-uffi-compat:def-constant EINVAL 22) ;imcomplete multibyte -(cffi-uffi-compat:def-constant E2BIG 7) ;not enough outbuf +(def-constant EILSEQ #+freebsd 86 #-freebsd 84) ;invalid multibyte +(def-constant EINVAL 22) ;imcomplete multibyte +(def-constant E2BIG 7) ;not enough outbuf -(cffi-uffi-compat:def-foreign-type uchar-ptr (* :unsigned-char)) -(cffi-uffi-compat:def-foreign-type iconv-t :pointer-void) +(def-foreign-type uchar-ptr (* :unsigned-char)) +(def-foreign-type iconv-t :pointer-void) -(cffi-uffi-compat:def-function ("iconv_open" iconv-open) +(def-function ("iconv_open" iconv-open) ((tocode :cstring) (fromcode :cstring)) :returning 'iconv-t) -(cffi-uffi-compat:def-function ("iconv_close" iconv-close) +(def-function ("iconv_close" iconv-close) ((cd 'iconv-t)) :returning :int) -(cffi-uffi-compat:def-function ("iconv" %iconv) +(def-function ("iconv" %iconv) ((cd 'iconv-t) (inbuf (* uchar-ptr)) (inbytesleft (* :unsigned-long)) @@ -49,7 +49,7 @@ :returning :unsigned-int) (defmacro with-iconv-cd ((cd from to) &body body) - `(cffi-uffi-compat:with-cstrings ((fromcode ,from) + `(with-cstrings ((fromcode ,from) (tocode ,to)) (let ((,cd (iconv-open tocode fromcode))) (unwind-protect @@ -63,21 +63,21 @@ (with-iconv-cd (cd from-code to-code) (let* ((from-len (length from-string)) (to-len (* from-len 2)) - (inbuffer (cffi-uffi-compat:convert-to-foreign-string from-string)) - (outbuffer (cffi-uffi-compat:allocate-foreign-string to-len :unsigned t)) - (in-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr)) - (out-ptr (cffi-uffi-compat:allocate-foreign-object 'uchar-ptr)) - (inbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int)) - (outbytesleft (cffi-uffi-compat:allocate-foreign-object :unsigned-int))) + (inbuffer (convert-to-foreign-string from-string)) + (outbuffer (allocate-foreign-string to-len :unsigned t)) + (in-ptr (allocate-foreign-object 'uchar-ptr)) + (out-ptr (allocate-foreign-object 'uchar-ptr)) + (inbytesleft (allocate-foreign-object :unsigned-int)) + (outbytesleft (allocate-foreign-object :unsigned-int))) (unwind-protect (progn - (setf (cffi-uffi-compat:deref-pointer in-ptr 'uchar-ptr) inbuffer - (cffi-uffi-compat:deref-pointer out-ptr 'uchar-ptr) outbuffer - (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int) from-len - (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int) to-len) + (setf (deref-pointer in-ptr 'uchar-ptr) inbuffer + (deref-pointer out-ptr 'uchar-ptr) outbuffer + (deref-pointer inbytesleft :unsigned-int) from-len + (deref-pointer outbytesleft :unsigned-int) to-len) (labels ((current () - (- from-len (cffi-uffi-compat:deref-pointer inbytesleft :unsigned-int))) + (- from-len (deref-pointer inbytesleft :unsigned-int))) (self () (when (= (%iconv cd in-ptr inbytesleft @@ -91,10 +91,10 @@ (self))) (error "unexpected iconv error ~A" (get-errno)))))) (self)) - (cffi-uffi-compat:convert-from-foreign-string outbuffer :length (- to-len (cffi-uffi-compat:deref-pointer outbytesleft :unsigned-int)))) - (cffi-uffi-compat:free-foreign-object outbytesleft) - (cffi-uffi-compat:free-foreign-object inbytesleft) - (cffi-uffi-compat:free-foreign-object out-ptr) - (cffi-uffi-compat:free-foreign-object in-ptr) - (cffi-uffi-compat:free-foreign-object outbuffer) - (cffi-uffi-compat:free-foreign-object inbuffer)))))) + (convert-from-foreign-string outbuffer :length (- to-len (deref-pointer outbytesleft :unsigned-int)))) + (free-foreign-object outbytesleft) + (free-foreign-object inbytesleft) + (free-foreign-object out-ptr) + (free-foreign-object in-ptr) + (free-foreign-object outbuffer) + (free-foreign-object inbuffer))))))

1 0

[bknr-cvs] r2174 - branches/bos/projects/bos/worldpay-test
by bknr＠bknr.net 11 Sep '07

11 Sep '07

Author: hhubner Date: 2007-09-11 04:41:27 -0400 (Tue, 11 Sep 2007) New Revision: 2174 Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp Log: Add checkbox for donation cert. Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:40:55 UTC (rev 2173) +++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2007-09-11 08:41:27 UTC (rev 2174) @@ -83,8 +83,10 @@ 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" - (:td (textarea-field "address" :rows 5 :cols 40)))) + (:tr (:td "Postal address for certificate") + (:td (textarea-field "address" :rows 5 :cols 40))) + (:tr (:td "Issue donation cert at the end of the year") + (:td (checkbox-field "donationcert-yearly" "" :checked nil))) (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))) (defun date-to-universal (date-string)

1 0

[bknr-cvs] r2173 - branches/bos/projects/bos/m2
by bknr＠bknr.net 11 Sep '07

11 Sep '07

Author: hhubner Date: 2007-09-11 04:40:55 -0400 (Tue, 11 Sep 2007) New Revision: 2173 Modified: branches/bos/projects/bos/m2/mail-generator.lisp Log: Properly destructure parameter list. Modified: branches/bos/projects/bos/m2/mail-generator.lisp =================================================================== --- branches/bos/projects/bos/m2/mail-generator.lisp 2007-08-30 09:43:19 UTC (rev 2172) +++ branches/bos/projects/bos/m2/mail-generator.lisp 2007-09-11 08:40:55 UTC (rev 2173) @@ -185,7 +185,7 @@ " (apply #'append (mapcar #'(lambda (cons) - (destructuring-bind (element-name content) cons + (destructuring-bind (element-name . content) cons (setf element-name (lookup-element-name element-name)) (list element-name (if (find #\Newline content)

1 0