claw-cvs

Download

claw-cvs@common-lisp.net

September 2008

1 participants
21 discussions

[claw-cvs] r77 - in trunk/main/claw-demo/src: backend frontend frontend/docroot/css frontend/docroot/img
by achiumenti＠common-lisp.net 01 Sep '08

01 Sep '08

Author: achiumenti Date: Mon Sep 1 11:32:49 2008 New Revision: 77 Added: trunk/main/claw-demo/src/frontend/docroot/img/asc_arrow.gif (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/desc_arrow.gif (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/sort_arrow.gif (contents, props changed) Modified: trunk/main/claw-demo/src/backend/dao.lisp trunk/main/claw-demo/src/backend/packages.lisp trunk/main/claw-demo/src/backend/service.lisp trunk/main/claw-demo/src/backend/vo.lisp trunk/main/claw-demo/src/frontend/auth.lisp trunk/main/claw-demo/src/frontend/customers.lisp trunk/main/claw-demo/src/frontend/docroot/css/style.css trunk/main/claw-demo/src/frontend/login.lisp Log: demo update Modified: trunk/main/claw-demo/src/backend/dao.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/dao.lisp (original) +++ trunk/main/claw-demo/src/backend/dao.lisp Mon Sep 1 11:32:49 2008 @@ -58,6 +58,8 @@ (defun slot-column-name (symbol-class slot-name) + (when (stringp slot-name) + (setf slot-name (intern (string-upcase slot-name) 'claw-demo-backend))) (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class)) when (and (typep slot 'clsql-sys::view-class-effective-slot-definition) (equal (closer-mop:slot-definition-name slot) slot-name)) Modified: trunk/main/claw-demo/src/backend/packages.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/packages.lisp (original) +++ trunk/main/claw-demo/src/backend/packages.lisp Mon Sep 1 11:32:49 2008 @@ -44,6 +44,8 @@ #:db-connect #:db-disconnect ;; --- Value objects --- ;; + #:copy-values-by-accessors + #:slot-column-name #:base-table #:table-id #:table-version @@ -97,6 +99,7 @@ #:update-db-item #:delete-db-item #:reload-db-item + #:find-by-id #:delete-class-records #:find-user-by-name #:find-customers)) \ No newline at end of file Modified: trunk/main/claw-demo/src/backend/service.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/service.lisp (original) +++ trunk/main/claw-demo/src/backend/service.lisp Mon Sep 1 11:32:49 2008 @@ -54,7 +54,14 @@ (with-transaction (:database *claw-demo-db*) (let ((table-name (symbol-name (view-table (find-class symbol-class))))) (delete-records :from table-name :where where)))) - + +(defun build-order-by (fields) + (loop for field in fields + collect (if (listp field) + (list (sql-expression :attribute (first field)) + (second field)) + (sql-expression :attribute field)))) + (defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) where group-by having order-by) "Returns a pair of values where the first is the select result, and the second is the total record amount without considering offset and limit keys." (values @@ -62,7 +69,7 @@ :where where :group-by group-by :having having - :order-by order-by + :order-by (when order-by (build-order-by order-by)) :flatp t :refresh refresh :offset offset @@ -75,18 +82,21 @@ :from (view-table (find-class symbol-class)) :where where :group-by group-by - :having having + :having having :flatp t :refresh refresh))) +(defun find-by-id (symbol-class id) + (first (select symbol-class + :where (sql-operation '= (slot-column-name symbol-class 'id) id) + :flatp t + :refresh t))) + (defmethod reload-db-item ((item base-table)) "Reloads item data selecting the item by its id. This function isn't destructive" (let ((symbol-class (class-name (class-of item))) (id (table-id item))) - (first (select symbol-class - :where [= [slot-value symbol-class 'id] id] - :flatp t - :refresh t)))) + (find-by-id symbol-class id))) (defun find-user-by-name (name) (let ((where (sql-operation '= (slot-column-name 'user 'username) name))) @@ -116,6 +126,7 @@ :limit limit :where (if (> (length where) 1) (apply #'sql-operation (cons 'and where)) - (first where))))) + (first where)) + :order-by sorting))) #.(locally-disable-sql-reader-syntax) \ No newline at end of file Modified: trunk/main/claw-demo/src/backend/vo.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/vo.lisp (original) +++ trunk/main/claw-demo/src/backend/vo.lisp Mon Sep 1 11:32:49 2008 @@ -29,6 +29,13 @@ (in-package :claw-demo-backend) +(defmacro copy-values-by-accessors (dest src &rest accessors) + (let ((dest-src-pairs + (loop for accessor in accessors + collect `(,accessor ,dest) + collect `(,accessor ,src)))) + `(setf ,@dest-src-pairs))) + (def-view-class base-table () ((id :db-kind :key :accessor table-id @@ -222,7 +229,7 @@ :accessor customer-code4 :type (varchar 50) :db-constraints :unique)) - (:default-initargs :name2 nil :email nil + (:default-initargs :name1 nil :name2 nil :email nil :phone1 nil :phone2 nil :phone3 nil :fax nil :vat nil :code1 nil :code2 nil :code3 nil :code4 nil) Modified: trunk/main/claw-demo/src/frontend/auth.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/auth.lisp (original) +++ trunk/main/claw-demo/src/frontend/auth.lisp Mon Sep 1 11:32:49 2008 @@ -49,11 +49,9 @@ (claw-parameter "password"))) (unwind-protect (progn - (log-message :info "ppppppppppppppp") (db-connect) (let ((user-vo (find-user-by-name user))) (when (and user-vo (string= password (user-password user-vo))) - (log-message :info "----> ~a " (user-roles user-vo)) (make-instance 'demo-principal :name (user-username user-vo) :firstname (user-firstname user-vo) Modified: trunk/main/claw-demo/src/frontend/customers.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/customers.lisp (original) +++ trunk/main/claw-demo/src/frontend/customers.lisp Mon Sep 1 11:32:49 2008 @@ -33,17 +33,17 @@ (defclass edit-customer (wcomponent) ((customer :initarg :customer - :accessor edit-customer-customer) + :accessor edit-customer-save-customer) (on-before-submit :initarg :on-before-submit :accessor on-before-submit) (on-xhr-finish :initarg :on-xhr-finish :accessor on-xhr-finish)) (:metaclass metacomponent) - (:default-initargs :on-before-submit nil :on-xhr-finish nil :customer (make-instance 'customer))) + (:default-initargs :on-before-submit nil :on-xhr-finish nil)) (defmethod wcomponent-template ((obj edit-customer)) (let ((id (htcomponent-client-id obj)) - (visit-object (edit-customer-customer obj))) + (visit-object (edit-customer-save-customer obj))) (djform> :static-id id :class "customerForm" :update-id id @@ -51,8 +51,13 @@ :action-object obj :on-before-submit (on-before-submit obj) :on-xhr-finish (on-xhr-finish obj) - (cinput> :type "hidden" :visit-object visit-object + (cinput> :id "customerid" + :type "hidden" :visit-object visit-object + :translator *integer-translator* :accessor 'table-id) + (cinput> :type "hidden" :visit-object visit-object + :translator *integer-translator* + :accessor 'table-version) (div> :class "label name1" (span> "Name 1") (djvalidation-text-box> :visit-object visit-object @@ -117,27 +122,53 @@ (div> :class "buttons" (djsubmit-button> :value "Save"))))) + +(defun customer-save (customer) + (let ((db-customer (find-by-id 'customer (table-id customer)))) + (copy-values-by-accessors db-customer customer + table-version + customer-name1 + customer-name2 + customer-email + customer-phone1 customer-phone2 customer-phone3 + customer-fax + customer-vat + customer-code1 customer-code2 customer-code3 customer-code4) + (update-db-item db-customer) + db-customer)) + (defmethod edit-customer-save ((obj edit-customer)) - (let ((id (htcomponent-client-id obj))) + (let ((id (htcomponent-client-id obj)) + (customer (edit-customer-save-customer obj))) (handler-case - (update-db-item (edit-customer-customer obj)) - (error (cond) - (add-validation-error id cond))))) + (setf (edit-customer-save-customer obj) (customer-save customer)) + (clsql-sys:sql-database-error (cond) + (log-message :info "Exception on edit-customer-save: ~a" cond) + (add-validation-error id (clsql-sys:sql-error-database-message cond)) + nil)))) -(defgeneric customers-page-find-users (customers-page)) +(defgeneric customers-page-find-customers (customers-page)) (defgeneric customers-page-offset-reset (customers-page)) +(defgeneric customers-page-edit-customer (customers-page)) + +(defgeneric customers-page-sorting (customers-page)) + (defclass customers-page (db-page) ((customers :initform nil :accessor customers-page-customers) + (current-customer :initform (make-instance 'customer) + :accessor customer-page-current-customer) + (customer-edit-dialog-title :initform "Add new cutomer" + :accessor customers-page-customer-edit-dialog-title) (customers-total-count :initform 0 :accessor customers-page-customers-total-count) (list-size :initarg :list-size :accessor customers-page-list-size) (offset :initform 0 :accessor customers-page-offset) - (name1 :initform "" + (name1 :initform "*" :accessor customers-page-name1) (name2 :initform "" :accessor customers-page-name2) @@ -146,22 +177,55 @@ (vat :initform "" :accessor customers-page-vat) (phone :initform "" - :accessor customers-page-phone)) + :accessor customers-page-phone) + (sorting-column :initform "name1" + :accessor customers-page-sorting-column) + (sorting-order :initform "asc" + :accessor customers-page-sorting-order)) (:default-initargs :list-size 20)) (defmethod customers-page-offset-reset ((page customers-page)) 0) +(defmethod customers-page-edit-customer ((page customers-page)) + (let ((customer-id (parse-integer (claw-parameter "customerid"))) + (current-customer)) + (setf current-customer (find-by-id 'customer customer-id)) + (setf (customers-page-customer-edit-dialog-title page) "Edit customer") + (when current-customer + (setf (customer-page-current-customer page) current-customer)))) + +(defmethod customers-page-sorting ((page customers-page)) + (let ((direction (if (string-equal "asc" (customers-page-sorting-order page)) + :asc + :desc)) + (fields (if (string-equal "name1" (customers-page-sorting-column page)) + (list (slot-column-name 'customer "name1") + (slot-column-name 'customer "name2")) + (list (slot-column-name 'customer "email") + (slot-column-name 'customer "name1") + (slot-column-name 'customer "name2"))))) + (loop for field in fields + collect (list field direction)))) + (defmethod page-content ((page customers-page)) (let ((spinner-id (generate-id "spinner")) (form-id (generate-id "customersForm")) (customers (customers-page-customers page)) - (offset-id (generate-id "offset"))) + (offset-id (generate-id "offset")) + (edit-customer-dialog-container-id (generate-id "customerDialogContainer")) + (edit-customer-dialog-id (generate-id "customerDialog")) + (edit-customer-form-id (generate-id "customerForm")) + (sorting-column-id (generate-id "sorting-column")) + (sorting-order-id (generate-id "sorting-order")) + (edit-customer-action-link-id (generate-id "editCustomer")) + (sort-field (customers-page-sorting-column page)) + (sort-direction (customers-page-sorting-order page))) (site-template> :title "CLAW Demo anagraphics" (djfloating-content> :static-id spinner-id (img> :alt "spinner" :src "docroot/img/spinner.gif")) (djform> :static-id form-id - :action 'customers-page-find-users + :action 'customers-page-find-customers :update-id form-id :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) @@ -180,30 +244,84 @@ :translator *integer-translator* :reader 'customers-page-offset-reset :writer (attribute-value '(setf customers-page-offset))) + (cinput> :type "hidden" + :static-id sorting-column-id + :accessor 'customers-page-sorting-column) + (cinput> :type "hidden" + :static-id sorting-order-id + :accessor 'customers-page-sorting-order) (djsubmit-button> :id "search" :value "Search")) (table> :class "listTable" (tr> :class "header" - (th> :class "name" "Name") - (th> :class "email" "Email") + (th> :class "name" (span> :class (if (string-equal "name1" sort-field) + (if (string-equal "asc" sort-direction) + "sort sortAsc" + "sort sortDesc") + "sort") + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "name1") + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc")) + (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) + "name1") + (.submit (dijit.by-id ,form-id))))) + "Name")) + (th> :class "email" (span> :class (if (string-equal "email" sort-field) + (if (string-equal "asc" sort-direction) + "sort sortAsc" + "sort sortDesc") + "sort") + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dojo.by-id ,sorting-order-id) 'value) + (if (and (== (slot-value (dojo.by-id ,sorting-column-id) 'value) "email") + (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) + "desc" + "asc")) + (setf (slot-value (dojo.by-id ,sorting-column-id) 'value) + "email") + (.submit (dijit.by-id ,form-id))))) + "Email")) (th> :class "vat" "VAT") (th> :class "phone" "Phone")) (loop for customer in customers for index = 0 then (incf index) collect (tr> :class (if (evenp index) "item even" "item odd") - (td> (customer-name1 customer) - " " - (customer-name2 customer)) + (td> (a> :id "edit" + :href "#" + :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-customer-action-link-id) 'parameters) + (create "customerid" ,(table-id customer))) + (.click (dijit.by-id ,edit-customer-action-link-id))))) + (customer-name1 customer) + " " + (customer-name2 customer))) (td> (customer-email customer)) (td> (customer-vat customer)) (td> (customer-phone1 customer))))) + (djaction-link> :static-id edit-customer-action-link-id + :style "display:none" + :action 'customers-page-edit-customer + :update-id edit-customer-dialog-container-id + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) + (.show (dijit.by-id ,edit-customer-dialog-id))))) + "invisible") (pager> :id "pager" :update-component-id offset-id :page-size (customers-page-list-size page) :total-items (customers-page-customers-total-count page) - :first-item-offset (customers-page-offset page)))))) + :first-item-offset (customers-page-offset page))) + (div> :static-id edit-customer-dialog-container-id + (djdialog> :static-id edit-customer-dialog-id + :title (customers-page-customer-edit-dialog-title page) + (edit-customer> :static-id edit-customer-form-id + :customer (customer-page-current-customer page) + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + :customer (customer-page-current-customer page)) + (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-customer-form-id)))))) -(defmethod customers-page-find-users ((page customers-page)) +(defmethod customers-page-find-customers ((page customers-page)) (let ((name1 (customers-page-name1 page)) (name2 (customers-page-name2 page)) (email (customers-page-email page)) @@ -216,14 +334,16 @@ :name2 (null-when-empty name2) :email (null-when-empty email) :vat (null-when-empty vat) - :phone (null-when-empty phone)) + :phone (null-when-empty phone) + :sorting (customers-page-sorting page)) (setf (customers-page-customers page) customers (customers-page-customers-total-count page) total-size)))) (defmethod page-before-render ((page customers-page)) (unless (page-req-parameter page *rewind-parameter*) (multiple-value-bind (customers total-size) - (find-customers :offset 0 + (find-customers :sorting (customers-page-sorting page) + :offset 0 :limit (customers-page-list-size page)) (setf (customers-page-customers page) customers (customers-page-customers-total-count page) total-size)))) Modified: trunk/main/claw-demo/src/frontend/docroot/css/style.css ============================================================================== --- trunk/main/claw-demo/src/frontend/docroot/css/style.css (original) +++ trunk/main/claw-demo/src/frontend/docroot/css/style.css Mon Sep 1 11:32:49 2008 @@ -117,4 +117,33 @@ } .searchParameters div.item span { display: block; +} + +.customerForm .label span{ + display:-moz-inline-stack; + display:inline-block; + width: 80px; + text-align: right; + padding-right: 15px; +} + +.customerForm .buttons { + margin-top: 10px; + padding-top: 5px; + text-align: center; + border-top: 1px solid #BCD5F0; +} + +.sort { + cursor: pointer; + padding-right: 15px; + background: url(../img/sort_arrow.gif) 100% 50% no-repeat; +} + +.sortAsc { + background: url(../img/asc_arrow.gif) 100% 50% no-repeat; +} + +.sortDesc { + background: url(../img/desc_arrow.gif) 100% 50% no-repeat; } \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/docroot/img/asc_arrow.gif ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/desc_arrow.gif ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/sort_arrow.gif ============================================================================== Binary file. No diff available. Modified: trunk/main/claw-demo/src/frontend/login.lisp ============================================================================== --- trunk/main/claw-demo/src/frontend/login.lisp (original) +++ trunk/main/claw-demo/src/frontend/login.lisp Mon Sep 1 11:32:49 2008 @@ -39,7 +39,8 @@ (defmethod page-content ((o login-page)) (let ((login-result-id (generate-id "loginResult")) - (spinner-id (generate-id "spinner"))) + (spinner-id (generate-id "spinner")) + (form-id (generate-id "login"))) (site-template> :title "CLAW Demo login" (djdialog> :id "loginDialog" :title "Login into system" @@ -47,7 +48,8 @@ (djfloating-content> :static-id spinner-id (img> :alt "spinner" :src "docroot/img/spinner.gif")) - (djform> :id "login" + (djform> :static-id form-id + :method "get" :class "loginForm" :action 'login-page-do-login :update-id login-result-id @@ -67,7 +69,7 @@ :accessor 'login-page-password)) (div> :class "buttonContainer" (djsubmit-button> :value "Login") - (exception-monitor> :id "exceptionMonitor"))) + (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p form-id))) (div> :static-id login-result-id (redirect> :render-condition #'current-principal :id "redirect" @@ -80,7 +82,6 @@ :login-page-p t) (defmethod login-page-do-login ((page login-page)) - (log-message :error "Performing login") (unless (login) (add-validation-error "login" "Invalid user or password"))) \ No newline at end of file

1 0