;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: tests/test1.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-tests) (setf hunchentoot:*default-content-type* "text/html; charset=UTF-8") (setf hunchentoot:*rewrite-for-session-urls* nil) (defvar *this-file* (load-time-value (or #.*compile-file-pathname* *load-pathname*))) (register-library-resource "libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img")))) (register-library-resource "libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (defvar *lisplet-messages* (make-instance 'simple-message-dispatcher)) (simple-message-dispatcher-add-message *lisplet-messages* "en" "NAME" "Name") (simple-message-dispatcher-add-message *lisplet-messages* "en" "SURNAME" "Surname") (simple-message-dispatcher-add-message *lisplet-messages* "en" "WELCOME" "Welcome") (simple-message-dispatcher-add-message *lisplet-messages* "en" "AGREE" "Agree") (simple-message-dispatcher-add-message *lisplet-messages* "en" "SURE" "Are you sure?") (simple-message-dispatcher-add-message *lisplet-messages* "it" "YES" "sì") (simple-message-dispatcher-add-message *lisplet-messages* "it" "NAME" "Nome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto") (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE" "Sei sicuro?") (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE-ERROR-MESSAGE" "Devi essere sicuro") (simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!") (defvar *test-lisplet*) (setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" :redirect-protected-resources-p t)) (defvar *test-lisplet2*) (setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) (defvar *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 :base-path "/claw" :mod-lisp-p nil :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) (clawserver-register-lisplet *clawserver* *test-lisplet*) (clawserver-register-lisplet *clawserver* *test-lisplet2*) (defun test-configuration-do-login (request user password) (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") (string-equal password "password")) (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) (defclass test-configuration (configuration) ()) (defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) (let ((lisplet (current-lisplet request))) (multiple-value-bind (user password) (if (eq (lisplet-authentication-type lisplet) :basic) (authorization) (values (aux-request-value 'user request) (aux-request-value 'password request))) (test-configuration-do-login request user password)))) (clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) (defun claw-tst-start () (clawserver-start *clawserver*)) (defun claw-tst-stop () (clawserver-stop *clawserver*)) ;;;--------------------template-------------------------------- (defclass site-template (wcomponent) ((title :initarg :title :reader title)) (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) (html> (head> (title> (title o)) (style> :type "text/css" "input.error, div.error { background-color: #FF9999; } ")) (body> (wcomponent-informal-parameters o) (div> :style "background-color: #DBDFE0;padding: 3px;" (a> :href "/claw/test/index.html" "home")) (htcomponent-body o)))) ;;;--------------------index testing page-------------------------------- (defclass auth-page (page) ()) (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" (p> "protected content"))) (lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") (lisplet-register-page-location *test-lisplet* 'auth-page "auth.html") (lisplet-protect *test-lisplet* "auth.html" '("admin" "user")) (lisplet-protect *test-lisplet* "unauth.html" '("nobody")) (defclass index-page (page) ()) (defmethod page-content ((o index-page)) (let ((clawserver-base-path (clawserver-base-path (current-server)))) (site-template> :title "Home test page" (p> :id "p" (ul> (li> (a> :href "login.html" "Do login")) (li> (a> :href "info.html" "Headers info")) (li> (a> :href (format nil "~a/libs/images/matrix.jpg" clawserver-base-path) "show static file provided by CLAW-TESTS package by folder")) (li> (a> :href (format nil "~a/libs/img.jpg" clawserver-base-path) "show static file provided by CLAW-TESTS package by file")) (li> (a> :href "images/matrix.jpg" "show static file")) (li> (a> :href "images/matrix2.jpg" "show file by function")) (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> (a> :href "id-tests.html" "id generation test")) (li> (a> :href "form.html" "form components test")) (li> (a> :href "auth.html" "authorized page")) (li> (a> :href "unauth.html" "unauthorized page"))))))) (lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) (defclass msie-p (wcomponent) () (:metaclass metacomponent)) (defmethod wcomponent-template ((msie-p msie-p)) (let ((id (htcomponent-client-id msie-p))) (p> :static-id id))) (defmethod htcomponent-instance-initscript ((msie-p msie-p)) (let ((id (htcomponent-client-id msie-p))) (format nil "document.getElementById('~a').innerHTML = '~a';" id (if (msie-p) "The browser is MSIE" "The browser is not MSIE")))) (defclass info-page (page) ()) (defmethod page-content ((o info-page)) (let ((header-props (headers-in))) (site-template> :title "Header info page" (p> :id "p" (table> (tr> (td> :colspan "2" "Header info")) (loop for key-val in header-props collect (tr> (td> (format nil "~a" (car key-val)) (td> (format nil "~a" (cdr key-val)))))))) (msie-p> :id "msie")))) (lisplet-register-page-location *test-lisplet* 'info-page "info.html") (defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") (lisplet-register-function-location *test-lisplet* (lambda () (let ((path (test-image-file))) (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) (with-open-file (in path :element-type 'flex:octet) (let ((image-data (make-array (file-length in) :element-type 'flex:octet))) (read-sequence image-data in) image-data)))) "images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) (defmethod page-content ((o realm-page)) (when (null hunchentoot:*session*) (claw-start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) (site-template> :title "Realm test page" (p> "session" (ul> (li> (a> :href "http://www.gentoo.org" :target "gentoo" "gentoo")) (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) (li> "Remote Addr: " (session-remote-addr *session*)) (li> "User agent: " (session-user-agent *session*)) (li> "Lisplet Realm: " (current-realm)) (li> "Session Realm: " (session-realm *session*)) (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) (li> "Request Realm: " (hunchentoot::realm *request*)))))) (lisplet-register-page-location *test-lisplet* 'realm-page "realm.html") (lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html") ;;;--------------------id testing page-------------------------------- (defclass id-tests-page (page) ()) (defmethod page-content ((o id-tests-page)) (let ((uid (generate-id "uid")) (uid2 (generate-id "uid"))) (site-template> :title "a page title" "\"test\"" (hr>) (div> :id "foo" :class "goo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") (div> :id "foo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") (div> :static-id uid :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") (div> :static-id uid2 :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) (lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html") ;;;--------------------from components testing page-------------------------------- (defgeneric login-page-login (login-page)) (defclass login-page (page) ((username :initform "" :accessor login-page-username) (passowrd :initform "" :accessor login-page-password)) (:default-initargs :message-dispatcher *lisplet-messages*)) (defmethod page-content ((login-page login-page)) (let ((princp (current-principal))) (site-template> :title "a page title" (if (null princp) (cform> :id "loginform" :method "post" :action #'login-page-login (table> (tr> (td> "Username") (td> (cinput> :id "username" :type "text" :accessor 'login-page-username) "\(kiuma)")) (tr> (td> "Password") (td> (cinput> :id "passowrd" :type "password" :accessor 'login-page-password) "\(password)")) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "Login"))))) (p> (with-message "WELCOME" "WELCOME") " " (principal-name princp) (a> :href "index.html" "home")))))) (defmethod login-page-login ((login-page login-page)) (setf (aux-request-value 'user) (login-page-username login-page) (aux-request-value 'password) (login-page-password login-page)) (login)) (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) (defclass user () ((name :initarg :name :accessor user-name) (surname :initarg :surname :accessor user-surname) (gender :initarg :gender :accessor user-gender) (age :initarg :age :accessor user-age) (agree :initarg :agree :accessor user-agree) (sure :initarg :sure :accessor user-sure) (capital :initarg :capital :accessor user-capital)) (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree "")) (defgeneric form-page-update-user (form-page)) (defclass form-page (page user) ((name :initarg :name :accessor form-page-name) (surname :initarg :surname :accessor form-page-surname) (colors :initarg :colors :accessor form-page-colors) (gender :initarg :gender :writer setf-gender :accessor form-page-gender) (user :initarg :user :accessor form-page-user) (age :initarg :age :accessor form-page-age) (agree :initarg :agree :accessor form-page-agree) (sure :initarg :sure :accessor form-page-sure) (capital :initarg :capital :accessor form-page-capital) (birthday :initarg :birthday :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil :gender "M" :age 1800 :capital 500055/100 :birthday (now) :message-dispatcher *lisplet-messages* :agree t :sure "yes" :user (make-instance 'user))) (defmethod form-page-update-user ((form-page form-page)) (let ((user (form-page-user form-page)) (name (form-page-name form-page)) (surname (form-page-surname form-page)) (gender (form-page-gender form-page)) (age (form-page-age form-page)) (agree (form-page-agree form-page)) (sure (form-page-sure form-page))) (setf (user-name user) name (user-surname user) surname (user-gender user) gender (user-age user) age (user-agree user) agree (user-sure user) sure))) (defun validate-agree (component value) (declare (ignore value)) (validate nil :component component :message (do-message "SURE-ERROR-MESSAGE" "You must be sure"))) (defmethod page-content ((o form-page)) (let ((user (form-page-user o))) (site-template> :title "a page title" (cform> :id "testform" :method "post" :action #'form-page-update-user (table> (tr> (td> "Name") (td> (cinput> :id "name" :type "text" :label "Name" :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-name)"*")) (tr> :id "messaged" (td> (with-message "SURNAME" "SURNAME")) (td> (cinput> :id "surname" :type "text" :label "Surname" :validator #'(lambda (value) (validate-required (page-current-component o) value) (validate-size (page-current-component o) value :min-size 1 :max-size 20)) :accessor 'form-page-surname)"*")) (tr> :id "agree" (td> (with-message "AGREE" "AGREE")) (td> (ccheckbox> :id "agree" :label (with-message "AGREE" "AGREE") :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-agree :value t)"*")) (tr> :id "sure" (td> (with-message "SURE" "SURE")) (td> (cradio> :id "sure" :label (with-message "SURE" "SURE") :accessor 'form-page-sure :value "yes") (span> :style "margin-right:1.5em;" (with-message "YES" "yes")) (cradio> :id "sure" :label (with-message "SURE" "SURE") :validator #'(lambda (value) (validate-agree (page-current-component o) value)) :accessor 'form-page-sure :value "no") (span> :style "margin-right:1.5em;" (with-message "NO" "no")))) (tr> (td> "Gender") (td> (cselect> :id "gender" :accessor 'form-page-gender (loop for gender in (list "M" "F") collect (option> :value gender (when (string= gender (form-page-gender o)) '(:selected "selected")) (if (string= gender "M") "Male" "Female")))))) (tr> (td> "Age") (td> (cinput> :id "age" :type "text" :label "Age" :translator (make-instance 'translator-integer :thousand-separator #\') :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-integer component value :min 1 :max 2000))) :accessor 'form-page-age)"*")) (tr> (td> "Birthday") (td> (cinput> :id "bday" :type "text" :label "Birthday" :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) :accessor 'form-page-birthday)"(dd-mm-yyyy)")) (tr> (td> "Capital") (td> (cinput> :id "capital" :type "text" :label "Capital" :translator (make-instance 'translator-number :decimal-digits 2 :thousand-separator #\') :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-number component value :min 1000.01 :max 500099/100))) :accessor 'form-page-capital)"*")) (tr> (td> "Colors") (td> (cselect> :id "colors" :multiple "true" :style "width:80px;height:120px;" :accessor 'form-page-colors (loop for color in (list "R" "G" "B") collect (option> :value color (when (find color (form-page-colors o) :test #'string=) '(:selected "selected")) (cond ((string= color "R") "red") ((string= color "G") "green") (t "blue"))))))) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) (p> (exception-monitor> :id "exceptionMonitor" :class "error") (hr>) (h2> "From result:") (div> (format nil "Name: ~a" (user-name user))) (div> (format nil "Surname: ~a" (user-surname user))) (div> (format nil "Gender: ~a" (user-gender user))) (div> (format nil "Age: ~a" (user-age user))) (div> (format nil "Agree: ~a" (user-agree user))) (div> (format nil "Sure: ~a" (user-sure user))))))) (lisplet-register-page-location *test-lisplet* 'form-page "form.html")