;;; -*- 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-add-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 wcomponent-after-rewind :after ((obj edit-user) (page users-page)) (setf (users-page-current-user page) (edit-user-user obj) (users-page-users page) (list (edit-user-user obj)))) (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)) (if (> user-id 0) (progn (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 (when (string-equal (user-username current-user) "admin") (add-validation-error "user" "User admin is readonly")) (setf (users-page-current-user page) current-user))) (users-page-add-user page)))) (defmethod users-page-add-user ((page users-page)) (let ((current-user (make-instance 'user))) (setf (users-page-user-edit-dialog-title page) "Add new user" (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)))) (defun js-users-clean-excpetions () (ps:ps* '(defun clean-exceptions () (.for-each dojo (.query dojo ".exceptionMonitor") (lambda (em) (.for-each dojo (slot-value em 'child-nodes) (lambda (node) (.remove-child em node)))))))) (defun js-users-add-new-click (edit-user-action-link-id offset-id) (remove #\newline (ps:ps* `(progn (setf (slot-value (.by-id dojo ,offset-id) 'value) 0 (slot-value (dijit.by-id ,edit-user-action-link-id) 'parameters) (create "userid" 0)) (.click (dijit.by-id ,edit-user-action-link-id)))))) (defun js-no-exceptions-p () (ps:ps* '(defun no-exceptions () (defvar validp t) (.for-each dojo (.query dojo ".globalExceptionMonitor") (lambda (el) (when (.has-child-nodes el) (setf validp false)))) (return validp)))) (defun js-users-form-submit (spinner-id edit-user-dialog-id) (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) (when (slot-value (dijit.by-id ,edit-user-dialog-id) 'xhrShow) (setf (slot-value (dijit.by-id ,edit-user-dialog-id) 'xhrShow) false) (when (no-exceptions) (.show (dijit.by-id ,edit-user-dialog-id)))))))) (defun js-users-show-spinner (spinner-id) (remove #\newline (ps:ps* `(progn (clean-exceptions) (.show (dijit.by-id ,spinner-id)))))) (defun js-users-delete-all-on-change () (remove #\newline (ps:ps (.for-each dojo (.map (.query dojo ".deleteItem") dijit.by-node) (lambda (checkbox) (.attr checkbox "checked" (.attr this "checked"))) this)))) (defun js-users-sort (sorting-column-id sorting-order-id form-id offset-id column) (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) ,column) (== (slot-value (dojo.by-id ,sorting-order-id) 'value) "asc")) "desc" "asc") (slot-value (dojo.by-id ,sorting-column-id) 'value) ,column (slot-value (dojo.by-id ,offset-id) 'value) 0) (.submit (dijit.by-id ,form-id)))))) (defun js-users-edit (edit-user-action-link-id user) (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)))))) (defun js-users-action-edit (spinner-id edit-user-dialog-id) (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) (when (no-exceptions) (.show (dijit.by-id ,edit-user-dialog-id))))))) (defun js-users-edit-users-before-submit (spinner-id edit-user-dialog-id) (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"))))) (defun js-users-check-deletion () (ps:ps* '(when (= (slot-value (.query dojo ".dijitCheckBoxChecked > [name='deleteItem']") 'length) 0) (.show-message claw "Message" "No items to delete") (return false)))) (defun js-users-edit-users-xhr-finish (spinner-id edit-user-dialog-id) (remove #\newline (ps:ps* `(progn (.hide (dijit.by-id ,spinner-id)) (dojo.remove-class (slot-value (dijit.by-id ,edit-user-dialog-id) 'container-node) "hideForm"))))) (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")) (exception-monitor> :class "globalExceptionMonitor") (djform> :static-id form-id :class "users" :action 'users-page-find-users :update-id result-container-id :on-before-submit (js-users-show-spinner spinner-id) :on-xhr-finish (js-users-form-submit spinner-id edit-user-dialog-id) (div> (div> :class "searchParameters hlist" (div> :class "item" (span> :class "surname" "Name") (djtext-box> :size 80 :label "name" :id "surname" :accessor 'users-page-surname) (djtext-box> :size 80 :label "name" :id "firstname" :accessor 'users-page-firstname)) (div> :class "item" (span> :class "username" "Username") (djtext-box> :size 80 :label "username" :id "username" :accessor 'users-page-username)) (div> :class "item" (span> :class "email" "Email") (djtext-box> :size 200 :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" :on-click (ps:ps* `(setf (slot-value (.by-id dojo ,offset-id) 'value) 0)) :value "Search") (djbutton> :id "addNew" :on-click (js-users-add-new-click edit-user-action-link-id offset-id) "Add new") (djconfirmation-submit> :id "delete" :value "Delete" :on-click (js-users-check-deletion) :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" :value "all" :onchange (js-users-delete-all-on-change))) (th> :class "name" (span> :class (if (string-equal "surname" sort-field) (if (string-equal "asc" sort-direction) "sort sortAsc" "sort sortDesc") "sort") :on-click (js-users-sort sorting-column-id sorting-order-id form-id offset-id "surname") "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 (js-users-sort sorting-column-id sorting-order-id form-id offset-id "username") "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 (js-users-sort sorting-column-id sorting-order-id form-id offset-id "email") "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" (when (> (table-id user) 1) (djcheck-box> :id "deleteItem" :class "deleteItem" :accessor 'users-page-delete-items :value (table-id user) :translator *integer-translator* :multiple t))) (td> (if (> (table-id user) 1) (a> :id "edit" :href "#" :on-click (js-users-edit edit-user-action-link-id user) (user-surname user) " " (user-firstname user)) (format nil "~a ~a" (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 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 (js-users-show-spinner spinner-id) :on-xhr-finish (js-users-action-edit spinner-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 (js-users-edit-users-before-submit spinner-id edit-user-dialog-id) :on-xhr-finish (js-users-edit-users-xhr-finish spinner-id edit-user-dialog-id)) (exception-monitor> :id "exceptionMonitor" :json-render-on-validation-errors-p edit-user-form-id))) (script> :type "text/javascript" (js-users-clean-excpetions) (js-no-exceptions-p))))) (defmethod users-page-delete-users ((page users-page)) (let ((user-id-list (remove-if #'(lambda (item) (= item 1)) (users-page-delete-items page))) (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 "...deleting users ~a" user-id-list) (when user-id-list (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 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"))