[claw-cvs] r103 - trunk/main/claw-demo/src/frontend
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Wed Oct 1 11:59:40 UTC 2008
Author: achiumenti
Date: Wed Oct 1 07:59:39 2008
New Revision: 103
Added:
trunk/main/claw-demo/src/frontend/users.lisp
Log:
several bugfixes and enhancements
Added: trunk/main/claw-demo/src/frontend/users.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/users.lisp Wed Oct 1 07:59:39 2008
@@ -0,0 +1,369 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/frontend/users.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :claw-demo-frontend)
+
+(defgeneric users-page-find-users (users-page))
+
+(defgeneric users-page-offset-reset (users-page))
+
+(defgeneric users-page-edit-user (uses-page))
+
+(defgeneric users-page-sorting (users-page))
+
+(defgeneric users-page-delete-users (users-page))
+
+(defclass users-page (db-page)
+ ((users :initform nil
+ :accessor users-page-users)
+ (current-user :initform (make-instance 'user)
+ :accessor users-page-current-user)
+ (user-edit-dialog-title :initform "Add new cutomer"
+ :accessor users-page-user-edit-dialog-title)
+ (users-total-count :initform 0
+ :accessor users-page-users-total-count)
+ (list-size :initarg :list-size
+ :accessor users-page-list-size)
+ (offset :initform 0
+ :accessor users-page-offset)
+ (surname :initform "*"
+ :accessor users-page-surname)
+ (firstname :initform ""
+ :accessor users-page-firstname)
+ (username :initform ""
+ :accessor users-page-username)
+ (email :initform ""
+ :accessor users-page-email)
+ (active :initform :any
+ :accessor users-page-active)
+ (roles :initform '("user" "guest")
+ :accessor users-page-roles)
+ (sorting-column :initform "surname"
+ :accessor users-page-sorting-column)
+ (sorting-order :initform "asc"
+ :accessor users-page-sorting-order)
+ (delete-all :initform nil
+ :accessor users-page-delete-all)
+ (delete-items :initform nil
+ :accessor users-page-delete-items))
+ (:default-initargs :list-size 20))
+
+(defmethod users-page-offset-reset ((page users-page)) 0)
+
+(defmethod users-page-edit-user ((page users-page))
+ (let ((user-id (parse-integer (claw-parameter "userid")))
+ (current-user))
+ (setf current-user (find-by-id 'user user-id)
+ (users-page-user-edit-dialog-title page) "Edit user"
+ (users-page-users page) (list current-user))
+ (when current-user
+ (setf (users-page-current-user page) current-user))))
+
+(defmethod users-page-sorting ((page users-page))
+ (let ((direction (if (string-equal "asc" (users-page-sorting-order page))
+ :asc
+ :desc))
+ (fields (cond
+ ((string-equal "surname" (users-page-sorting-column page)) (list (slot-column-name 'user "surname")
+ (slot-column-name 'user "firstname")))
+ ((string-equal "username" (users-page-sorting-column page)) (list (slot-column-name 'user "username")))
+ (t (list (slot-column-name 'user "email")
+ (slot-column-name 'user "surname")
+ (slot-column-name 'user "firstname"))))))
+ (loop for field in fields
+ collect (list field direction))))
+
+(defmethod page-content ((page users-page))
+ (let ((spinner-id (generate-id "spinner"))
+ (form-id (generate-id "usersForm"))
+ (users (users-page-users page))
+ (offset-id (generate-id "offset"))
+ (result-container-id (generate-id "resultContainer"))
+ (edit-user-dialog-container-id (generate-id "userDialogContainer"))
+ (edit-user-dialog-id (generate-id "userDialog"))
+ (edit-user-form-id (generate-id "userForm"))
+ (sorting-column-id (generate-id "sorting-column"))
+ (sorting-order-id (generate-id "sorting-order"))
+ (active-any-id (generate-id "activeAny"))
+ (active-yes-id (generate-id "activeYes"))
+ (active-no-id (generate-id "activeNo"))
+ (edit-user-action-link-id (generate-id "editUser"))
+ (sort-field (users-page-sorting-column page))
+ (sort-direction (users-page-sorting-order page))
+ (all-roles (find-vo 'role :order-by (list (slot-column-name 'role "name")))))
+ (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
+ :class "users"
+ :action 'users-page-find-users
+ :update-id result-container-id
+ :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
+ :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id)))
+ (div> (div> :class "searchParameters hlist"
+ (div> :class "item" (span> :class "surname" "Name")
+ (djtext-box> :label "name" :id "surname" :accessor 'users-page-surname)
+ (djtext-box> :label "name" :id "firstname" :accessor 'users-page-firstname))
+ (div> :class "item" (span> :class "username" "Username")
+ (djtext-box> :label "username" :id "username" :accessor 'users-page-username))
+ (div> :class "item" (span> :class "email" "Email")
+ (djtext-box> :label "email" :id "email" :accessor 'users-page-email))
+ (div> :class "item active" (span> :class "active" "Active")
+ (div> :class "boundBox"
+ (div> (djradio-button> :static-id active-any-id
+ :name "active"
+ :class "active"
+ :translator *threestate-translator*
+ :accessor 'users-page-active
+ :value :any)
+ (label> :for active-any-id "Any"))
+ (div> (djradio-button> :static-id active-yes-id
+ :name "active"
+ :class "active"
+ :translator *threestate-translator*
+ :accessor 'users-page-active
+ :value t)
+ (label> :for active-yes-id "Yes"))
+ (div> (djradio-button> :static-id active-no-id
+ :name "active"
+ :class "active"
+ :translator *threestate-translator*
+ :accessor 'users-page-active
+ :value nil)
+ (label> :for active-no-id "No"))))
+ (div> :class "item roles" (span> :class "roles" "Roles")
+ (div> :class "boundBox"
+ (loop for role in all-roles
+ collect (let ((chk-id (generate-id "selRole")))
+ (div> (djcheck-box> :static-id chk-id
+ :name "selRole"
+ :class "selRole"
+ :accessor 'users-page-roles
+ :value (role-name role)
+ :multiple t)
+ (label> :for chk-id (role-name role))))))))
+ (cinput> :type "hidden"
+ :static-id offset-id
+ :translator *integer-translator*
+ :reader 'users-page-offset-reset
+ :writer (attribute-value '(setf users-page-offset)))
+ (cinput> :type "hidden"
+ :static-id sorting-column-id
+ :accessor 'users-page-sorting-column)
+ (cinput> :type "hidden"
+ :static-id sorting-order-id
+ :accessor 'users-page-sorting-order)
+ (div> :class "hlistButtons"
+ (djsubmit-button> :id "search"
+ :value "Search")
+ (djconfirmation-submit> :id "delete"
+ :value "Delete"
+ :action 'users-page-delete-users
+ :confirmation-message "Are you sure to delete these items?")))
+
+ (div> :static-id result-container-id
+ (table> :class "listTable"
+ (tr> :class "header"
+ (th> :class "deleteAll" (djcheck-box> :id "deleteAll"
+ ;:reader 'users-page-delete-all
+ :value "all"
+ :onchange(remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node)
+ (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this)))))
+ (th> :class "name" (span> :class (if (string-equal "surname" 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) "surname")
+ (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc"))
+ "desc"
+ "asc"))
+ (setf (slot-value (dojo.by-id ,sorting-column-id) 'value)
+ "surname")
+ (.submit (dijit.by-id ,form-id)))))
+ "Name"))
+ (th> :class "username" (span> :class (if (string-equal "username" 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) "username")
+ (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc"))
+ "desc"
+ "asc"))
+ (setf (slot-value (dojo.by-id ,sorting-column-id) 'value)
+ "username")
+ (.submit (dijit.by-id ,form-id)))))
+ "Username"))
+ (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 "enabled" "Enabled")
+ (th> :class "roles" "Roles"))
+ (loop for user in users
+ for index = 0 then (incf index)
+ collect (tr> :class (if (evenp index) "item even" "item odd")
+ (th> :class "delete" (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'users-page-delete-items
+ :value (table-id user)
+ :translator *integer-translator*
+ :multiple t))
+ (td> (a> :id "edit"
+ :href "#"
+ :on-click (remove #\newline (ps:ps* `(progn (setf (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters)
+ (create "userid" ,(table-id user)))
+ (.click (dijit.by-id ,edit-user-action-link-id)))))
+ (user-surname user)
+ " "
+ (user-firstname user)))
+ (td> (user-username user))
+ (td> (user-email user))
+ (td> :class (if (user-active user)
+ "active"
+ "inactive")
+ (if (user-active user)
+ "yes"
+ "no"))
+ (td> (format nil "~{~a~^, ~}" (loop for role in (user-roles user)
+ collect (role-name (first role))))))))
+ (unless users
+ (djcheck-box> :id "deleteItem"
+ :accessor 'users-page-delete-items
+ :value 0
+ :multiple t
+ :translator *integer-translator*
+ :style "display: none;"))
+ (djaction-link> :static-id edit-user-action-link-id
+ :style "display:none"
+ :action 'users-page-edit-user
+ :update-id (attribute-value (list edit-user-dialog-container-id result-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-user-dialog-id)))))
+ "invisible")
+ (pager> :id "pager"
+ :update-component-id offset-id
+ :page-size (users-page-list-size page)
+ :total-items (users-page-users-total-count page)
+ :first-item-offset (users-page-offset page))))
+ (div> :static-id edit-user-dialog-container-id
+ (djdialog> :static-id edit-user-dialog-id
+ :class "userDialog"
+ :title (users-page-user-edit-dialog-title page)
+ #|
+ (edit-user> :static-id edit-user-form-id
+ :on-close-click (ps:ps* `(.hide (dijit.by-id ,edit-user-dialog-id)))
+ :update-id (attribute-value (list edit-user-form-id result-container-id))
+ :user (users-page-current-user page)
+ :on-before-submit (remove #\newline (ps:ps* `(progn (.show (dijit.by-id ,spinner-id))
+ (dojo.add-class
+ (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node)
+ "hideForm"))))
+ :on-xhr-finish (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id))
+ (dojo.remove-class
+ (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node)
+ "hideForm"))))
+ |#
+ (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-user-form-id))))))
+
+(defmethod users-page-delete-users ((page users-page))
+ (let ((user-id-list (users-page-delete-items page))
+ (surname (users-page-surname page))
+ (firstname (users-page-firstname page))
+ (username (user-username page))
+ (email (users-page-email page))
+ (active (users-page-active page))
+ (roles (users-page-roles page)))
+ (log-message :info "...deleting")
+ (delete-by-id 'user user-id-list)
+ (setf (users-page-delete-items page) ())
+ (multiple-value-bind (users total-size)
+ (find-users :offset (users-page-offset page)
+ :limit (users-page-list-size page)
+ :surname (null-when-empty surname)
+ :firstname (null-when-empty firstname)
+ :username username
+ :email (null-when-empty email)
+ :active active
+ :role-names (null-when-empty roles)
+ :sorting (users-page-sorting page))
+ (setf (users-page-users page) users
+ (users-page-users-total-count page) total-size))))
+
+(defmethod users-page-find-users ((page users-page))
+ (let ((surname (users-page-surname page))
+ (firstname (users-page-firstname page))
+ (username (users-page-username page))
+ (email (users-page-email page))
+ (active (users-page-active page))
+ (roles (users-page-roles page)))
+(log-message :info "èèèè ~a" roles)
+ (multiple-value-bind (users total-size)
+ (find-users :offset (users-page-offset page)
+ :limit (users-page-list-size page)
+ :surname (null-when-empty surname)
+ :firstname (null-when-empty firstname)
+ :username (null-when-empty username)
+ :email (null-when-empty email)
+ :active active
+ :role-names roles
+ :sorting (users-page-sorting page))
+ (log-message :info "xxxx : ~a" users)
+ (setf (users-page-users page) users
+ (users-page-users-total-count page) total-size))))
+
+(defmethod page-before-render ((page users-page))
+ (unless (page-req-parameter page *rewind-parameter*)
+ (multiple-value-bind (users total-size)
+ (find-users :sorting (users-page-sorting page)
+ :offset 0
+ :limit (users-page-list-size page))
+ (setf (users-page-users page) users
+ (users-page-users-total-count page) total-size))))
+
+
+(lisplet-register-function-location *dojo-demo-lisplet*
+ (make-page-renderer 'users-page #'claw-post-parameters #'claw-get-parameters)
+ "users.html")
+
+(lisplet-protect *dojo-demo-lisplet* "users.html" '("administrator" "user"))
+
More information about the Claw-cvs
mailing list