[claw-cvs] r72 - in trunk/main/claw-demo: . src src/backend src/frontend src/frontend/docroot src/frontend/docroot/css src/frontend/docroot/img test
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Tue Aug 26 10:57:08 UTC 2008
Author: achiumenti
Date: Tue Aug 26 06:57:00 2008
New Revision: 72
Added:
trunk/main/claw-demo/
trunk/main/claw-demo/claw-demo.asd
trunk/main/claw-demo/src/
trunk/main/claw-demo/src/backend/
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/setup.lisp
trunk/main/claw-demo/src/backend/vo.lisp
trunk/main/claw-demo/src/frontend/
trunk/main/claw-demo/src/frontend/auth.lisp
trunk/main/claw-demo/src/frontend/commons.lisp
trunk/main/claw-demo/src/frontend/customers.lisp
trunk/main/claw-demo/src/frontend/docroot/
trunk/main/claw-demo/src/frontend/docroot/css/
trunk/main/claw-demo/src/frontend/docroot/css/style.css
trunk/main/claw-demo/src/frontend/docroot/img/
trunk/main/claw-demo/src/frontend/docroot/img/bg.png (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/claw.png (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/clawDemo.png (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.gif (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.png (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/img/spinner.gif (contents, props changed)
trunk/main/claw-demo/src/frontend/docroot/spinner.gif (contents, props changed)
trunk/main/claw-demo/src/frontend/index.lisp
trunk/main/claw-demo/src/frontend/login.lisp
trunk/main/claw-demo/src/frontend/logout.lisp
trunk/main/claw-demo/src/frontend/main.lisp
trunk/main/claw-demo/src/frontend/packages.lisp
trunk/main/claw-demo/test/
Log:
CLAW demo application
Added: trunk/main/claw-demo/claw-demo.asd
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/claw-demo.asd Tue Aug 26 06:57:00 2008
@@ -0,0 +1,74 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: claw-demo.asd $
+
+;;; 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.
+
+(asdf:defsystem :claw-demo-test-backend
+ :components ((:module "test"
+ :components ((:module backend
+ :components ((:file "tests"))))))
+ :depends-on (:claw-demo-backend :lift))
+
+(asdf:defsystem :claw-demo-backend
+ :name "claw-demo-backend"
+ :author "Andrea Chiumenti"
+ :description "Demo application for claw, backend part."
+ :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence)
+ :components ((:module src
+ :components ((:module backend
+ :components ((:file "packages")
+ (:file "vo" :depends-on ("packages"))
+ (:file "setup" :depends-on ("packages" "vo"))
+ (:file "dao" :depends-on ("vo" "setup"))
+ (:file "service" :depends-on ("dao"))))))))
+
+(asdf:defsystem :claw-demo-frontend
+ :name "claw-demo-frontend"
+ :author "Andrea Chiumenti"
+ :description "Demo application for claw, frontend part."
+ :depends-on (:local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend)
+ :components ((:module src
+ :components ((:module frontend
+ :components ((:file "packages")
+ (:file "auth" :depends-on ("packages"))
+ (:file "commons" :depends-on ("packages"))
+ (:file "main" :depends-on ("packages" "auth"))
+ (:file "index" :depends-on ("commons" "main"))
+ (:file "logout" :depends-on ("commons" "main"))
+ (:file "login" :depends-on ("commons" "main"))
+ (:file "customers" :depends-on ("commons" "main"))))))))
+
+
+(asdf:defsystem :claw-demo
+ :name "claw-demo"
+ :author "Andrea Chiumenti"
+ :description "Demo application for claw."
+ :in-order-to ((test-op (load-op :claw-demo-test-backend)))
+ :perform (test-op :after (op c)
+ (describe (funcall (find-symbol "RUN-TESTS" "LIFT")
+ :suite (find-symbol "CLAW-DEMO-BACKEND-TESTSUITE" "CLAW-DEMO-BACKEND"))))
+ :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :claw-demo-backend :claw-demo-frontend))
Added: trunk/main/claw-demo/src/backend/dao.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/backend/dao.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,166 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/dao.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-backend)
+
+(defgeneric check-instance-version (base-table &key database)
+ (:documentation "Versioning support for base-table instances"))
+
+(defgeneric sign-table-update (base-table)
+ (:documentation "Set insert/modify user and date to the given record"))
+
+
+(defgeneric local-time-to-timestamp (local-time))
+
+(defmethod local-time-to-timestamp ((local-time local-time))
+ (with-decoded-local-time (:sec sec :minute minute :hour hour :day day :month month :year year)
+ local-time
+ (make-time
+ :year year :month month :day day :hour hour :minute minute :second sec)))
+
+(defmethod sign-table-update ((base-table base-table))
+ (let ((user-name (or (and *clawserver*
+ (current-principal)
+ (principal-name (current-principal)))
+ "anonymous"))
+ (now-timestamp (local-time-to-timestamp (now))))
+ (when (null (table-insert-user base-table))
+ (setf (table-insert-user base-table) user-name
+ (table-insert-date base-table) now-timestamp))
+ (setf (table-update-user base-table) user-name
+ (table-update-date base-table) now-timestamp)))
+
+
+(defun slot-column-name (symbol-class slot-name)
+ (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))
+ return slot)))
+ (when slot
+ (slot-value slot 'clsql-sys::column))))
+
+(defun sql-expression-upper (&key string table alias attribute type)
+ (sql-operation 'upper (sql-expression :string string :table table :alias alias :attribute attribute :type type)))
+
+#.(locally-enable-sql-reader-syntax)
+
+(defmethod check-instance-version ((instance base-table) &key (database *default-database*))
+ (let* ((instance-version (table-version instance))
+ (table (view-table (class-of instance)))
+ (instance-id (table-id instance))
+ (version (first (select [version]
+ :from table
+ :where [= [id] instance-id]
+ :flatp t
+ :refresh t
+ :database database))))
+ (when (and version (not (= version instance-version)))
+ (error "Wrong version number (given ~d , expected ~d) for record id ~d on table ~a"
+ instance-version
+ version
+ instance-id
+ table))))
+
+(defmethod delete-instance-records :before ((instance base-table))
+ (check-instance-version instance :database (clsql-sys::view-database instance)))
+
+
+
+(defmethod update-records-from-instance :before ((instance base-table) &key (database *default-database*))
+ (check-instance-version instance :database database)
+ (sign-table-update instance)
+ (if (and (slot-boundp instance 'id) (not (null (table-id instance))))
+ (incf (table-version instance))
+ (unless (typep instance 'base-table-121)
+ (let ((sequence-name (format nil
+ "~a_id_seq"
+ (string-downcase (symbol-name (view-table (class-of instance)))))))
+ (setf (table-id instance) (sequence-next sequence-name :database database))))))
+
+(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *default-database*))
+ (declare (ignore slot database))
+ (check-instance-version instance))
+
+
+(defmethod update-records-from-instance :before ((instance user) &key (database *default-database*))
+ (let ((id (table-id instance)))
+ (when id
+ (delete-records :from [users-roles] :where [= [user-id] id]))))
+
+(defmethod update-records-from-instance :after ((instance user) &key (database *default-database*))
+ (let ((id (table-id instance)))
+ (dolist (role (user-roles instance))
+ (update-records-from-instance (make-instance 'user-role :user-id id :role-id (table-id role))))))
+
+
+(defmethod update-records-from-instance :before ((instance customer) &key (database *default-database*))
+ (let ((id (table-id instance)))
+ (when id
+ (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+
+(defmethod update-records-from-instance :after ((instance customer) &key (database *default-database*))
+ (let ((id (table-id instance)))
+ (dolist (address (customer-addresses instance))
+ (setf (customer-address-customer-id address) id)
+ (update-records-from-instance address))))
+
+(defmethod delete-instance-records :before ((instance user))
+ (let ((id (table-id instance)))
+ (when id
+ (delete-records :from [users-roles] :where [= [user-id] id]))))
+
+
+(defmethod delete-instance-records :before ((instance customer))
+ (let ((id (table-id instance)))
+ (when id
+ (delete-records :from [customer-addresses] :where [= [customer-id] id]))))
+
+(defmethod delete-instance-records :before ((instance role))
+ (let ((id (table-id instance)))
+ (when id
+ (delete-records :from [users-roles] :where [= [role-id] id]))))
+
+(defun like-operation (name value &key (insensitive t) (wild-char #\*))
+ (setf value (format nil "~{~A~^\\\\~}" (split-sequence #\\ value)))
+ (unless (eql wild-char #\%)
+ (setf value (format nil "~{~A~^\\%~}" (split-sequence #\% value))))
+ (let ((v (if (eql wild-char #\%)
+ value
+ (substitute #\% wild-char value)))
+ (result))
+ (setf result (sql-operation 'LIKE
+ (if insensitive
+ (sql-operation 'UPPER name)
+ name)
+ (if insensitive
+ (sql-operation 'UPPER v)
+ v)))
+ result))
+
+#.(locally-disable-sql-reader-syntax)
\ No newline at end of file
Added: trunk/main/claw-demo/src/backend/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/backend/packages.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,102 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/package.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 :cl-user)
+
+
+(defpackage :claw-demo-backend
+ (:use :cl :clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence)
+ (:shadowing-import-from :local-time
+ :timezone
+ :decode-duration
+ :format-duration
+ :parse-datestring
+ :universal-time
+ :parse-timestring)
+ (:documentation "A demo application for CLAW")
+ (:export #:demo-setup
+ #:db-connect
+ #:db-disconnect
+ ;; --- Value objects --- ;;
+ #:base-table
+ #:table-id
+ #:table-version
+ #:table-update-user
+ #:table-insert-user
+ #:table-update-date
+ #:table-insert-date
+ #:user
+ #:user-firstname
+ #:user-surname
+ #:user-username
+ #:user-email
+ #:user-password
+ #:user-active
+ #:user-roles
+ #:role
+ #:role-name
+ #:role-description
+ #:role-users
+ #:city
+ #:city-name
+ #:city-zip
+ #:city-iso-state
+ #:city-iso-country
+ #:city-alt-code
+ #:customer
+ #:customer-name1
+ #:customer-name2
+ #:customer-email
+ #:customer-phone1
+ #:customer-phone2
+ #:customer-phone3
+ #:customer-fax
+ #:customer-addresses
+ #:customer-vat
+ #:customer-vat
+ #:customer-code1
+ #:customer-code2
+ #:customer-code3
+ #:customer-code4
+ #:customer-address
+ #:customer-address-name1
+ #:customer-address-name2
+ #:customer-address-address-type
+ #:customer-address-address
+ #:customer-address-city
+ #:customer-address-zip
+ #:customer-address-state
+ #:customer-address-country
+ ;; --- Business methods --- ;;
+ #:update-db-item
+ #:delete-db-item
+ #:reload-db-item
+ #:delete-class-records
+ #:find-user-by-name
+ #:find-customers))
\ No newline at end of file
Added: trunk/main/claw-demo/src/backend/service.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/backend/service.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,121 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/service.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-backend)
+
+(defvar *select-limit* 1000000)
+
+(defgeneric update-db-item (base-table)
+ (:documentation "Updates or inserts an item in a transaction aware context"))
+
+(defgeneric delete-db-item (base-table)
+ (:documentation "Deletes an item in a transaction aware context"))
+
+(defgeneric reload-db-item (base-table)
+ (:documentation "Reloads an item."))
+
+#.(locally-enable-sql-reader-syntax)
+
+(defmethod update-db-item ((item base-table))
+ (with-transaction (:database *claw-demo-db*)
+ (update-records-from-instance item)))
+
+(defmethod delete-db-item ((item base-table))
+ (with-transaction (:database *claw-demo-db*)
+ (delete-instance-records item)))
+
+(defun delete-class-records (symbol-class &key where)
+ (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 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
+ (select symbol-class
+ :where where
+ :group-by group-by
+ :having having
+ :order-by order-by
+ :flatp t
+ :refresh refresh
+ :offset offset
+ :limit limit)
+ (count-vo symbol-class :refresh refresh :where where :group-by group-by :having having)))
+
+(defun count-vo (symbol-class &key (refresh t) where group-by having)
+ "Returns the number of records matching the given criteria"
+ (first (select [count [*]]
+ :from (view-table (find-class symbol-class))
+ :where where
+ :group-by group-by
+ :having having
+ :flatp t
+ :refresh refresh)))
+
+(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))))
+
+(defun find-user-by-name (name)
+ (let ((where (sql-operation '= (slot-column-name 'user 'username) name)))
+ (first (select 'user
+ :where where
+ :flatp t
+ :refresh t))))
+
+(defun find-customers (&key (offset 0) (limit *select-limit*) name1 name2 email vat phone sorting)
+ (let ((where (remove-if #'null (list
+ (when name1
+ (like-operation (slot-column-name 'customer 'name1)
+ name1))
+ (when name2
+ (like-operation (slot-column-name 'customer 'name2)
+ name2))
+ (when email
+ (like-operation (slot-column-name 'customer 'email)
+ email))
+ (when vat
+ (sql-operation '= (slot-column-name 'customer 'vat)
+ vat))
+ (when phone
+ (sql-operation '= (slot-column-name 'customer 'phone1)
+ phone))))))
+ (find-vo 'customer :offset offset
+ :limit limit
+ :where (if (> (length where) 1)
+ (apply #'sql-operation (cons 'and where))
+ (first where)))))
+
+#.(locally-disable-sql-reader-syntax)
\ No newline at end of file
Added: trunk/main/claw-demo/src/backend/setup.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/backend/setup.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,106 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/setup.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-backend)
+
+(defvar *claw-demo-db* nil
+ "The demo datebase")
+
+(defun db-connect (&optional (connection-string '("127.0.0.1" "claw-demo" "claw-demo" "demo")))
+ (setf *claw-demo-db* (connect connection-string :database-type :postgresql :pool t)))
+
+(defun db-disconnect ()
+ (disconnect :database *claw-demo-db*))
+
+
+(defun create-claw-demo-tables ()
+ (let ((*default-database* *claw-demo-db*))
+ (create-view-from-class 'user-role)
+ (create-view-from-class 'user)
+ (create-view-from-class 'role)
+ (let ((user-role-table (symbol-name (view-table (find-class 'user-role)))))
+ (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk1 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE"
+ user-role-table
+ user-role-table
+ (slot-column-name 'user-role 'user-id)
+ (symbol-name (view-table (find-class 'user)))))
+ (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk2 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE"
+ user-role-table
+ user-role-table
+ (slot-column-name 'user-role 'role-id)
+ (symbol-name (view-table (find-class 'role))))))
+ (create-view-from-class 'city)
+ (create-view-from-class 'customer)
+ (create-view-from-class 'customer-address)
+ (let ((customer-address-table (symbol-name (view-table (find-class 'customer-address)))))
+ (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk1 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE"
+ customer-address-table
+ customer-address-table
+ (slot-column-name 'customer-address 'customer-id)
+ (symbol-name (view-table (find-class 'customer))))))))
+
+(defun drop-claw-demo-tables ()
+ (let ((*default-database* *claw-demo-db*)
+ (user-role-table (symbol-name (view-table (find-class 'user-role))))
+ (customer-address-table (symbol-name (view-table (find-class 'customer-address)))))
+ (dolist (table (list-tables))
+ (execute-command (format nil "DROP TABLE ~a CASCADE" table)))
+ (dolist (sequence (list-sequences))
+ (execute-command (format nil "DROP SEQUENCE ~a" sequence)))))
+
+(defun demo-setup ()
+ (db-connect)
+ (drop-claw-demo-tables)
+ (create-claw-demo-tables)
+ (with-transaction ()
+ (let ((admin-role (make-instance 'role :name "administrator"))
+ (user-role (make-instance 'role :name "user")))
+ (update-db-item admin-role)
+ (update-db-item user-role)
+ (update-db-item (make-instance 'user :firstname "Andrea"
+ :surname "Chiumenti"
+ :username "admin"
+ :password "admin"
+ :email "admin at new.com"
+ :roles (list admin-role user-role)))
+ (loop for i from 1 to 400
+ do (update-db-item (make-instance 'customer
+ :name1 (format nil "Andrea~a" i)
+ :name2 (format nil "Chiumenti~a" i)
+ :email (format nil "a~a.chiumenti at new.com" i)
+ :phone1 "+393900001"
+ :phone2 "+393900002"
+ :phone3 "+393900003"
+ :fax "+393900010"
+ :vat (format nil "9999999999-~a" i)
+ :code1 (format nil "code1-~a" i)
+ :code1 (format nil "code2-~a" i)
+ :code1 (format nil "code3-~a" i)
+ :code1 (format nil "code4-~a" i))))))
+ (db-disconnect))
\ No newline at end of file
Added: trunk/main/claw-demo/src/backend/vo.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/backend/vo.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,267 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/vo.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-backend)
+
+(def-view-class base-table ()
+ ((id :db-kind :key
+ :accessor table-id
+ :initarg :id
+ :type integer
+ :db-type "serial"
+ :db-constraints :not-null)
+ (version :accessor table-version
+ :initarg :version
+ :type integer
+ :db-constraints :not-null)
+ (update-user :accessor table-update-user
+ :initarg :update-user
+ :type (varchar 80))
+ (insert-user :accessor table-insert-user
+ :initarg :insert-user
+ :type (varchar 80))
+ (update-date :accessor table-update-date
+ :initarg :update-date
+ :type wall-time)
+ (insert-date :accessor table-insert-date
+ :initarg :insert-date
+ :type wall-time))
+ (:default-initargs :id nil
+ :version 0
+ :update-user nil
+ :insert-user nil
+ :update-date nil
+ :insert-date nil))
+
+(def-view-class base-table-121 (base-table)
+ ((id :db-kind :key
+ :accessor table-id
+ :initarg :id
+ :type integer
+ :db-constraints :not-null)))
+
+(def-view-class user-role ()
+ ((user-id :db-kind :key
+ :initarg :user-id
+ :accessor user-role-user-id
+ :type integer
+ :db-constraints :not-null)
+ (role-id :db-kind :key
+ :initarg :role-id
+ :accessor user-role-role-id
+ :type integer
+ :db-constraints :not-null)
+ (users :db-kind :join
+ :accessor user-role-users
+ :db-info (:join-class user
+ :home-key user-id
+ :foreign-key id
+ :retrieval :immediate
+ :set t))
+ (roles :db-kind :join
+ :accessor user-role-roles
+ :db-info (:join-class role
+ :home-key role-id
+ :foreign-key id
+ :retrieval :immediate
+ :set t)))
+ (:base-table users-roles))
+
+(def-view-class user (base-table)
+ ((firstname :initarg :firstname
+ :accessor user-firstname
+ :type (varchar 80)
+ :db-constraints :not-null)
+ (surname :initarg :surname
+ :accessor user-surname
+ :type (varchar 80)
+ :db-constraints :not-null)
+ (username :initarg :username
+ :accessor user-username
+ :type (varchar 80)
+ :db-constraints :not-null)
+ (email :initarg :email
+ :accessor user-email
+ :type (varchar 200)
+ :db-constraints :not-null)
+ (password :initarg :password
+ :accessor user-password
+ :type (varchar 100)
+ :db-constraints :not-null)
+ (active :initarg :active
+ :accessor user-active
+ :type boolean
+ :db-constraints :not-null)
+ (roles :db-kind :join
+ :initarg :roles
+ :accessor user-roles
+ :db-info (:join-class user-role
+ :home-key id
+ :foreign-key user-id
+ :target-slot roles
+ :set t)))
+ (:default-initargs :active t)
+ (:base-table users))
+
+(def-view-class role (base-table)
+ ((name :initarg :name
+ :accessor role-name
+ :type (varchar 20)
+ :db-constraints :not-null)
+ (description :initarg :description
+ :accessor role-description
+ :type (varchar 200))
+ (users :db-kind :join
+ :accessor role-users
+ :db-info (:join-class user-role
+ :home-key id
+ :foreign-key role-id
+ :target-slot users
+ :set t)))
+ (:default-initargs :description "")
+ (:base-table roles))
+
+
+(def-view-class city (base-table)
+ ((city-name :initarg :name
+ :accessor city-name
+ :type (varchar 120)
+ :db-constraints :not-null)
+ (zip :initarg :zip
+ :accessor city-zip
+ :type (string 5)
+ :db-constraints :not-null)
+ (iso-state :initarg :iso-state
+ :accessor city-iso-state
+ :type (string 5)) ;ISO_3166-2
+ (iso-country :initarg :isocountry
+ :accessor city-iso-country
+ :type (string 3)) ;ISO_3166-1 Alpha-3
+ (alt-code :initarg :alt-code
+ :accessor city-alt-code
+ :type (varchar 50)))
+ (:default-initargs :iso-state nil :iso-country nil
+ :alt-code nil)
+ (:base-table cities))
+
+
+(def-view-class customer (base-table)
+ ((name1 :initarg :name1
+ :accessor customer-name1
+ :type (varchar 150)
+ :db-constraints :not-null)
+ (name2 :initarg :name2
+ :accessor customer-name2
+ :type (varchar 80))
+ (email :initarg :email
+ :accessor customer-email
+ :type (varchar 200))
+ (phone1 :initarg :phone1
+ :accessor customer-phone1
+ :type (varchar 25))
+ (phone2 :initarg :phone2
+ :accessor customer-phone2
+ :type (varchar 25))
+ (phone3 :initarg :phone3
+ :accessor customer-phone3
+ :type (varchar 25))
+ (fax :initarg :fax
+ :accessor customer-fax
+ :type (varchar 25))
+ (addresses :db-kind :join
+ :initarg :addresses
+ :accessor customer-addresses
+ :db-info (:join-class customer-address
+ :home-key id
+ :foreign-key customer-id
+ :retrieval :deferred
+ :set t))
+ (vat :initarg :vat
+ :accessor customer-vat
+ :type (varchar 50)
+ :db-constraints :unique)
+ (code1 :initarg :code1
+ :accessor customer-code1
+ :type (varchar 50)
+ :db-constraints :unique)
+ (code2 :initarg :code2
+ :accessor customer-code2
+ :type (varchar 50)
+ :db-constraints :unique)
+ (code3 :initarg :code3
+ :type (varchar 50)
+ :accessor customer-code3
+ :db-constraints :unique)
+ (code4 :initarg :code4
+ :accessor customer-code4
+ :type (varchar 50)
+ :db-constraints :unique))
+ (:default-initargs :name2 nil :email nil
+ :phone1 nil :phone2 nil :phone3 nil
+ :fax nil
+ :vat nil :code1 nil :code2 nil :code3 nil :code4 nil)
+ (:base-table customers))
+
+(def-view-class customer-address (base-table)
+ ((address-type :initarg :address-type
+ :accessor customer-address-type
+ :type integer
+ :db-constraints :not-null)
+ (address :initarg :address
+ :accessor customer-address-address
+ :type (varchar 200)
+ :db-constraints :not-null)
+ (city :initarg :city
+ :accessor customer-address-city
+ :type (varchar 120)
+ :db-constraints :not-null)
+ (zip :initarg :zip
+ :accessor customer-address-zip
+ :type (string 5)
+ :db-constraints :not-null)
+ (state :initarg :state
+ :accessor customer-address-state
+ :type (varchar 120)
+ :db-constraints :not-null)
+ (country :initarg :country
+ :accessor customer-address-country
+ :type (varchar 80)
+ :db-constraints :not-null)
+ (customer-id :initarg :customer-id
+ :accessor customer-address-customer-id
+ :type integer
+ :db-constraints :not-null)
+ (customer :initarg :customer
+ :db-info (:join-class customer
+ :home-key customer-id
+ :foreign-key id
+ :retrieval :immediate
+ :set nil)))
+ (:default-initargs :address-type 0)
+ (:base-table customer-addresses))
Added: trunk/main/claw-demo/src/frontend/auth.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/auth.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,63 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/auth.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)
+
+(defclass demo-principal (principal)
+ ((firstname :initarg :firstname
+ :accessor demo-principal-firstname)
+ (surname :initarg :surname
+ :accessor demo-principal-surname))
+ (:default-initargs :firstname "" :surname ""))
+
+(defclass demo-configuration (configuration)
+ ()
+ (:documentation "Authorization configuration for application
+atuhentication and authorization management."))
+
+(defmethod configuration-login ((configuration configuration))
+ (multiple-value-bind (user password)
+ (if (eq (lisplet-authentication-type *claw-current-lisplet*) :basic)
+ (claw-authorization)
+ (values (claw-parameter "username")
+ (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)
+ :surname (user-surname user-vo)
+ :roles (loop for role-vo in (user-roles user-vo)
+ collect (role-name (first role-vo)))))))
+ (db-disconnect))))
\ No newline at end of file
Added: trunk/main/claw-demo/src/frontend/commons.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/commons.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,223 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/commons.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)
+
+
+
+
+(defclass site-template (wcomponent)
+ ((title :initarg :title
+ :reader site-template-title)
+ (djconfig :initarg :djconfig
+ :reader site-template-djconfig))
+ (:metaclass metacomponent)
+ (:default-initargs :djconfig nil))
+
+(defclass redirect (wcomponent)
+ ((href :initarg :href
+ :reader redirect-href))
+ (:metaclass metacomponent))
+
+(defmethod htcomponent-instance-initscript ((redirect redirect))
+ (ps:ps* `(location.replace ,(redirect-href redirect))))
+
+(defmethod wcomponent-template ((redirect redirect))
+ ($> ""))
+
+(defun current-site-template ()
+ (claw-aux-request-value 'site-template))
+
+(defmethod wcomponent-template ((site-template site-template))
+ (let ((principal (current-principal)))
+ (html>
+ (head>
+ (title> (site-template-title site-template))
+ (link> :href (format nil "~a/docroot/css/style.css" (build-lisplet-location *claw-current-lisplet*))
+ :rel "stylesheet"
+ :type "text/css"))
+ (djbody> :is-debug "false"
+ :theme "soria"
+ :class "demo"
+ :djconfig (site-template-djconfig site-template)
+ (wcomponent-informal-parameters site-template)
+ (div> :class "topheader"
+ (div> :class "logoDemo")
+ (div> :class "logoClaw"))
+ (djtoolbar> :id "menuBar" :class "menuBar"
+ (djdrop-down-button> (span> "File")
+ (djmenu>
+ (djmenu-item> :id "loginMenu"
+ :render-condition #'(lambda () (null principal))
+ :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" (build-lisplet-location *claw-current-lisplet*))))
+ "Login")
+ (djmenu-item> :id "logoutMenu"
+ :render-condition #'(lambda () principal)
+ :on-click (ps:ps* `(location.replace ,(format nil "~a/logout.html" (build-lisplet-location *claw-current-lisplet*))))
+ "Logout")))
+ (djdrop-down-button> :render-condition #'(lambda () principal)
+ (span> "Anagraphics")
+ (djmenu>
+ (djmenu-item> :id "customersMenu"
+ :on-click (ps:ps* `(location.replace ,(format nil "~a/customers.html" (build-lisplet-location *claw-current-lisplet*))))
+ "Customers")
+ (djmenu-item> :id "usersMenu"
+ :render-condition #'(lambda () (user-in-role-p '("admin")))
+ "Users"))))
+ (div> :class "contentBody"
+ (htcomponent-body site-template))))))
+
+(defclass db-page (page)
+ ())
+
+(defmethod page-render :around ((db-page db-page))
+ (let ((result))
+ (unwind-protect (progn
+ (db-connect)
+ (setf result (call-next-method)))
+ (db-disconnect))
+ result))
+
+
+
+(defgeneric pager-count-pages (pager))
+
+(defgeneric pager-current-page (pager))
+
+(defgeneric pager-page-list (pager))
+
+(defgeneric set-offset-value (pager page))
+
+(defclass pager (wcomponent)
+ ((update-component-id :initarg :update-component-id
+ :accessor pager-update-component-id)
+ (class :initarg :class
+ :reader pager-class)
+ (page-size :initarg :page-size
+ :reader pager-page-size)
+ (visible-pages :initarg :visible-pages
+ :accessor pager-visible-pages)
+ (total-items :initarg :total-items
+ :accessor pager-total-items)
+ (first-item-offset :initarg :first-item-offset
+ :accessor pager-first-item-offset))
+ (:metaclass metacomponent)
+ (:default-initargs :page-size 10 :visible-pages 10 :class "pager"))
+
+(defmethod wcomponent-template ((pager pager))
+ (let ((total-items (pager-total-items pager))
+ (page-size (pager-page-size pager))
+ (page-list (pager-page-list pager))
+ (current-page (pager-current-page pager))
+ (count-pages (pager-count-pages pager))
+ (id (htcomponent-client-id pager)))
+ (when (> total-items page-size)
+ (div>
+ :static-id id
+ :class (pager-class pager)
+ (wcomponent-informal-parameters pager)
+
+ (when (> current-page 1)
+ (list (div> :class "button first"
+ (span> :on-click (set-offset-value pager 1) "first"))
+ (div> :class "button previous"
+ (span> :on-click (set-offset-value pager (1- current-page)) "previous"))))
+ (loop for page in page-list
+ collect (if (= page current-page)
+ (div> :class "current page"
+ (span> (format nil "~a" page)))
+ (div> :class "page" (span> :on-click (set-offset-value pager page) (format nil "~a" page)))))
+ (when (< current-page count-pages)
+ (list (div> :class "button next"
+ (span> :on-click (set-offset-value pager (1+ current-page)) "next"))
+ (div> :class "button last"
+ (span> :on-click (set-offset-value pager count-pages) "last"))))))))
+
+(defmethod htcomponent-class-initscripts ((pager pager))
+ (let ((update-component-id (pager-update-component-id pager))
+ (page-size (pager-page-size pager)))
+ (list
+ (ps:ps* `(defun pager-go-to (page)
+ (setf (slot-value (dojo.by-id ,update-component-id) 'value) (* (1- page) ,page-size))
+ (defvar form-id (slot-value (slot-value (dojo.by-id ,update-component-id) 'form) 'id))
+ (let ((form-el (or (dijit.by-id form-id)
+ (dojo.by-id form-id))))
+ (.submit form-el)))))))
+
+(defmethod set-offset-value ((pager pager) page)
+ (ps:ps* `(pager-go-to ,page)))
+
+(defmethod pager-count-pages ((pager pager))
+ (let ((page-size (pager-page-size pager))
+ (total-items (pager-total-items pager)))
+ (count-pages page-size total-items)))
+
+(defun count-pages (page-size total-items)
+ (multiple-value-bind (pages rest)
+ (truncate total-items page-size)
+ (when (> rest 0) (incf pages))
+ pages))
+
+(defmethod pager-current-page ((pager pager))
+ (let ((page-size (pager-page-size pager))
+ (first-item-offset (pager-first-item-offset pager)))
+ (multiple-value-bind (page rest)
+ (truncate (1+ first-item-offset) page-size)
+ (when (> rest 0) (incf page))
+ page)))
+
+(defmethod pager-page-list ((pager pager))
+ (let ((current-page (pager-current-page pager))
+ (count-pages (pager-count-pages pager))
+ (visible-pages (pager-visible-pages pager))
+ (pages-before-current-page)
+ (pages-after-current-page)
+ (result))
+ (when (> current-page 1)
+ (setf pages-before-current-page
+ (reverse
+ (loop for page from (1- current-page) downto (max 1 (- current-page
+ (truncate visible-pages 2)))
+ collect page))))
+ (when (< current-page count-pages)
+ (setf pages-after-current-page
+ (loop for page from (1+ current-page) to (min count-pages (+ (1- current-page)
+ (- visible-pages (length pages-before-current-page))))
+ collect page)))
+ (setf result (append pages-before-current-page (list current-page) pages-after-current-page))
+ (let ((result-length (length result))
+ (first-result-page (first result)))
+ (if (< result-length visible-pages)
+ (append (reverse (loop for page from (1- first-result-page) downto (max 1 (- first-result-page (- visible-pages result-length)))
+ collect page)) result)
+ result))))
+
+(defun null-when-empty (string)
+ (unless (string= string "")
+ string))
\ No newline at end of file
Added: trunk/main/claw-demo/src/frontend/customers.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/customers.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,237 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: dojo/tests/customers.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-customer-save (edit-customer))
+
+(defclass edit-customer (wcomponent)
+ ((customer :initarg :customer
+ :accessor edit-customer-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)))
+
+(defmethod wcomponent-template ((obj edit-customer))
+ (let ((id (htcomponent-client-id obj))
+ (visit-object (edit-customer-customer obj)))
+ (djform> :static-id id
+ :class "customerForm"
+ :update-id id
+ :action 'edit-customer-save
+ :action-object obj
+ :on-before-submit (on-before-submit obj)
+ :on-xhr-finish (on-xhr-finish obj)
+ (cinput> :type "hidden" :visit-object visit-object
+ :accessor 'table-id)
+ (div> :class "label name1"
+ (span> "Name 1")
+ (djvalidation-text-box> :visit-object visit-object
+ :required "true"
+ :label "Name 1"
+ :accessor 'customer-name1))
+ (div> :class "label name2"
+ (span> "Name 2")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Name 2"
+ :accessor 'customer-name2))
+ (div> :class "label email"
+ (span> "Email")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Email"
+ :accessor 'customer-email))
+ (div> :class "label pone1"
+ (span> "Phone 1")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Phone 1"
+ :accessor 'customer-phone1))
+ (div> :class "label pone2"
+ (span> "Phone 2")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Phone 2"
+ :accessor 'customer-phone2))
+ (div> :class "label pone3"
+ (span> "Phone 3")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Phone 3"
+ :accessor 'customer-phone3))
+ (div> :class "label fax"
+ (span> "Fax")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Fax"
+ :accessor 'customer-fax))
+ (div> :class "label vat"
+ (span> "VAT")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "VAT"
+ :accessor 'customer-vat))
+ (div> :class "label code1"
+ (span> "Code 1")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Code 1"
+ :accessor 'customer-code1))
+ (div> :class "label code2"
+ (span> "Code 2")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Code 2"
+ :accessor 'customer-code2))
+ (div> :class "label code3"
+ (span> "Code 3")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Code 3"
+ :accessor 'customer-code3))
+ (div> :class "label code4"
+ (span> "Code 4")
+ (djvalidation-text-box> :visit-object visit-object
+ :label "Code 4"
+ :accessor 'customer-code4))
+ (div> :class "buttons"
+ (djsubmit-button> :value "Save")))))
+
+(defmethod edit-customer-save ((obj edit-customer))
+ (let ((id (htcomponent-client-id obj)))
+ (handler-case
+ (update-db-item (edit-customer-customer obj))
+ (error (cond)
+ (add-validation-error id cond)))))
+
+(defgeneric customers-page-find-users (customers-page))
+
+(defgeneric customers-page-offset-reset (customers-page))
+
+(defclass customers-page (db-page)
+ ((customers :initform nil
+ :accessor customers-page-customers)
+ (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 ""
+ :accessor customers-page-name1)
+ (name2 :initform ""
+ :accessor customers-page-name2)
+ (email :initform ""
+ :accessor customers-page-email)
+ (vat :initform ""
+ :accessor customers-page-vat)
+ (phone :initform ""
+ :accessor customers-page-phone))
+ (:default-initargs :list-size 20))
+
+(defmethod customers-page-offset-reset ((page customers-page)) 0)
+
+(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")))
+ (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
+ :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)))
+ (div> (div> :class "searchParameters hlist"
+ (div> :class "item" (span> :class "name1" "Name")
+ (djtext-box> :label "name" :id "name1" :accessor 'customers-page-name1)
+ (djtext-box> :label "name" :id "name2" :accessor 'customers-page-name2))
+ (div> :class "item" (span> :class "email" "Email")
+ (djtext-box> :label "email" :id "email" :accessor 'customers-page-email))
+ (div> :class "item" (span> :class "vat" "VAT")
+ (djtext-box> :label "vat" :id "vat" :accessor 'customers-page-vat))
+ (div> :class "item" (span> :class "phone" "phone")
+ (djtext-box> :label "phone" :id "phone" :accessor 'customers-page-phone)))
+ (cinput> :type "hidden"
+ :static-id offset-id
+ :translator *integer-translator*
+ :reader 'customers-page-offset-reset
+ :writer (attribute-value '(setf customers-page-offset)))
+ (djsubmit-button> :id "search"
+ :value "Search"))
+ (table> :class "listTable"
+ (tr> :class "header"
+ (th> :class "name" "Name")
+ (th> :class "email" "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> (customer-email customer))
+ (td> (customer-vat customer))
+ (td> (customer-phone1 customer)))))
+ (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))))))
+
+(defmethod customers-page-find-users ((page customers-page))
+ (let ((name1 (customers-page-name1 page))
+ (name2 (customers-page-name2 page))
+ (email (customers-page-email page))
+ (vat (customers-page-vat page))
+ (phone (customers-page-phone page)))
+ (multiple-value-bind (customers total-size)
+ (find-customers :offset (customers-page-offset page)
+ :limit (customers-page-list-size page)
+ :name1 (null-when-empty name1)
+ :name2 (null-when-empty name2)
+ :email (null-when-empty email)
+ :vat (null-when-empty vat)
+ :phone (null-when-empty phone))
+ (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
+ :limit (customers-page-list-size page))
+ (setf (customers-page-customers page) customers
+ (customers-page-customers-total-count page) total-size))))
+
+
+(lisplet-register-function-location *dojo-demo-lisplet*
+ (make-page-renderer 'customers-page #'claw-post-parameters #'claw-get-parameters)
+ "customers.html")
+
+(lisplet-protect *dojo-demo-lisplet* "customers.html" '("administrator" "user"))
+
Added: trunk/main/claw-demo/src/frontend/docroot/css/style.css
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/docroot/css/style.css Tue Aug 26 06:57:00 2008
@@ -0,0 +1,120 @@
+body.demo {
+ width: 1000px;
+ margin: 0 auto;
+ padding: 0 100px;
+ background: #14335C url('../img/bg.png') repeat-x scroll 0 0;
+ font-family: arial;
+}
+
+.contentBody {
+ margin-top: 0;
+ background: white;
+ min-height: 450px;
+ padding: 10px;
+}
+
+.contentBody ul {
+ margin: 0;
+}
+
+p.header {
+ background: #9CBBE5;
+ padding: .5em;
+ margin-top:0;
+}
+
+.unclosable .dijitDialogCloseIcon {
+ display: none;
+}
+
+.dialogLabel {
+ width: 80px;
+ text-align: right;
+ display:-moz-inline-stack;
+ display:inline-block;
+}
+
+.buttonContainer {
+ margin-top: 1em;
+ border-top: 1px solid #BDD6F0;
+ padding-top: .5em;
+ text-align: center;
+}
+
+#exceptionMonitor ul {
+ list-style-type: none;
+ color: red;
+}
+
+.topheader {
+ position: relative;
+ height: 140px;
+ background: url(../img/clawHead.png) 0 0 no-repeat;
+ z-index: 100;
+}
+
+.logoDemo {
+ position: absolute;
+ top: 35px;
+ background: url(../img/clawDemo.png) 0 0 no-repeat;
+ height: 106px;
+ width: 301px;
+ margin-left: 700px;
+ z-index: 200;
+}
+
+.topheader .logoClaw {
+ position: absolute;
+ top: 5px;
+ background: url(../img/claw.png) 0 0 no-repeat;
+ height: 123px;
+ width: 123px;
+ margin-left:20px;
+ z-index: 300;
+}
+
+.soria .listTable {
+ width: 100%;
+ border-collapse: collapse;
+}
+
+.soria .listTable .header {
+ background:#EAEAEA;
+ border-bottom:1px solid #CCCCCC;
+}
+
+.soria .listTable .header th {
+ padding:3px 0 1px 3px;
+}
+
+
+.pager {
+ text-align: center;
+}
+
+.pager div {
+ display:-moz-inline-stack;
+ display:inline-block;
+ cursor: pointer;
+}
+
+.pager div.page {
+ width: 20px;
+}
+
+.pager div.button {
+ padding-left: 3px;
+ padding-right: 3px;
+}
+
+.pager div.current {
+ cursor: default;
+ font-weight: bold;
+}
+
+.hlist div.item {
+ float: left;
+}
+.searchParameters div.item span {
+ display: block;
+}
\ No newline at end of file
Added: trunk/main/claw-demo/src/frontend/docroot/img/bg.png
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/claw.png
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/clawDemo.png
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.gif
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.png
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/img/spinner.gif
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/docroot/spinner.gif
==============================================================================
Binary file. No diff available.
Added: trunk/main/claw-demo/src/frontend/index.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/index.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,58 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: dojo/tests/index.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)
+
+
+(defclass index-page (page)
+ ((username :initform nil
+ :accessor index-page-username)
+ (passwd :initform nil
+ :accessor index-page-password)))
+
+(defmethod page-content ((o index-page))
+ (site-template> :title "Home test page"
+ (ul>
+ (li> (a> :href "index.html" "Home"))
+ (li> (a> :href "info.html" "HTTP Header info"))
+ (li> (a> :href "realm.html" "realm on test"))
+ (li> (a> :href "../test2/realm.html" "realm on test2"))
+ (li> (a> :href "djbutton.html" "dojo buttons integration test"))
+ (li> (a> :href "djdialog.html" "dojo dialog integration test"))
+ (li> (a> :href "djcolorpalette.html" "dojo color palette integration test"))
+ (li> (a> :href "djeditor.html" "dojo editor integration test"))
+ (li> (a> :href "ajax.html" "dojo ajax test"))
+ (li> (a> :href "djcalendar.html" "dojo calendar test"))
+ (li> (a> :href "slider.html" "dojo slider test"))
+ (li> (a> :href "djmenu.html" "dojo menu test")))))
+
+(lisplet-register-function-location *dojo-demo-lisplet*
+ (make-page-renderer 'index-page #'claw-post-parameters #'claw-get-parameters)
+ "index.html"
+ :welcome-page-p t)
\ No newline at end of file
Added: trunk/main/claw-demo/src/frontend/login.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/login.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,86 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: dojo/tests/login.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 login-page-do-login (login-page))
+
+(defclass login-page (page)
+ ((username :initform ""
+ :accessor login-page-username)
+ (passwd :initform ""
+ :accessor login-page-password)))
+
+(defmethod page-content ((o login-page))
+ (let ((login-result-id (generate-id "loginResult"))
+ (spinner-id (generate-id "spinner")))
+ (site-template> :title "CLAW Demo login"
+ (djdialog> :id "loginDialog"
+ :title "Login into system"
+ :class "unclosable"
+ (djfloating-content> :static-id spinner-id
+ (img> :alt "spinner"
+ :src "docroot/img/spinner.gif"))
+ (djform> :id "login"
+ :class "loginForm"
+ :action 'login-page-do-login
+ :update-id login-result-id
+ :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id)))
+ :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id)))
+ (div>
+ (span> :class "dialogLabel" "Username")
+ (djvalidation-text-box> :id "username"
+ :label "Username"
+ :required "true"
+ :accessor 'login-page-username))
+ (div>
+ (span> :class "dialogLabel" "Password")
+ (djvalidation-text-box> :id "password"
+ :label "Password"
+ :required "true"
+ :accessor 'login-page-password))
+ (div> :class "buttonContainer"
+ (djsubmit-button> :value "Login")
+ (exception-monitor> :id "exceptionMonitor")))
+ (div> :static-id login-result-id
+ (redirect> :render-condition #'current-principal
+ :id "redirect"
+ :href (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*)))))
+ (script> (ps:ps* `(dojo.add-on-load (lambda () (.show (dijit.by-id "loginDialog")))))))))
+
+(lisplet-register-function-location *dojo-demo-lisplet*
+ (make-page-renderer 'login-page #'claw-post-parameters #'claw-get-parameters)
+ "login.html"
+ :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
Added: trunk/main/claw-demo/src/frontend/logout.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/logout.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,46 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: dojo/tests/logout.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 do-logout (page))
+
+(defclass logout-page (page)
+ ())
+
+(defmethod page-content ((o logout-page))
+ (do-logout o))
+
+(defmethod do-logout ((demo-page logout-page))
+ (claw-remove-session)
+ (claw-redirect (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*)) :protocol :http))
+
+(lisplet-register-function-location *dojo-demo-lisplet*
+ (make-page-renderer 'logout-page #'claw-post-parameters #'claw-get-parameters)
+ "logout.html")
\ No newline at end of file
Added: trunk/main/claw-demo/src/frontend/main.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/main.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,74 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: dojo/tests/main.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)
+
+
+(defvar *main-file* (load-time-value
+ (or #.*compile-file-pathname* *load-pathname*)))
+
+(defvar *dojo-demo-lisplet*)
+
+(setf *dojo-demo-lisplet* (make-instance 'lisplet :realm "demo"
+ :redirect-protected-resources-p t
+ :base-path "/demo"))
+
+(defvar *ht-connector* (make-instance 'hunchentoot-connector
+ :port 4242
+ :sslport nil
+ :behind-apache-p t
+ :mod-lisp-p nil))
+
+(defvar *sm* (make-instance 'default-session-manager))
+
+(defvar *ht-log-manager* (make-instance 'hunchentoot-logger))
+
+(defvar *dojo-clawserver* (make-instance 'clawserver
+ :connector *ht-connector*
+ :log-manager *ht-log-manager*
+ :session-manager *sm*
+ :base-path "/claw"))
+
+(clawserver-register-lisplet *dojo-clawserver* *dojo-demo-lisplet*)
+
+(clawserver-register-configuration *dojo-clawserver* "demo" (make-instance 'demo-configuration))
+
+(let ((path (make-pathname :directory (append (pathname-directory *main-file*) '("docroot"))))
+ (*clawserver* *dojo-clawserver*))
+ (log-message :info "Registering resource ~a" path)
+ (lisplet-register-resource-location *dojo-demo-lisplet*
+ path
+ "docroot/"))
+
+(defun djstart ()
+ (clawserver-start *dojo-clawserver*))
+
+(defun djstop ()
+ (clawserver-stop *dojo-clawserver*))
+
Added: trunk/main/claw-demo/src/frontend/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-demo/src/frontend/packages.lisp Tue Aug 26 06:57:00 2008
@@ -0,0 +1,36 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/package.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 :cl-user)
+
+
+(defpackage :claw-demo-frontend
+ (:use :cl :local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend)
+ (:documentation "A demo application for CLAW")
+ #|(:export #:demo-setup)|#)
\ No newline at end of file
More information about the Claw-cvs
mailing list