;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/frontend/components/edit-user.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 edit-user-save (edit-user)) (defclass edit-user (djform) ((user :initarg :user :accessor edit-user-user) (password :initarg :password :accessor edit-user-password) (user-id-parameter :initarg :user-id-parameter :accessor edit-user-user-id-parameter) (assigned-roles :initform () :accessor edit-user-assigned-roles) (on-close-click :initarg :on-close-click :accessor edit-user-on-close-click)) (:metaclass metacomponent) (:default-initargs :on-close-click nil :class "userForm" :user-id-parameter "userid" :user nil :password nil)) (defmethod initialize-instance :after ((obj edit-user) &key rest) (declare (ignore rest)) (setf (action-object obj) obj (action obj) 'edit-user-save)) (defmethod wcomponent-created :after ((obj edit-user)) (setf (edit-user-assigned-roles obj) (and (edit-user-user obj) (loop for role in (user-roles (edit-user-user obj)) collect (table-id role))))) (defun unused-roles (user) (remove-if #'(lambda (role) (find role (user-roles user) :test #'records-equal)) (find-vo 'role :order-by (list (slot-column-name 'role "name"))))) (defun edit-user-roles-can-drop (css-class-name) `(progn (defvar m (.manager (slot-value dojo 'dnd))) (when (slot-value m 'source) (.can-drop m (.has-class dojo (slot-value (slot-value m 'source) 'node) ,css-class-name))))) (defun edit-user-check-nodes (checked-p) `(progn (defvar m (.manager (slot-value dojo 'dnd))) (.for-each dojo nodes (lambda (node-el) (.for-each dojo (.query dojo "input" node-el) (lambda (input-el) (setf (slot-value input-el 'checked) ,checked-p))))))) (defmethod htcomponent-body ((obj edit-user)) (let* ((visit-object (edit-user-user obj)) (assigned-roles-container-id (generate-id "assignedRolesContainer")) (available-roles-container-id (generate-id "availableRolesContainer"))) (list (cinput> :id (edit-user-user-id-parameter obj) :type "hidden" :visit-object visit-object :translator *integer-translator* :accessor 'table-id) (cinput> :id "tabbleVersion" :type "hidden" :visit-object visit-object :translator *integer-translator* :accessor 'table-version) (div> :class "label username" (span> "Username") (djvalidation-text-box> :visit-object visit-object :required "true" :label "Username" :size 80 :accessor 'user-username)) (div> :class "label surname" (span> "Surname") (djvalidation-text-box> :visit-object visit-object :required "true" :label "Surname" :size 80 :accessor 'user-surname)) (div> :class "label firstname" (span> "First name") (djvalidation-text-box> :visit-object visit-object :label "First name" :size 80 :accessor 'user-firstname)) (div> :class "label email" (span> "Email") (djvalidation-text-box> :visit-object visit-object :label "Email" :size 200 :accessor 'user-email)) (div> :class "label active" (span> "Active") (djcheck-box> :id "userActive" :visit-object visit-object :label "Active" :translator *boolean-translator* :value t :multiple nil :accessor 'user-active)) (djxpassword-validator> :id "password" :class "label password" :required nil :visit-object obj :label "Password" :type "password" :size 100 :accessor 'edit-user-password (div> :class "label" (span> "Password") (djxpassword-new>)) (div> :class "label" (span> "Confirm password") (djxpassword-verify>))) (div> :class "userRolesRow" (djdnd-source> :static-id available-roles-container-id :class "userRolesContainer availableRoles" :tag-name "fieldset" (script> :type "dojo/connect" :event "onMouseMove" :args "e" (ps:ps* `,(edit-user-roles-can-drop "userRoles"))) (script> :type "dojo/connect" :event "onDndDrop" :args "source, nodes, copy, target" (ps:ps* `(when (= target.id ,available-roles-container-id) ,(edit-user-check-nodes 'false)))) (legend> "Available roles") (loop for role in (unused-roles visit-object) collect (djdnd-item> (role-name role) (ccheckbox> :id "userRole" :visit-object obj :translator *integer-translator* :value (table-id role) :accessor 'edit-user-assigned-roles)))) (djdnd-source> :static-id assigned-roles-container-id :class "userRolesContainer userRoles" :tag-name "fieldset" (script> :type "dojo/connect" :event "onMouseMove" :args "e" (ps:ps* `,(edit-user-roles-can-drop "availableRoles"))) (script> :type "dojo/connect" :event "onDndDrop" :args "source, nodes, copy, target" (ps:ps* `(when (= target.id ,assigned-roles-container-id) ,(edit-user-check-nodes t)))) (legend> "Assigned roles") (loop for role in (user-roles visit-object) collect (djdnd-item> (role-name role) (ccheckbox> :id "userRole" :visit-object obj :translator *integer-translator* :value (table-id role) :accessor 'edit-user-assigned-roles))))) (div> :class "buttons" (djsubmit-button> :value "Save") (djbutton> :render-condition #'(lambda () (edit-user-on-close-click obj)) :id "Close" :on-click (edit-user-on-close-click obj) "Close"))))) (defmethod wcomponent-before-rewind :before ((obj edit-user) (page page)) (when (string-equal (htcomponent-client-id obj) (claw-parameter *rewind-parameter*)) (let ((user-id (parse-integer (claw-parameter (edit-user-user-id-parameter obj))))) (setf (edit-user-user obj) (if (> user-id 0) (find-by-id 'user user-id) (make-instance 'user)))))) (defmethod edit-user-save ((obj edit-user)) (let ((id (htcomponent-client-id obj)) (user (edit-user-user obj)) (roles (find-roles-by-ids :ids (edit-user-assigned-roles obj))) (password (edit-user-password obj))) (handler-case (progn (setf (user-roles user) roles) (when password (setf (user-password user) password)) (update-db-item user) (setf (edit-user-password obj) nil)) (clsql-sys:sql-database-error (cond) (log-message :info "Exception on edit-user-save: ~a" cond) (add-validation-error id (clsql-sys:sql-error-database-message cond)) nil))))