[claw-cvs] r77 - in trunk/main/claw-demo/src: backend frontend frontend/docroot/css frontend/docroot/img
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Mon Sep 1 15:32:50 UTC 2008
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 , at 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
More information about the Claw-cvs
mailing list