Author: achiumenti Date: Tue Jan 22 01:44:06 2008 New Revision: 1 Added: trunk/ trunk/doc/ trunk/doc/CREDITS trunk/doc/Makefile trunk/doc/README trunk/doc/blender/ trunk/doc/chapters/ trunk/doc/claw.texinfo trunk/doc/figure1.png (contents, props changed) trunk/logo/ trunk/logo/claw.svg trunk/main/ trunk/main/claw-core/ trunk/main/claw-core/claw-tests.asd trunk/main/claw-core/claw.asd trunk/main/claw-core/src/ trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/hunchentoot-overrides.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/ trunk/main/claw-core/tests/packages.lisp trunk/main/claw-core/tests/test1.lisp Log: first commit Added: trunk/doc/CREDITS ============================================================================== Added: trunk/doc/Makefile ============================================================================== --- (empty file) +++ trunk/doc/Makefile Tue Jan 22 01:44:06 2008 @@ -0,0 +1,22 @@ +DOCFILES:=*.texinfo +MAINFILE=claw +I_FLAGS=-I chapters/ +TEXI2PDF=texi2pdf +MAKEINFO=makeinfo +DIRNAME=`dirname` +MYPNGS=$(wildcard *.png) +MYPDFS=$(MYPNGS:%.png=%.pdf) + +all: $(MYPDFS) html pdf + +$(MYPDFS) : %.pdf : %.png + convert $< $@ + +html: + ${MAKEINFO} --html ${MAINFILE}.texinfo + +pdf: + ${TEXI2PDF} ${I_FLAGS} --output=${MAINFILE}.pdf ${MAINFILE}.texinfo + +clean: + rm -rf ${MAINFILE} *.pdf *.ps Added: trunk/doc/README ============================================================================== Added: trunk/doc/claw.texinfo ============================================================================== --- (empty file) +++ trunk/doc/claw.texinfo Tue Jan 22 01:44:06 2008 @@ -0,0 +1,67 @@ +\input texinfo @c -*-texinfo-*- + +@c %**start of header +@setfilename claw.info +@settitle CLAW User Manual +@c %**end of header + +@set claw CLAW +@set VERSION 0.1 +@set UPDATE-MONTH genuary 2008 +@settitle @value{claw} @value{VERSION} User Manual + +@copying +@quotation +This manual is part of the @value{claw} software system. See the +@file{README} file for more information. + +This manual is in the public domain and is +provided with absolutely no warranty. See the @file{COPYING} and +@file{CREDITS} files for more information. +@end quotation +@end copying + +@titlepage +@title @value{claw} User Manual +@subtitle @value{claw} version @value{VERSION} +@subtitle @value{UPDATE-MONTH} + +@c The following two commands start the copyright page. +@page +@vskip 0pt plus 1filll +@insertcopying + +@end titlepage + +@contents + +@ifnottex + +@node Top +@comment node-name, next, previous, up +@top About this manual + +@insertcopying + +@menu +* Introduction:: +* Server:: +* Function index:: +@c * Starting and Stopping:: +@c * Compiler:: +@c * Debugger:: +@c * Efficiency:: +@c * Beyond the ANSI Standard:: +@c * Type Index:: +@end menu + +@end ifnottex + +@include chapters/intro.texinfo +@include chapters/server.texinfo + +@node Function index +@unnumbered Function index +@printindex fn + +@bye Added: trunk/doc/figure1.png ============================================================================== Binary file. No diff available. Added: trunk/logo/claw.svg ============================================================================== --- (empty file) +++ trunk/logo/claw.svg Tue Jan 22 01:44:06 2008 @@ -0,0 +1,89 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://web.resource.org/cc/" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="395.3533" + height="452.69388" + id="svg2" + sodipodi:version="0.32" + inkscape:version="0.45.1" + sodipodi:docbase="/home/kiuma/lispWks/cl-webobjects" + sodipodi:docname="claw.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + version="1.0"> + <defs + id="defs4" /> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="0.49497475" + inkscape:cx="-221.21661" + inkscape:cy="243.96822" + inkscape:document-units="px" + inkscape:current-layer="g2186" + inkscape:window-width="844" + inkscape:window-height="596" + inkscape:window-x="535" + inkscape:window-y="240" /> + <metadata + id="metadata7"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <g + inkscape:label="Livello 1" + inkscape:groupmode="layer" + id="layer1" + transform="translate(-1.5750449e-6,-599.66831)"> + <g + id="g2186" + transform="translate(-182.7324,243.63533)"> + <path + sodipodi:nodetypes="czczcsc" + id="path2184" + d="M 574.28571,712.93361 C 574.28571,712.93361 497.0762,864.36966 322.85714,778.64789 C 147.49119,692.36181 191.42857,404.36218 191.42857,404.36218 C 191.42857,404.36218 249.28571,430.07647 298.57143,430.07647 C 347.85714,430.07647 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 301.42527,582.9303 378.57143,660.07646 C 447.17633,728.68136 574.28571,712.93361 574.28571,712.93361 z " + style="fill:#d9b134;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + style="fill:#ffff85;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 574.28571,712.93361 C 574.28571,712.93361 468.79193,795.67929 367.30385,740.26209 C 265.08098,684.44367 281.83722,437.69722 281.83722,437.69722 C 281.83722,437.69722 298.73168,448.20074 343.01814,429.57139 C 386.24294,411.38865 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 301.42527,582.9303 378.57143,660.07646 C 447.17633,728.68136 574.28571,712.93361 574.28571,712.93361 z " + id="path2170" + sodipodi:nodetypes="czczcsc" /> + <path + style="fill:#ffcc16;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.9;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 574.28571,712.93361 C 574.28571,712.93361 493.03559,799.7199 373.36477,748.34331 C 256.12816,698.01178 268.07761,436.21788 268.07761,436.21788 C 268.07761,436.21788 260.5593,443.54704 303.57143,435.79076 C 347.14285,427.93361 388.57143,404.36218 388.57143,404.36218 C 388.57143,404.36218 284.28241,605.78744 361.42857,682.9336 C 430.03347,751.5385 574.28571,712.93361 574.28571,712.93361 z " + id="path2214" + sodipodi:nodetypes="czczcsc" /> + <path + sodipodi:nodetypes="cssscscsssc" + id="path2186" + d="M 568.60778,714.63119 C 568.60778,714.63119 555.15172,738.78869 513.68644,760.07049 C 475.21405,779.81621 438.21293,772.86104 405.69624,766.07942 C 343.66906,753.14314 300.82929,717.20788 276.50661,675.32185 C 263.76746,653.38378 237.59798,608.21343 241.16941,438.21344 C 241.16941,438.21344 245.86186,440.51972 265.40978,440.02636 C 286.10384,439.50406 294.2798,435.89726 294.2798,435.89726 C 275.32828,566.97873 287.34798,625.24753 314.44785,674.20916 C 337.22107,715.35379 384.60573,742.83441 441.41324,751.96937 C 469.45232,756.47821 488.72704,758.51616 518.0041,748.36048 C 538.09485,741.39137 568.60778,714.63119 568.60778,714.63119 z " + style="fill:#ffff85;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.92731011px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + <path + transform="matrix(0.9197522,-8.7906129e-2,0.101145,0.998963,-23.194129,22.377644)" + d="M 410.00002 402.36218 A 111.42857 37.142857 0 1 1 187.14287,402.36218 A 111.42857 37.142857 0 1 1 410.00002 402.36218 z" + sodipodi:ry="37.142857" + sodipodi:rx="111.42857" + sodipodi:cy="402.36218" + sodipodi:cx="298.57144" + id="path3161" + style="fill:#a16226;fill-opacity:1;fill-rule:nonzero;stroke:#000000;stroke-width:7.5999999;stroke-linecap:butt;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + sodipodi:type="arc" /> + </g> + </g> +</svg> Added: trunk/main/claw-core/claw-tests.asd ============================================================================== --- (empty file) +++ trunk/main/claw-core/claw-tests.asd Tue Jan 22 01:44:06 2008 @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: claw-tests.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-tests + :name "claw-tests" + :author "Andrea Chiumenti" + :description "Tests for cl-webobjects" + :depends-on (:claw) + :components ((:module tests + :components ((:file "packages") + (:file "test1" :depends-on ("packages")))))) + Added: trunk/main/claw-core/claw.asd ============================================================================== --- (empty file) +++ trunk/main/claw-core/claw.asd Tue Jan 22 01:44:06 2008 @@ -0,0 +1,42 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: claw.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 + :name "claw" + :author "Andrea Chiumenti" + :description "Common Lisp Active Web.A famework to write web applications" + :depends-on (:hunchentoot :alexandria :cl-ppcre) + :components ((:module src + :components ((:file "packages") + (:file "misc" :depends-on ("packages")) + (:file "hunchentoot-overrides" :depends-on ("packages")) + (:file "tags" :depends-on ("misc")) + (:file "components" :depends-on ("tags")) + (:file "lisplet" :depends-on ("components")) + (:file "server" :depends-on ("lisplet")))))) Added: trunk/main/claw-core/src/components.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/components.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,207 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.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) + +(defgeneric cform-rewinding-p (obj page-obj) + (:documentation "Internal method to determine, during the rewinding phase, if the COMP has been fired for calling its action. +- OBJ the wcomponent instance +- PAGE-OBJ the wcomponent owner page")) + +;-------------------------------------------------------------------------------- + +(defcomponent cform () () + (:documentation "This component render as a FORM tag class, but it is aware of +the request cycle and is able to fire an action on rewind")) + +(defmethod cform-rewinding-p ((obj cform) (pobj page)) + (string= (htcomponent-client-id obj) + (page-req-parameter pobj *rewind-parameter*))) + +(defmethod wcomponent-parameters ((o cform)) + (list :id :required :action nil)) + +(defmethod wcomponent-template((o cform)) + (let ((client-id (htcomponent-client-id o))) + (when (null client-id) + (setf client-id "")) + (form> :static-id client-id + :name client-id + (wcomponent-informal-parameters o) + (input> :name *rewind-parameter* + :type "hidden" + :value client-id) + (htcomponent-body o)))) + +(defmethod wcomponent-before-rewind ((obj cform) (pobj page)) + (setf (page-current-form pobj) obj)) + +(defmethod wcomponent-after-rewind ((obj cform) (pobj page)) + (let ((action (wcomponent-parameter-value obj :action))) + (unless (or (null action) (null (cform-rewinding-p obj pobj))) + (funcall (fdefinition action) pobj)) + (setf (page-current-form pobj) nil))) + +;-------------------------------------------------------------------------------- + +(defcomponent action-link (cform) () + (:documentation "This component behaves like a CFORM, firing it's associated action once clicked. +It renders as a normal link.")) + +(defmethod wcomponent-reserved-parameters ((o action-link)) + '(:href)) + +(defmethod wcomponent-template((o action-link)) + (let ((client-id (htcomponent-client-id o))) + (when (null client-id) + (setf client-id "")) + (a> :static-id client-id + :href (format nil "?~a=~a" *rewind-parameter* client-id) + (wcomponent-informal-parameters o) + (htcomponent-body o)))) + +;--------------------------------------------------------------------------------------- + +(defcomponent cinput () + ((result-as-list :initarg :result-as-list + :accessor cinput-result-as-list)) + (:default-initargs :result-as-list nil) + (:documentation "Request cycle aware component the renders as an INPUT tag class")) + +(defmethod wcomponent-parameters ((o cinput)) + (list :id :required :reader nil :writer nil :visit-object nil :accessor nil :type :required)) + +(defmethod wcomponent-reserved-parameters ((o cinput)) + '(:value :name)) + +(defmethod wcomponent-template ((obj cinput)) + (let ((client-id (htcomponent-client-id obj)) + (type (wcomponent-parameter-value obj :type)) + (visit-object (wcomponent-parameter-value obj :visit-object)) + (accessor (wcomponent-parameter-value obj :accessor)) + (reader (wcomponent-parameter-value obj :reader)) + (value "")) + (when (null visit-object) + (setf visit-object (htcomponent-page obj))) + (if (and (null reader) accessor) + (setf value (funcall (fdefinition accessor) visit-object)) + (setf value (funcall (fdefinition reader) visit-object))) + (input> :static-id client-id + :type type + :name client-id + :value value + (wcomponent-informal-parameters obj)))) + +(defmethod wcomponent-after-rewind ((obj cinput) (pobj page)) + (let ((visit-object (wcomponent-parameter-value obj :visit-object)) + (accessor (wcomponent-parameter-value obj :accessor)) + (writer (wcomponent-parameter-value obj :writer)) + (new-value (page-req-parameter pobj + (htcomponent-client-id obj) + (cinput-result-as-list obj)))) + (unless (null new-value) + (when (null visit-object) + (setf visit-object (htcomponent-page obj))) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object))))) + +;--------------------------------------------------------------------------------------- +(defcomponent csubmit () () + (:documentation "This component render as an INPUT tag class ot type submit, but +can override the default CFORM action, using its own associated action")) + +(defmethod wcomponent-parameters ((o csubmit)) + (list :id :required :value :required :action nil)) + +(defmethod wcomponent-reserved-parameters ((o csubmit)) + '(:type :name)) + +(defmethod wcomponent-template ((obj csubmit)) + (let ((client-id (htcomponent-client-id obj)) + (value (wcomponent-parameter-value obj :value))) + (input> :static-id client-id + :type "submit" + :name client-id + :value value + (wcomponent-informal-parameters obj)))) + +(defmethod wcomponent-after-rewind ((obj csubmit) (pobj page)) + (let ((action (wcomponent-parameter-value obj :action)) + (current-form (page-current-form pobj)) + (submitted-p (page-req-parameter pobj (htcomponent-client-id obj)))) + (unless (or (null current-form) (null submitted-p) (null action)) + (setf (getf (wcomponent-parameters current-form) :action) action)))) +;----------------------------------------------------------------------------- +(defcomponent submit-link (csubmit) () + (:documentation "This component renders as a normal link, but behaves like a CSUBMIT, +so it can be used instead of CSUBMIT when needed")) + +(defmethod wcomponent-reserved-parameters ((o submit-link)) + '(:href)) + +(defmethod wcomponent-template ((obj submit-link)) + (let* ((id (htcomponent-client-id obj)) + (submit-id (generate-id id))) + (list + (input> :static-id submit-id + :style "display:none;" + :type "submit" + :name id + :value "-") + (a> :static-id id + :href (format nil "javascript:document.getElementById('~a').click();" submit-id) + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))) + +;-------------------------------------------------------------------------- + +(defcomponent cselect (cinput) () + (:default-initargs :result-as-list t) + (:documentation "This component renders as a normal SELECT tag class, +but it is request cycle aware.")) + +(defmethod wcomponent-parameters :around ((obj cselect)) + (declare (ignore obj)) + (let ((params (call-next-method))) + (remf params :reader) + (remf params :type) + params)) + +(defmethod wcomponent-reserved-parameters ((obj cselect)) + (declare (ignore obj)) + '(:type :name)) + +(defmethod wcomponent-template ((obj cselect)) + (let ((client-id (htcomponent-client-id obj))) + (select> :static-id client-id + :name client-id + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) + Added: trunk/main/claw-core/src/hunchentoot-overrides.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/hunchentoot-overrides.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,238 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/hunchentoot/session.lisp,v 1.11 2007/06/04 19:24:12 edi Exp $ + +;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. 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 :hunchentoot) + +(defgeneric realm (request) + (:documentation "Returns the realm under which the request has been sent. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user.")) +(defgeneric (setf realm) (value request) + (:documentation "Sets the realm under which the request has been sent, where value is the realm name. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user.")) + +(defmethod realm ((request request)) + (aux-request-value 'realm request)) + +(defmethod (setf realm) (value (request request)) + (setf (aux-request-value 'realm request) value) + (session-realm-verify request)) + +;;;------------------------------------------------------------------------------- + +(defclass session () + ((session-id :initform (get-next-session-id) + :reader session-id + :type integer + :documentation "The unique ID \(an INTEGER) of the session.") + (session-realm :initform (realm *request*) + :reader session-realm + :documentation "Defines a realm for this session. +A realm is injected by *request* aux parameter, and is used to group resources that will share this session object.") + (session-string :reader session-string + :documentation "The session strings encodes enough +data to safely retrieve this session. It is sent to the browser as a +cookie value or as a GET parameter.") + (user-agent :initform (user-agent *request*) + :reader session-user-agent + :documentation "The incoming 'User-Agent' header that +was sent when this session was created.") + (remote-addr :initform (real-remote-addr *request*) + :reader session-remote-addr + :documentation "The remote IP address of the client when +this sessions was started as returned by REAL-REMOTE-ADDR.") + (session-start :initform (get-universal-time) + :reader session-start + :documentation "The time this session was started.") + (last-click :initform (get-universal-time) + :reader session-last-click + :documentation "The last time this session was used.") + (session-data :initarg :session-data + :initform nil + :reader session-data + :documentation "Data associated with this session - +see SESSION-VALUE.") + (session-counter :initform 0 + :reader session-counter + :documentation "The number of times this session +has been used.") + (max-time :initarg :max-time + :initform *session-max-time* + :accessor session-max-time + :type fixnum + :documentation "The time \(in seconds) after which this +session expires if it's not used.")) + (:documentation "SESSION objects are automatically maintained +by Hunchentoot. They should not be created explicitly with +MAKE-INSTANCE but implicitly with START-SESSION. Note that +SESSION objects can only be created when the special variable +*REQUEST* is bound to a REQUEST object.")) + +(defun encode-session-string (id user-agent remote-addr start realm) + "Create a uniquely encoded session string based on the values ID, +USER-AGENT, REMOTE-ADDR, START and REALM" + ;; *SESSION-SECRET* is used twice due to known theoretical + ;; vulnerabilities of MD5 encoding + (md5-hex (concatenate 'string + *session-secret* + (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A~@[~A~]" + *session-secret* + id + (and *use-user-agent-for-sessions* + user-agent) + (and *use-remote-addr-for-sessions* + remote-addr) + start + realm))))) + +(defun stringify-session (session) + "Creates a string representing the SESSION object SESSION. See +ENCODE-SESSION-STRING." + (encode-session-string (session-id session) + (session-user-agent session) + (session-remote-addr session) + (session-start session) + (session-realm session))) + + +(defun session-realm-verify (request) + "Once a session is verified for a given user this function verifies that it belongs to the request realm, so +that session and request realm must be the same." + (when (session request) + (let + ((req-realm (realm request)) + (realm (session-realm (session request)))) + (when (string-not-equal req-realm realm) + (log-message :info "2) $$$$$~a$$$$$" (aux-request-value 'realm request)) + (log-message :info "#####~a ~a#####" req-realm realm) + (setf (session request) nil) + (setf *session* nil))))) + +(defun session-verify (request) + "Tries to get a session identifier from the cookies \(or +alternatively from the GET parameters) sent by the client. This +identifier is then checked for validity against the REQUEST object +REQUEST. On success the corresponding session object \(if not too old) +is returned \(and updated). Otherwise NIL is returned." + (let ((session-identifier (or (cookie-in *session-cookie-name* request) + (get-parameter *session-cookie-name* request)))) + (unless (and session-identifier + (stringp session-identifier) + (plusp (length session-identifier))) + (return-from session-verify nil)) + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (let* ((id (and (scan "^\\d+$" id-string) + (parse-integer id-string + :junk-allowed t))) + (session (and id + (get-stored-session id))) + (user-agent (user-agent request)) + (remote-addr (remote-addr request)) + (realm (when session (session-realm session)))) + (unless (and session + session-string + (string= session-string + (session-string session)) + (string= session-string + (encode-session-string id + user-agent + (real-remote-addr request) + (session-start session) + realm))) + (when *reply* + (cond ((null session) + (log-message :notice "No session for session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')" + session-identifier user-agent remote-addr realm)) + (t + (log-message :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')" + session-identifier user-agent remote-addr realm)))) + (when session + (remove-session session)) + (return-from session-verify nil)) + (incf (slot-value session 'session-counter)) + (setf (slot-value session 'last-click) (get-universal-time)) + session)))) + +(defun start-session (&optional (path "/")) + "Returns the current SESSION object. If there is no current session, +creates one and updates the corresponding data structures. In this +case the function will also send a session cookie to the browser. +This function slightly differs from standard hunchentoot implementation because +it can bound a session to a specific url inside the same server instance. +The path optional parameter has sense when the cookies are enabled, and bounds +resources under the given path to a specific session" + (count-session-usage) + (let ((session (session *request*))) + (when session + (return-from start-session session)) + (setf session (make-instance 'session) + (session *request*) session) + (with-lock (*session-data-lock*) + (setq *session-data* (acons (session-id session) session *session-data*))) + (set-cookie *session-cookie-name* + :value (session-cookie-value session) + :path path) + (setq *session* session))) + +;;;--------------------------- dispatchers ---------------------------------------------- + +(defun create-prefix-dispatcher (prefix page-function &optional (realm "Hunchentoot")) + "Creates a dispatch function which will dispatch to the +function denoted by PAGE-FUNCTION if the file name of the current +request starts with the string PREFIX. +The optional parameter realm is a string that identifies the realm under which the request is displatching. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user." + (lambda (request) + (let ((mismatch (mismatch (script-name request) prefix + :test #'char=))) + (when (and (or (null mismatch) + (>= mismatch (length prefix))) + page-function) + (setf (realm request) realm) + page-function)))) + +(defun create-regex-dispatcher (regex page-function &optional (realm "Hunchentoot")) + "Creates a dispatch function whipch will dispatch to the +function denoted by PAGE-FUNCTION if the file name of the current +request matches the CL-PPCRE regular expression REGEX. +The optional parameter realm is a string that identifies the realm under which the request is displatching. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user." + (let ((scanner (create-scanner regex))) + (lambda (request) + (when (and (scan scanner (script-name request)) + page-function) + (setf (realm request) realm) + page-function)))) + Added: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/lisplet.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,109 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/lisplet.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) + +;(print *this-file*) + +(defgeneric lisplet-register-page-location (obj page-class location &optional welcome-pagep)) +(defgeneric lisplet-register-resource-location (obj uri url)) + +(defgeneric lisplet-dispatch-request (obj)) +(defgeneric lisplet-dispatch-method (obj)) + + +(defclass lisplet () + ((base-path :initarg :base-path + :reader lisplet-base-path) + (welcome-page :initarg :welcome-page + :accessor lisplet-welcome-page) + (realm :initarg :realm + :reader lisplet-realm) + (pages :initform nil + :accessor lisplet-pages) + (page404 :initarg :page404 + :accessor lisplet-page404)) + (:default-initargs :welcome-page nil :realm nil :page404 (make-instance 'page404))) + +(defun build-lisplet-location (lisplet location) + (let ((server-base-path *clawserver-base-path*) + (base-path (lisplet-base-path lisplet))) + (if location + (setf location (format nil "~a/~a" base-path location)) + (setf location base-path)) + (unless (null server-base-path) + (setf location (format nil "~a~a" server-base-path location))) + location)) + +(defmethod lisplet-register-page-location ((obj lisplet) page-class location &optional welcome-pagep) + (let ((pages (lisplet-pages obj)) + (new-location (build-lisplet-location obj location))) + (setf (lisplet-pages obj) + (sort-dispatchers (push-dispatcher + (cons new-location + (create-prefix-dispatcher new-location + #'(lambda () + (with-output-to-string + (*standard-output*) + (page-render (make-instance page-class :lisplet obj :url new-location)))) + (lisplet-realm obj))) + pages))) + (when welcome-pagep + (setf (lisplet-welcome-page obj) new-location)))) + +(defmethod lisplet-register-resource-location ((obj lisplet) resource-path location) + (let ((pages (lisplet-pages obj)) + (new-location (build-lisplet-location obj location))) + (set (lisplet-pages obj) + (sort-dispatchers (push-dispatcher + (cons new-location + (create-folder-dispatcher-and-handler new-location resource-path)) + pages))))) + +(defmethod lisplet-dispatch-request ((obj lisplet)) + (let ((pages (lisplet-pages obj))) + (loop for dispatcher in pages + for action = (funcall (cdr dispatcher) *request*) + when action return (funcall action)))) + +(defmethod lisplet-dispatch-method ((obj lisplet)) + (let ((page404 (lisplet-page404 obj)) + (result nil) + (base-path (build-lisplet-location obj nil)) + (uri (request-uri)) + (welcome-page (lisplet-welcome-page obj))) + (if (and welcome-page (string= uri base-path)) + (progn + (redirect (lisplet-welcome-page obj)) + t) + (progn + (setf result (lisplet-dispatch-request obj)) + (when (null result) + (setf result (with-output-to-string (*standard-output*) (page-render page404)))) + result)))) Added: trunk/main/claw-core/src/misc.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/misc.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,63 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/tags.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) + + +(defun strings-to-jsarray (strings) + "Transforms a list of strings into a javascript array." + (let ((st-size (length strings)) + (items "")) + (cond ((= st-size 0) "[]") + ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) + (t (format nil (format nil "[~a~a]" + (prin1-to-string (first strings)) + (progn + (dolist (str (rest strings)) + (setf items (format nil "~a,~a" + items (prin1-to-string str)))) + items))))))) + +(defun sort-dispatchers (dispatchers) + "Sorts a list of dispatcher. A dispatcher is a cons where the car is the url +where the dispatcher method(the cdr) will be called." + (sort dispatchers #'(lambda (item1 item2) + (string-not-lessp (car item1) (car item2))))) + +(defun remove-dispatcher-by-location (location dispatchers) + "Removes a dispatcher cons (location.dispatcher-method) checking its car +against the location parameter" + (delete-if #'(lambda (dispatcher) (string= (car dispatcher) location)) dispatchers)) + +(defun push-dispatcher (dispatcher dispatchers) + "Isert a new dispatcher into dispatchers, or replace the one that has the same location +registered (its car)." + (let ((result (remove-dispatcher-by-location (car dispatcher) dispatchers))) + (setf result (push dispatcher dispatchers)))) + Added: trunk/main/claw-core/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/packages.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,247 @@ +;;; -*- 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) + +(export 'HUNCHENTOOT::REQUEST-REALM 'HUNCHENTOOT) +(export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT) + +(defpackage :claw + (:use :cl :hunchentoot :alexandria :cl-ppcre) + (:export :*html-4.01-strict* + :*html-4.01-transitional* + :*html-4.01-frameset* + :*xhtml-1.0-strict* + :*xhtml-1.0-transitional* + :*xhtml-1.0-frameset* + :*default-encoding* + :*rewind-parameter* + :*clawserver-base-path* + ;:request-realm + :request-id-table-map + ;:dyna-id + :tag-empty-p + :tag-symbol-class + :strings-to-jsarray + :empty-string-p + :build-tagf + :parse-htcomponent-function + :page ;page classes hadle the whole rendering cycle + :page-writer + :page-can-print + :page-url + :page-lisplet + :page-current-form + :page-req-parameter + :page-json-id-list + :page-format + :page-format-raw + :page-script-files + :page-stylesheet-files + :page-class-initscripts + :page-instance-initscripts + :page-indent + :page-xmloutput + :page-doc-type + :htclass-body + :htcomponent + :htcomponent-page + :htcomponent-body +; :setf-htcomponent-page + :htcomponent-attributes + :htcomponent-can-print + :htcomponent-empty + :htcomponent-client-id + :htcomponent-script-files + :htcomponent-stylesheet-files + :htcomponent-class-initscripts + :htcomponent-instance-initscript + :tag ;class for tags that accept body + :tag-name + :tag-render-starttag + :tag-render-endtag + :htbody + :page-body-init-scripts + :htscript + :htlink + :hthead + :htstring + :$> + :$raw> + ;empty tags definition + :area> + :base> + :basefont> + :br> + :col> + :frame> + :hr> + :img> + :input> + :isindex> + :link> + :meta> + :param> + ;standard tags + :a> + :abbr> + :acronym> + :address> + :applet> + :b> + :bdo> + :big> + :blockquote> + :body> + :button> + :caption> + :center> + :cite> + :code> + :colgroup> + :dd> + :del> + :dfn> + :dir> + :div> + :dl> + :dt> + :em> + :fieldset> + :font> + :form> + :frameset> + :h1> + :h2> + :h3> + :h4> + :h5> + :h6> + :head> + :html> + :i> + :iframe> + :ins> + :kbd> + :label> + :legend> + :li> + :map> + :menu> + :noframes> + :noscript> + :object> + :ol> + :optgroup> + :option> + :p> + :pre> + :q> + :s> + :samp> + :script> + :select> + :small> + :span> + :strike> + :strong> + :style> + :sub> + :sup> + :table> + :tbody> + :td> + :textarea> + :tfoot> + :th> + :thead> + :title> + :tr> + :tt> + :u> + :ul> + :var> + ;; class modifiers + :page-content + :page-render + :generate-id + :wcomponent + :wcomponent-parameters + :wcomponent-informal-parameters + :wcomponent-allow-informal-parametersp + :wcomponent-template + :wcomponent-parameter-value + :wcomponent-before-rewind + :wcomponent-after-rewind + :wcomponent-before-prerender + :wcomponent-after-prerender + :wcomponent-before-render + :wcomponent-after-render + :make-component + :defcomponent + :cform + :cform> + :action-link + :action-link> + :cinput + :cinput> + :cselect + :cselect> + :csubmit + :csubmit> + :submit-link + :submit-link> + :lisplet + :lisplet-realm + :lisplet-pages + :lisplet-base-path + :lisplet-dispatch-method + :lisplet-register-page-location + :lisplet-register-resource-location + ;; clawserver + :clawserver + :clawserver-register-lisplet + :clawserver-unregister-lisplet + :clawserver-start + :clawserver-stop + :clawserver-port + :clawserver-sslport + :clawserver-address + :clawserver-name + :clawserver-sslname + :clawserver-mod-lisp-p + :clawserver-use-apache-log-p + :clawserver-input-chunking-p + :clawserver-read-timeout + :clawserver-write-timeout + #+(and :unix (not :win32)) :clawserver-setuid + #+(and :unix (not :win32)) :clawserver-setgid + #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file + #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file + #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password)) Added: trunk/main/claw-core/src/server.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/server.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,389 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/server.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) + +(defgeneric clawserver-register-lisplet (obj lisplet-obj) + (:documentation "This method registers a lisplet for request dispatching +- OBJ the CLAWSERVER instance +- LISPLET-OBJ the LISPLET instance")) + +(defgeneric clawserver-unregister-lisplet (obj lisplet-obj) + (:documentation "This method unregisters a lisplet from request dispatching +- OBJ the CLAWSERVER instance +- LISPLET-OBJ the LISPLET instance")) + +(defgeneric clawserver-dispatch-request (obj)) ;internal +(defgeneric clawserver-dispatch-method (obj)) ;internal + +(defgeneric clawserver-start (obj) + (:documentation "Starts the server")) +(defgeneric clawserver-stop (obj) + (:documentation "Stops the server")) + +(defgeneric (setf clawserver-port) (val obj)) +(defgeneric (setf clawserver-sslport) (val obj)) +(defgeneric (setf clawserver-address) (val obj)) +(defgeneric (setf clawserver-name) (val obj)) +(defgeneric (setf clawserver-sslname) (val obj)) +(defgeneric (setf clawserver-mod-lisp-p) (val obj)) +(defgeneric (setf clawserver-use-apache-log-p) (val obj)) +(defgeneric (setf clawserver-input-chunking-p) (val obj)) +(defgeneric (setf clawserver-read-timeout) (val obj)) +(defgeneric (setf clawserver-write-timeout) (val obj)) +#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (val obj)) +#+(and :unix (not :win32)) (defgeneric (setf clawserver-setgid) (val obj)) +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-certificate-file) (val obj)) +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-file) (val obj)) +#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-password) (val obj)) + + +(defclass page404 (page) + ((style :initform + " +body { + font-family: arial, elvetica; + font-size: 7pt; +} +span.blue { + background-color: #525D76; + color: white; + font-weight: bolder; + margin-right: .25em; +} +p.h1, p.h2 { + background-color: #525D76; + color: white; + font-weight: bolder; + font-size: 2em; + margin: 0; + margin-bottom: .5em; +} +p.h2 {font-size: 1.5em;}" + :reader page404-style)) + (:documentation "This page class is used to render +the 404 (page not found) messages.")) + +(defmethod page-content ((obj page404)) + (html> + (head> + (title> + "404 Page not found") + (style> + (page404-style obj))) + (body> + (p> + (p> :class "h1" + (format nil "HTTP Status 404 - ~a" (request-uri *request*))) + (hr> :noshade "noshade") + (p> + (span> :class "blue" + ($> "type")) + "Status report") + (p> + (span> :class "blue" + "message") + (request-uri *request*)) + (p> + (span> :class "blue" + "description") + (format nil "The requested resource (~a) is not available." (request-uri *request*))) + (hr> :noshade "noshade")) + (p> :class "h2" + "cl-webobject server")))) + +(defclass clawserver () + ((port :initarg :port + :reader clawserver-port) + (sslport :initarg :sslport + :reader clawserver-sslport) + (address :initarg :address + :reader clawserver-address) + (name :initarg :name + :reader clawserver-name) + (sslname :initarg :sslname + :reader clawserver-sslname) + (mod-lisp-p :initarg :mod-lisp-p + :reader clawserver-mod-lisp-p) + (use-apache-log-p :initarg :use-apache-log-p + :reader clawserver-use-apache-log-p) + (input-chunking-p :initarg :input-chunking-p + :reader clawserver-input-chunking-p) + (read-timeout :initarg :read-timeout + :reader clawserver-read-timeout) + (write-timeout :initarg :write-timeout + :reader clawserver-write-timeout) + #+(and :unix (not :win32)) (setuid :initarg :setuid + :reader clawserver-setuid) + #+(and :unix (not :win32)) (setgid :initarg :setgid + :reader clawserver-setgid) + #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file + :reader clawserver-ssl-certificate-file) + #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file + :reader clawserver-ssl-privatekey-file) + #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password + :reader clawserver-ssl-privatekey-password) + (server :initform nil + :accessor clawserver-server) + (sslserver :initform nil + :accessor clawserver-sslserver) + (lisplets :initform nil + :accessor clawserver-lisplets) + (page404 :initarg :page404 + :accessor clawserver-page404)) + (:default-initargs :address nil + :name (gensym) + :sslname (gensym) + :port 80 + :sslport 443 + :mod-lisp-p nil + :input-chunking-p t + :read-timeout *default-read-timeout* + :write-timeout *default-write-timeout* + #+(and :unix (not :win32)) :setuid nil + #+(and :unix (not :win32)) :setgid nil + #-:hunchentoot-no-ssl :ssl-certificate-file nil + #-:hunchentoot-no-ssl :ssl-privatekey-password nil + :page404 (make-instance 'page404)) + (:documentation "CLAWSERVER is built around huncentoot and has the +instructions for lisplet dispatching, so use this class to start and stop +hunchentoot server.")) + +(defmethod initialize-instance :after ((obj clawserver) &rest keys) + (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined)) + #-:hunchentoot-no-ssl (ssl-privatekey-file (getf keys :ssl-privatekey-file :undefined))) + (when (eq use-apache-log-p :undefined) + (setf (clawserver-use-apache-log-p obj) (getf keys :mod-lisp-p))) + #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) + (setf (clawserver-ssl-privatekey-file obj) (getf keys :ssl-certificate-file))))) + +(defmethod clawserver-register-lisplet ((obj clawserver) (lisplet-obj lisplet)) + (let ((lisplets (clawserver-lisplets obj)) + (server-base-path *clawserver-base-path*) + (location (lisplet-base-path lisplet-obj))) + (unless (null server-base-path) + (setf location (format nil "~@[~a~]~a" server-base-path location))) + (setf (clawserver-lisplets obj) (sort-dispatchers (push-dispatcher + (cons location + (create-prefix-dispatcher + location + #'(lambda () + (lisplet-dispatch-method lisplet-obj)) + (lisplet-realm lisplet-obj))) + lisplets))))) + +(defmethod clawserver-unregister-lisplet ((obj clawserver) (lisplet-obj lisplet)) + (let ((lisplets (clawserver-lisplets obj)) + (server-base-path *clawserver-base-path*) + (location (lisplet-base-path lisplet-obj))) + (unless (null server-base-path) + (setf location (format nil "~@[~a~]~a" server-base-path location))) + (remove-dispatcher-by-location location lisplets))) + + +;;;-------------------------- WRITERS ---------------------------------------- + +(defmethod (setf clawserver-port) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change port when server is started")) + (setf (slot-value obj 'port) val)) + +(defmethod (setf clawserver-sslport) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change SSL port when server is started")) + (setf (slot-value obj 'sslport) val)) + +(defmethod (setf clawserver-address) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change binding address when server is started")) + (setf (slot-value obj 'address) val)) + +(defmethod (setf clawserver-name) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (setf (server-name (clawserver-server obj)) val)) + (setf (slot-value obj 'name) val)) + +(defmethod (setf clawserver-sslname) (val (obj clawserver)) + (unless (null (clawserver-sslserver obj)) + (setf (server-name (clawserver-sslserver obj)) val)) + (setf (slot-value obj 'sslname) val)) + +(defmethod (setf clawserver-mod-lisp-p) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change mod-lisp property when server is started")) + (setf (slot-value obj 'mod-lisp-p) val)) + +(defmethod (setf clawserver-use-apache-log-p) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change logging property when server is started")) + (setf (slot-value obj 'use-apache-log-p) val)) + +(defmethod (setf clawserver-input-chunking-p) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change chunking property when server is started")) + (setf (slot-value obj 'input-chunking-p) val)) + +(defmethod (setf clawserver-read-timeout) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change read timeout property when server is started")) + (setf (slot-value obj 'read-timeout) val)) + +(defmethod (setf clawserver-write-timeout) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change write timeout property when server is started")) + (setf (slot-value obj 'write-timeout) val)) + +#+(and :unix (not :win32)) (defmethod (setf clawserver-setuid) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change uid property when server is started")) + (setf (slot-value obj 'setuid) val)) + +#+(and :unix (not :win32)) (defmethod (setf clawserver-setgid) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change gid property when server is started")) + (setf (slot-value obj 'setgid) val)) + +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-certificate-file) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change ssl certificate file property when server is started")) + (setf (slot-value obj 'ssl-certificate-file) val)) + +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-file) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change ssl privatekey file property when server is started")) + (setf (slot-value obj 'ssl-privatekey-file) val)) + +#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-password) (val (obj clawserver)) + (unless (null (clawserver-server obj)) + (error "Cannot change ssl privatekey password property when server is started")) + (setf (slot-value obj 'ssl-privatekey-password) val)) + +;;;-------------------------- METHODS ---------------------------------------- +(defmethod clawserver-dispatch-request ((obj clawserver)) + (let ((lisplets (clawserver-lisplets obj))) + (loop for dispatcher in lisplets + for action = (funcall (cdr dispatcher) *request*) + when action return (funcall action)))) + +(defmethod clawserver-dispatch-method ((obj clawserver)) + (let ((page404 (clawserver-page404 obj)) + (result nil)) + (progn + (setf result (clawserver-dispatch-request obj)) + (if (null result) + #'(lambda () (with-output-to-string (*standard-output*) (page-render page404))) + #'(lambda () result))))) + +(defmethod clawserver-start ((obj clawserver)) + (let ((port (clawserver-port obj)) + (sslport (clawserver-sslport obj)) + (address (clawserver-address obj)) + (dispatch-table (list #'(lambda (request) + (declare (ignorable request)) + (clawserver-dispatch-method obj)))) + (name (clawserver-name obj)) + (sslname (clawserver-sslname obj)) + (mod-lisp-p (clawserver-mod-lisp-p obj)) + (use-apache-log-p (clawserver-use-apache-log-p obj)) + (input-chunking-p (clawserver-input-chunking-p obj)) + (read-timeout (clawserver-read-timeout obj)) + (write-timeout (clawserver-write-timeout obj)) + (uid (clawserver-setuid obj)) + (gid (clawserver-setgid obj)) + (ssl-certificate-file (clawserver-ssl-certificate-file obj)) + (ssl-privatekey-file (clawserver-ssl-privatekey-file obj)) + (ssl-privatekey-password (clawserver-ssl-privatekey-password obj))) + (progn + (setf (clawserver-server obj) + (start-server :port port + :address address + :dispatch-table dispatch-table + :name name + :mod-lisp-p mod-lisp-p + :use-apache-log-p use-apache-log-p + :input-chunking-p input-chunking-p + :read-timeout read-timeout + :write-timeout write-timeout + #+(and :unix (not :win32)) :setuid uid + #+(and :unix (not :win32)) :setgid gid)) + #-:hunchentoot-no-ssl (when ssl-certificate-file + (setf (clawserver-sslserver obj) + (start-server :port sslport + :address address + :dispatch-table dispatch-table + :name sslname + :mod-lisp-p mod-lisp-p + :use-apache-log-p use-apache-log-p + :input-chunking-p input-chunking-p + :read-timeout read-timeout + :write-timeout write-timeout + #+(and :unix (not :win32)) :setuid uid + #+(and :unix (not :win32)) :setgid gid + :ssl-certificate-file ssl-certificate-file + :ssl-privatekey-file ssl-privatekey-file + :ssl-privatekey-password ssl-privatekey-password)))))) + +(defmethod clawserver-stop ((obj clawserver)) + (progn + (setf (clawserver-server obj) (stop-server (clawserver-server obj))) + (when (clawserver-sslserver obj) + (setf (clawserver-sslserver obj) (stop-server (clawserver-sslserver obj)))))) +;;;---------------------------------------------------------------------------- +(defun start-clawserver (clawserver-obj + &key (port 80) + address + (name (gensym)) + (mod-lisp-p nil) + (use-apache-log-p mod-lisp-p) + (input-chunking-p t) + (read-timeout *default-read-timeout*) + (write-timeout *default-write-timeout*) + #+(and :unix (not :win32)) setuid + #+(and :unix (not :win32)) setgid + #-:hunchentoot-no-ssl ssl-certificate-file + #-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file) + #-:hunchentoot-no-ssl ssl-privatekey-password) + (start-server :port port + :address address + :dispatch-table (list #'(lambda (request) + (declare (ignorable request)) + (clawserver-dispatch-method clawserver-obj))) + :name name + :mod-lisp-p mod-lisp-p + :use-apache-log-p use-apache-log-p + :input-chunking-p input-chunking-p + :read-timeout read-timeout + :write-timeout write-timeout + #+(and :unix (not :win32)) :setuid setuid + #+(and :unix (not :win32)) :setgid setgid + #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file + #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file + #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password)) + + \ No newline at end of file Added: trunk/main/claw-core/src/tags.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/tags.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,1042 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/tags.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 EXPRESSEDse +;;; 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) + + + +(defgeneric page-req-parameter (obj name &optional as-list) + (:documentation "This method returns a request parameter given by NAME searching first +into post parameters and, if no parameter found, into get prarmeters. +The optional function parameter AS-LIST if true returns the result as list. +When AS-LIST is true, if the searched parameter is found more then once, a list with +all valuse given to param NAME is returned. + - OBJ is the page instance that must be given. + - NAME The parameter to search + - AS-LIST If true the result is returned as list, if false as string. Default: false")) + +(defgeneric page-json-id-list (obj) + (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when +an xhr request is sent from the browser. + - OBJ is the page instance that must be given")) + +(defgeneric page-content (obj) + (:documentation "This method returns the page content to be redered. + - OBJ is the page instance that must be given")) + +(defgeneric page-init (obj) + (:documentation "Internal method for page initialization. + - OBJ is the page instance that must be given")) + +(defgeneric page-render (obj) + (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. + - OBJ is the page instance that must be given")) + +(defgeneric page-init-injections (pobj) + (:documentation "This internal method is called during the request cycle phase to reset page slots that +must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). + - OBJ is the page instance that must be given")) + +(defgeneric page-render-headings (obj) + (:documentation "This internal method renders the html first lines that determine if the page is a html or a xhtml, along with the schema definition. + - OBJ is the page instance that must be given")) + +(defgeneric page-request-parameters (obj) + (:documentation "This internal method builds the get and post parameters into an hash table. + - OBJ is the page instance that must be given")) + +(defgeneric page-print-tabulation (obj) + (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount +of tabs chars to indent the page. + - OBJ is the page instance that must be given")) + +(defgeneric page-newline (obj) + (:documentation "This internal method simply writes the rest of page content on a new line when needed. + - OBJ is the page instance that must be given")) + +(defgeneric page-format (obj str &rest rest) + (:documentation "This internal method is the replacement of the FORMAT function. It is aware +of an xhr request when the reply must be given as a json object. It also uses the default page output stream +to render the output. + - OBJ is the page instance that must be given + - STR The format control + - REST The format arguments +See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) + +(defgeneric page-format-raw (obj str &rest rest) + (:documentation "This internal method is the replacement of the FORMAT. +The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive. +It also uses the default page output stream as PAGE-FORMAT does to render the output. + - OBJ is the page instance that must be given + - STR The format control + - REST The format arguments +See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) + +(defgeneric page-body-init-scripts (page-obj) + (:documentation "During the render phase wcomponent instances inject their initialization scripts (javascript) +that will be evaluated when the page has been loaded. +This internal method is called to render these scripts. + - PAGE-OBJ is the page instance that must be given")) + +(defgeneric htbody-init-scripts-tag (page-obj) + (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component +See PAGE-BODY-INIT-SCRIPTS form more info. + - PAGE-OBJ is the page instance that must be given")) + +(defgeneric htcomponent-rewind (obj page-obj) + (:documentation "This internal method is the first called during the request cycle phase. +It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. + - OBJ is the htcomponent instance that must be rewound + - PAGE-OBJ is the page instance that must be given")) + +(defgeneric htcomponent-prerender (obj page-obj) + (:documentation "This internal method is the second sub phase during the request cycle phase. +It is used to inject all wcomponent class scripts and stylesheets into the owner page. + - OBJ is the htcomponent instance that must be prerendered + - PAGE-OBJ is the page instance that must be given")) + +(defgeneric htcomponent-render (obj page-obj) + (:documentation "This internal method is the last called during the request cycle phase. +It is used to effectively render the component into the page. + - OBJ is the htcomponent instance that must be rendered + - PAGE-OBJ is the page instance that must be given")) + +(defgeneric htcomponent-can-print (obj) + (:documentation "This internal method is used in an xhr call to determine +if a component may be rendered into the reply + - OBJ is the htcomponent instance")) + +(defgeneric htcomponent-json-print-start-component (obj) + (:documentation "Internal method called to render the json reply during the render cycle phase +on component start. + - OBJ is the htcomponent instance")) + +(defgeneric htcomponent-json-print-end-component (obj) + (:documentation "Internal method called to render the json reply during the render cycle phase +on component end. + - OBJ is the htcomponent instance")) + +(defgeneric tag-render-starttag (obj page-obj) + (:documentation "Internal method to print out the opening html tag during the render phase + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric tag-render-endtag (obj page-obj) + (:documentation "Internal method to print out the closing html tag during the render phase + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric tag-render-attributes (obj page-obj) + (:documentation "Internal method to print out the attributes of an html tag during the render phase + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric (setf htcomponent-page) (page-obj obj) + (:documentation "Internal method to set the component owner page and to assign +an unique id attribute when provided. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric wcomponent-parameter-value (obj key) + (:documentation "Returns the value of a parameter passed to the wcomponent initialization +function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed. + - OBJ is the wcomponent instance + - KEY the parameter key to query")) + +(defgeneric wcomponent-check-parameters(obj) + (:documentation "This internal method check if all :REQUIRED parameters are provided + - OBJ is the wcomponent instance")) + +(defgeneric wcomponent-parameters(obj) + (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component) + - OBJ is the wcomponent instance")) +(defgeneric wcomponent-informal-parameters(obj) + (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component, +usually rendered as tag attributes withot any kind of evaluation) + - OBJ is the wcomponent instance")) + +(defgeneric wcomponent-before-rewind (obj page-obj) + (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric wcomponent-after-rewind (obj page-obj) + (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) +(defgeneric wcomponent-before-prerender (obj page-obj) + (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric wcomponent-after-prerender (obj page-obj) + (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) +(defgeneric wcomponent-before-render (obj page-obj) + (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defgeneric wcomponent-after-render (obj page-obj) + (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes. + - OBJ is the tag instance + - PAGE-OBJ the page instance")) + +(defvar *clawserver-base-path* nil) + +(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" "Page doctype as HTML 4.01 STRICT") + +(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" "Page doctype as HTML 4.01 TRANSITIONAL") + +(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" "Page doctype as HTML 4.01 FRAMESET") + +(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" "Page doctype as HTML 4.01 XHTML") + +(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" "Page doctype as XHTML 4.01 TRANSITIONAL") + +(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") + +(defvar *default-encoding* "UTF-8" "Page default encoding (if no changes 'UTF-8')") + +(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") + +(defvar *empty-tags* + (list "area" "base" "basefont" "br" "col" "frame" + "hr" "img" "input" "isindex" "meta" + "param" "link")) + +(defun request-id-table-map () + "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. +So if you have a :id \"compId\" given to a previous component, the second +time this id will be used, it will be rendered as \"compId1\", the third time will be \"compId2\" and so on" + (when (boundp '*request*) + (let ((id-table-map (aux-request-value :id-table-map))) + (if (null id-table-map) + (progn + (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) + id-table-map)))) + +(defun reset-request-id-table-map () + "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. +See REQUEST-ID-TABLE-MAP for more info." + (when (boundp '*request*) + (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))) + + +(defun parse-htcomponent-function (function-body) + "This function parses attributes passed to a htcomponent creation function" + (let ((attributes) + (body)) + (loop for last-elem = nil then elem + for elem in function-body + do (if (or (and (stringp last-elem) (stringp elem)) + (and (null last-elem) (stringp elem)) + (subtypep (type-of elem) 'htcomponent) + (and (evenp (length attributes)) (stringp elem)) + body) + (push elem body) + (push elem attributes))) + (list (reverse attributes) (reverse body)))) + +(defun generate-id (id) + "This function is very useful when having references to components id inside component body. +When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." + (let* ((id-ht (request-id-table-map)) + (client-id-index (gethash id id-ht 0)) + (result)) + (if (= 0 client-id-index) + (setf result id) + (setf result (format nil "~a~d" id client-id-index))) + (setf (gethash id id-ht) (1+ client-id-index)) + result)) + +(defun build-tagf (tag-name parent empty-p &rest rest) + "This function is used to create a tag object instance +- TAG-NAME the a string tag name to create, for example \"span\" +- PARENT the parent class. usually 'TAG +- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase. +- REST a list of attribute/value pairs and the component body" + (let* ((fbody (parse-htcomponent-function (flatten rest))) + (id-table-map (request-id-table-map)) + (id (getf (first fbody) :id)) + (static-id (getf (first fbody) :static-id)) + (instance)) + (unless (null static-id) + (remf (first fbody) :id) + (setf id nil)) + (setf instance (make-instance parent + :empty empty-p + :name (string-downcase tag-name) + :attributes (first fbody) + :body (second fbody))) + (if (null static-id) + (unless (or (null id-table-map) (null id)) + (setf (htcomponent-client-id instance) + (generate-id id))) + (setf (htcomponent-client-id instance) static-id)) + instance)) + +(defun generate-tagf (tag-name empty-p) + "Internal function that generates an htcomponent creation function from the component class name +- TAG-NAME the symbol class name of the component +- EMPTY-P determines if the tag must be rendered as an empty tag during the request cycle phase." + (setf (fdefinition (intern (format nil "~a>" (string-upcase tag-name)))) + #'(lambda (&rest rest) (build-tagf tag-name 'tag empty-p rest)))) + + +;;;---------------------------------------------------------------- + + + +(defclass page() + ((writer :initarg :writer + :accessor page-writer :documentation "The output stream for this page instance") + (lisplet :initarg :lisplet + :reader page-lisplet :documentation "The lisplet that owns this page instance") + (can-print :initform nil + :accessor page-can-print) + (script-files :initarg :script-files + :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") + (stylesheet-files :initarg :stylesheet-files + :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") + (class-initscripts :initarg :class-initscripts + :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") + (instancee-initscripts :initarg :instance-initscripts + :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") + (indent :initarg :indent + :accessor page-indent :documentation "Determine if the output must be indented or not") + (tabulator :initarg :tabulator + :accessor page-tabulator :documentation "Holds the indentation level") + (xmloutput :initarg :xmloutput + :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") + (current-form :initform :nil + :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") + (content-type :initarg :doc-type + :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") + (lasttag :initform nil + :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") + (json-component-count :initarg :json-component-count + :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") + (request-parameters :initarg :request-parameters) + (url :initarg :url + :accessor page-url :documentation "The URL provided with this page instance")) + (:default-initargs :writer t + :script-files nil + :json-component-count 0 + :stylesheet-files nil + :class-initscripts nil + :instance-initscripts nil + :indent t + :tabulator 0 + :xmloutput nil + :doc-type *html-4.01-strict* + :request-parameters nil + :url nil) + (:documentation "A page object holds claw components to be rendered") ) + +(defclass htcomponent () + ;class for html tags + ((page :initarg :page + :reader htcomponent-page :documentation "The owner page") + (body :initarg :body + :accessor htcomponent-body :documentation "The tag body") + (client-id :initarg :client-id + :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") + (attributes :initarg :attributes + :accessor htcomponent-attributes :documentation "The tag attributes") + (empty :initarg :empty + :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") + (script-files :initarg :script-files + :accessor htcomponent-script-files :documentation "Page injectable script files") + (stylesheet-files :initarg :stylesheet-files + :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") + (class-initscripts :initarg :class-initscripts + :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") + (instance-initscript :initarg :instance-initscript + :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) + (:default-initargs :page nil + :body nil + :client-id nil + :attributes nil + :empty nil + :script-files nil + :stylesheet-files nil + :class-initscripts nil + :instance-initscript nil) + (:documentation "Base class for all other claw components")) + +(defclass tag (htcomponent) + ((name :initarg :name + :reader tag-name :documentation "The tag name to be rendered")) + (:default-initargs :name nil) + (:documentation "This class is used to render the most part of html tags")) + +(defclass htstring (htcomponent) + ((raw :initarg :raw + :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) + (:default-initargs :raw nil) + (:documentation "Component needed to render strings")) + +(defmethod initialize-instance :after ((inst tag) &rest keys) + (let ((empty-p (getf keys :empty)) + (body (getf keys :body))) + (when (and (not (null empty-p)) + (not (null body))) + (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) + +(defun $> (value) + "Creates an escaping htstring component" + (make-instance 'htstring :body value)) + +(defun $raw> (value) + "Creates a non escaping htstring component" + (make-instance 'htstring :body value :raw t)) + +(defclass htscript (tag) () + (:documentation "Creates a component for rendering a <script> tag")) + +(defun script> (&rest rest) + (build-tagf "script" 'htscript nil rest)) + +(defclass htlink (tag) () + (:documentation "Creates a component for rendering a <link> tag")) + +(defun link> (&rest rest) + (build-tagf "link" 'htlink t rest)) + +(defclass htbody (tag) () + (:documentation "Creates a component for rendering a <body> tag")) + +(defun body> (&rest rest) + (build-tagf "body" 'htbody nil rest)) + +(defclass hthead (tag) () + (:documentation "Creates a component for rendering a <head> tag")) + +(defun head> (&rest rest) + (build-tagf "head" 'hthead nil rest)) + +(mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) + ;;Creates empty tag initialization functions. But the ones directly defined + '("area" "base" "basefont" "br" "col" "frame" + "hr" "img" "input" "isindex" "meta" + "param")) + +(mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) + ;;Creates non empty tag initialization functions. But the ones directly defined + '("a" "abbr" "acronym" "address" "applet" + "b" "bdo" "big" "blockquote" "button" + "caption" "center" "cite" "code" "colgroup" + "dd" "del" "dfn" "dir" "div" "dl" "dt" + "em" + "fieldset" "font" "form" "frameset" + "h1" "h2" "h3" "h4" "h5" "h6" "html" + "i" "iframe" "ins" + "kbd" + "label" "legend" "li" + "map" "menu" + "noframes" "noscript" + "object" "ol" "optgroup" "option" + "p" "pre" + "q" + "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" + "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" + "u" "ul" "var")) + +(defun tag-empty-p (tag-name) + "Returns if a tag defined by the string TAG-NAME is empty" + (member tag-name *empty-tags* :test #'string-equal)) + +(defun tag-symbol-class (tag-name) + "Returns the symbol class for a given TAG-NAME" + (let ((name (string-downcase tag-name))) + (cond ((string= name "script") 'htscript) + ((string= name "link") 'htlink) + ((string= name "body") 'htbody) + ((string= name "head") 'hthead) + (t 'tag)))) +;;;--------------------METHODS implementation---------------------------------------------- + +(defmethod (setf htcomponent-page) ((pobj page) (obj htcomponent)) + (let ((id (getf (htcomponent-attributes obj) :id)) + (static-id (getf (htcomponent-attributes obj) :static-id))) + (setf (slot-value obj 'page) pobj) + (unless (and (null id) (null static-id)) + (let ((client-id (htcomponent-client-id obj))) + (when (null client-id) + (if (null static-id) + (setf (htcomponent-client-id obj) (generate-id id)) + (setf (htcomponent-client-id obj) static-id))))))) + +(defmethod page-request-parameters ((pobj page)) + (if (and (boundp '*request*) (null (slot-value pobj 'request-parameters))) + (let ((parameters (append (post-parameters) (get-parameters))) + (pparameters (make-hash-table :test 'equal))) + (loop for kv in parameters + do (setf (gethash (string-upcase (car kv)) pparameters) + (append (gethash (string-upcase (car kv)) pparameters) + (list (cdr kv))))) + (setf (slot-value pobj 'request-parameters) pparameters)) + (slot-value pobj 'request-parameters))) + +(defmethod page-req-parameter ((pobj page) name &optional as-list) + (let ((parameters (page-request-parameters pobj)) + (retval)) + (unless (null parameters) + (setf retval (gethash (string-upcase name) parameters)) + (if (or (null retval) as-list) + retval + (first retval))))) + +(defmethod page-format ((obj page) str &rest rest) + (let ((json-p (page-json-id-list obj)) + (writer (page-writer obj))) + (if (null json-p) + (apply #'format writer str rest) + (apply #'format writer (list + (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + (apply #'format nil str rest) + "\\n") + "\\\\\\\"") + "\\\"")))))) + +(defmethod page-format-raw ((obj page) str &rest rest) + (let ((writer (page-writer obj))) + (apply #'format writer str rest))) + +(defmethod page-json-id-list ((obj page)) + (page-req-parameter obj "json" t)) + +(defmethod page-init ((obj page)) + (progn + (reset-request-id-table-map) + (setf (page-can-print obj) (null (page-json-id-list obj))) + (reset-request-id-table-map) + (setf (page-tabulator obj) 0))) + +(defmethod page-render-headings ((obj page)) + (let* ((writer (page-writer obj)) + (json-p (page-json-id-list obj)) + (encoding (handler-case (format nil "~a" (stream-external-format writer)) + (error () (format nil "~a" *default-encoding*)))) + (xml-p (page-xmloutput obj)) + (content-type (page-doc-type obj))) + (when (null json-p) + (unless (null xml-p) + (page-format-raw obj "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (unless (null content-type) + (page-format-raw obj "~a~%" content-type))))) + +(defmethod page-render ((obj page)) + (let ((body (page-content obj)) + (json-p (page-json-id-list obj))) + (if (null body) + (format nil "null body for page ~a~%" (type-of obj)) + (progn + (page-init obj) + (unless (null (page-req-parameter obj *rewind-parameter*)) + (htcomponent-rewind body obj)) + (page-init obj) + (htcomponent-prerender (page-content obj) obj) ;Here we need a fresh new body!!! + (page-render-headings obj) + (page-init obj) + (unless (null json-p) + (page-format-raw obj "{components:{")) + (htcomponent-render (page-content obj) obj) ;Here we need a fresh new body!!! + (unless (null json-p) + (page-format-raw obj "},classInjections:\"") + (setf (page-can-print obj) t) + (dolist (injection (page-init-injections obj)) + (htcomponent-render injection obj)) + (page-format-raw obj "\",instanceInjections:\"") + (htcomponent-render (htbody-init-scripts-tag obj) obj) + (page-format-raw obj "\"}")))))) + +(defmethod page-body-init-scripts ((pobj page)) + (let ((js-body "")) + (dolist (current-js (reverse (page-instance-initscripts pobj))) + (setf js-body (format nil "~a~%~a~%" js-body current-js))) + (if (string= "" js-body) + js-body + (format nil "~a" js-body)))) + +(defmethod page-print-tabulation ((obj page)) + (let ((json-p (page-json-id-list obj)) + (tabulator (page-tabulator obj)) + (indent-p (page-indent obj))) + (when (and (<= 0 tabulator) indent-p (null json-p)) + (page-format-raw obj "~a" + (make-string tabulator :initial-element #\tab))))) + +(defmethod page-newline ((obj page)) + (let ((json-p (page-json-id-list obj)) + (indent-p (page-indent obj))) + (when (and indent-p (null json-p)) + (page-format-raw obj "~%")))) + +(defmethod page-init-injections ((pobj page)) + (let ((tag-list) + (class-init-scripts "")) + + (dolist (script (reverse (page-class-initscripts pobj))) + (setf class-init-scripts (format nil "~a~%~a" + class-init-scripts + script))) + (unless (string= "" class-init-scripts) + (let ((current-js (script> :type "text/javascript"))) + (setf (htcomponent-body current-js) class-init-scripts) + (push current-js tag-list))) + + (dolist (js-file (page-script-files pobj)) + (let ((current-js (script> :type "text/javascript" :src ""))) + (setf (getf (htcomponent-attributes current-js) :src) js-file) + (push current-js tag-list))) + + (dolist (css-file (page-stylesheet-files pobj)) + (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) + (setf (getf (htcomponent-attributes current-css) :href) css-file) + (push current-css tag-list))) + + tag-list)) + +;;;========= HTCOMPONENT ============================ +(defmethod htcomponent-can-print ((obj htcomponent)) + (let* ((id (htcomponent-client-id obj)) + (pobj (htcomponent-page obj)) + (print-status (page-can-print pobj)) + (render-p (member id (page-json-id-list pobj) :test #'string=))) + (or print-status render-p))) + +(defmethod htcomponent-json-print-start-component ((obj htcomponent)) + (let* ((pobj (htcomponent-page obj)) + (json-p (page-json-id-list pobj)) + (id (htcomponent-client-id obj))) + (unless (or (null json-p) (null (member id json-p :test #'string-equal))) + (when (> (page-json-component-count pobj) 0) + (page-format pobj ",")) + (page-format-raw pobj "~a:\"" id) + (incf (page-json-component-count pobj))))) + +(defmethod htcomponent-json-print-end-component ((obj htcomponent)) + (let* ((pobj (htcomponent-page obj)) + (json-p (page-json-id-list pobj)) + (id (htcomponent-client-id obj))) + (unless (or (null json-p) (null (member id json-p :test #'string-equal))) + (page-format-raw pobj "\"")))) + +(defmethod htcomponent-rewind :before ((obj htcomponent) (pobj page)) + (setf (htcomponent-page obj) pobj)) +(defmethod htcomponent-prerender :before ((obj htcomponent) (pobj page)) + (setf (htcomponent-page obj) pobj)) +(defmethod htcomponent-render :before ((obj htcomponent) (pobj page)) + (setf (htcomponent-page obj) pobj)) + +(defmethod htcomponent-rewind ((obj htcomponent) (pobj page)) + (dolist (tag (htcomponent-body obj)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-rewind tag pobj)))) + +(defmethod htcomponent-prerender ((obj htcomponent) (pobj page)) + (let ((previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj))) + (dolist (tag (htcomponent-body obj)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) nil)))) + +(defmethod htcomponent-render ((obj htcomponent) (pobj page)) + (let ((body-list (htcomponent-body obj)) + (previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (dolist (tag body-list) + (if (stringp tag) + (htcomponent-render ($> tag) pobj) + (htcomponent-render tag pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +;;;========= TAG ===================================== +(defmethod tag-render-attributes ((obj tag) (pobj page)) + (unless (null (htcomponent-attributes obj)) + (loop for (k v) on (htcomponent-attributes obj) by #'cddr + do (progn + (assert (keywordp k)) + (unless (null v) + (page-format pobj " ~a=\"~a\"" + (string-downcase (if (eq k :static-id) + "id" + (symbol-name k))) + (let ((s (if (eq k :id) + (prin1-to-string (htcomponent-client-id obj)) + (prin1-to-string v)))) ;escapes double quotes + (subseq s 1 (1- (length s)))))))))) + +(defmethod tag-render-starttag ((obj tag) (pobj page)) + (let ((tagname (tag-name obj)) + (empty-p (htcomponent-empty obj)) + (xml-p (page-xmloutput pobj))) + (setf (page-lasttag pobj) tagname) + (page-newline pobj) + (page-print-tabulation pobj) + (page-format pobj "<~a" tagname) + (tag-render-attributes obj pobj) + (if (null empty-p) + (progn + (page-format pobj ">") + (incf (page-tabulator pobj))) + (if (null xml-p) + (page-format pobj ">") + (page-format pobj "/>"))))) + +(defmethod tag-render-endtag ((obj tag) (pobj page)) + (let ((tagname (tag-name obj)) + (previous-tagname (page-lasttag pobj)) + (empty-p (htcomponent-empty obj))) + (when (null empty-p) + (progn + (decf (page-tabulator pobj)) + (if (string= tagname previous-tagname) + (progn + (page-format pobj "</~a>" tagname)) + (progn + (page-newline pobj) + (page-print-tabulation pobj) + (page-format pobj "</~a>" tagname))))) + (setf (page-lasttag pobj) nil))) + +(defmethod htcomponent-render ((obj tag) (pobj page)) + (let ((body-list (htcomponent-body obj)) + (previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (tag-render-starttag obj pobj)) + (dolist (tag body-list) + (if (stringp tag) + (htcomponent-render ($> tag) pobj) + (htcomponent-render tag pobj))) + (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (tag-render-endtag obj pobj)) + (when (null previous-print-status) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +;;;========= HTHEAD ====================================== +(defmethod htcomponent-render ((obj hthead) (pobj page)) + (when (null (page-json-id-list pobj)) + (let ((body-list (htcomponent-body obj)) + (injections (page-init-injections pobj))) + (tag-render-starttag obj pobj) + (dolist (tag body-list) + (if (stringp tag) + (htcomponent-render ($> tag) pobj) + (htcomponent-render tag pobj))) + (dolist (injection injections) + (htcomponent-render injection pobj)) + (tag-render-endtag obj pobj)))) + +;;;========= HTSTRING =================================== + +(defmethod htcomponent-rewind((obj htstring) (pobj page))) +(defmethod htcomponent-prerender((obj htstring) (pobj page))) + +(defmethod htcomponent-render ((obj htstring) (pobj page)) + (let ((body (htcomponent-body obj)) + (json-p (not (null (page-json-id-list pobj)))) + (print-p (page-can-print pobj))) + (unless (or (null print-p) (null body)) + (unless (null json-p) + (setf body (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + body + "\\n") + "\\\\\\\"") + "\\\""))) + (if (null (htstring-raw obj)) + (loop for ch across body + do (case ch + ((#\<) (page-format-raw pobj "<")) + ((#\>) (page-format-raw pobj ">")) + ((#\&) (page-format-raw pobj "&")) + (t (page-format-raw pobj "~a" ch)))) + (page-format-raw pobj body))))) + +;;;========= HTSCRIPT =================================== +(defmethod htcomponent-prerender((obj htscript) (pobj page))) + +(defmethod htcomponent-render ((obj htscript) (pobj page)) + (let ((xml-p (page-xmloutput pobj)) + (body (htcomponent-body obj)) + (previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (unless (getf (htcomponent-attributes obj) :type) + (append '(:type "text/javascript") (htcomponent-attributes obj))) + (unless (null (page-can-print pobj)) + (tag-render-starttag obj pobj) + (when (and (null (getf (htcomponent-attributes obj) :src)) + (not (null (htcomponent-body obj)))) + (if (null xml-p) + (page-format pobj "~%//<!--~%") + (page-format pobj "~%//<[CDATA[~%")) + (unless (listp body) + (setf body (list body))) + (dolist (element body) + (if (stringp element) + (htcomponent-render ($raw> element) pobj) + (htcomponent-render element pobj))) + (if (null xml-p) + (page-format pobj "~%//-->") + (page-format pobj "~%//]]>"))) + (setf (page-lasttag pobj) nil) + (tag-render-endtag obj pobj)) + (when (null previous-print-status) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +;;;========= HTLINK ==================================== + +(defmethod htcomponent-render ((obj htlink) (pobj page)) + (let ((previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (unless (null (page-can-print pobj)) + (unless (getf (htcomponent-attributes obj) :type) + (append '(:type "text/css") (htcomponent-attributes obj))) + (unless (getf (htcomponent-attributes obj) :rel) + (append '(:rel "styleshhet") (htcomponent-attributes obj))) + (tag-render-starttag obj pobj) + (tag-render-endtag obj pobj)) + (when (null previous-print-status) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +;;;========= HTBODY =================================== +(defmethod htcomponent-render ((obj htbody) (pobj page)) + (let ((body-list (htcomponent-body obj)) + (previous-print-status (page-can-print pobj))) + (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (unless (null (page-can-print pobj)) + (tag-render-starttag obj pobj)) + (dolist (tag body-list) + (if (stringp tag) + (htcomponent-render ($> tag) pobj) + (htcomponent-render tag pobj))) + (unless (null (page-can-print pobj)) + (htcomponent-render (htbody-init-scripts-tag pobj) pobj) + (tag-render-endtag obj pobj)) + (unless (or (null (page-can-print pobj)) (null previous-print-status)) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +(defmethod htbody-init-scripts-tag ((pobj page)) + (let ((js (script> :type "text/javascript"))) + (setf (htcomponent-page js) pobj) + (setf (htcomponent-body js) (page-body-init-scripts pobj)) + js)) + +;;;========= WCOMPONENT =================================== +(defclass wcomponent (htcomponent) + ((parameters :initarg :parameters + :accessor wcomponent-parameters + :type cons + :documentation "must be a plist or nil") + (reserved-parameters :initarg :reserved-parameters + :accessor wcomponent-reserved-parameters + :type cons :documentation "Parameters that may not be used in the constructor function") + (informal-parameters :initarg :informal-parameters + :accessor wcomponent-informal-parameters + :type cons :documentation "Informal parameters are parameters optional for the component") + (allow-informal-parameters :initarg :allow-informal-parameters + :reader wcomponent-allow-informal-parametersp + :allocation :class :documentation "Determines if the component accepts informal parameters") + (template :initform nil + :accessor wcomponent-template + :type htcomponent :documentation "The component template. What gives to each wcomponent its unique aspect and features")) + (:default-initargs :informal-parameters nil + :reserved-parameters nil + :parameters nil + :allow-informal-parameters t) + (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) + +(defmethod wcomponent-check-parameters((comp wcomponent)) + (let ((id nil) + (static-id nil)) + (loop for (k v) on (htcomponent-attributes comp) by #'cddr + do (progn (when (and (eql v ':required) (not (eq k :id))) + (error (format nil + "Parameter ~a of class ~a is required" + k (class-name (class-of comp))))) + (when (eq k :id) + (setf id v)) + (when (eq k :static-id) + (setf static-id v)))) + (when (and (eq id :required) (null static-id)) + (error (format nil + "Parameter id of class ~a is required" + (class-name (class-of comp))))))) + + +(defun make-component (name parameters content) + (let ((instance (make-instance name)) + (static-id (getf parameters :static-id))) + (unless (null static-id) + (remf parameters :id)) + (loop for (k v) on parameters by #'cddr + do (let ((keyword k)) + (when (eq keyword :static-id) + (setf keyword :id)) + (multiple-value-bind (inst-k inst-v inst-p) + (get-properties (wcomponent-parameters instance) (list keyword)) + (declare (ignore inst-v)) + (unless (null (find inst-k (wcomponent-reserved-parameters instance))) + (error (format nil "Parameter ~a is reserved" inst-k))) + (if (null inst-p) + (if (null (wcomponent-allow-informal-parametersp instance)) + (error (format nil + "Component ~a doesn't accept informal parameters" + name)) + (setf (getf (wcomponent-informal-parameters instance) keyword) v)) + (progn + (when (and (eq keyword :id) (not (null static-id))) + (setf keyword :static-id)) + (setf (getf (htcomponent-attributes instance) keyword) v)))))) + (wcomponent-check-parameters instance) + (let ((id (wcomponent-parameter-value instance :id)) + (static-id (wcomponent-parameter-value instance :static-id))) + (if (and (null static-id) id) + (setf (htcomponent-client-id instance) (generate-id id)) + (setf (htcomponent-client-id instance) static-id))) + (setf (htcomponent-body instance) content) + instance)) + +(defun build-component (component-name &rest rest) + (let ((fbody (parse-htcomponent-function (flatten rest)))) + (make-component component-name (first fbody) (second fbody)))) + + +(defmethod wcomponent-parameter-value ((c wcomponent) key) + (let ((result (getf (htcomponent-attributes c) key :undefined))) + (if (eq result :undefined) + (getf (wcomponent-parameters c) key) + result))) + +(defmacro defcomponent (name superclass-name slot-specifier &body class-option) + (let ((symbolf (intern (format nil "~a>" name)))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ,name + ,@(if (null superclass-name) + (list '(wcomponent)) + (list + (let ((result)) + (dolist (parent superclass-name) + (when (subtypep parent 'wcomponent) + (setf result t))) + (if result + superclass-name + (append '(wcomponent) superclass-name))))) + ,@(if (null class-option) + (list slot-specifier) + (push slot-specifier class-option))) + (setf (fdefinition `,',symbolf) #'(lambda(&rest rest) (build-component ',name rest)))))) + + +(defmethod htcomponent-rewind ((obj wcomponent) (pobj page)) + (let ((template (wcomponent-template obj))) + (wcomponent-before-rewind obj pobj) + (if (listp template) + (dolist (tag template) + (htcomponent-rewind tag pobj)) + (htcomponent-rewind template pobj)) + (wcomponent-after-rewind obj pobj))) + +(defmethod wcomponent-before-rewind ((obj wcomponent) (pobj page))) +(defmethod wcomponent-after-rewind ((obj wcomponent) (pobj page))) + +(defmethod htcomponent-prerender ((obj wcomponent) (pobj page)) + (wcomponent-before-prerender obj pobj) + (let ((previous-print-status (page-can-print pobj)) + (template (wcomponent-template obj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj))) + (unless (null (page-can-print pobj)) + (dolist (script (htcomponent-script-files obj)) + (pushnew script (page-script-files pobj) :test #'equal)) + (dolist (css (htcomponent-stylesheet-files obj)) + (pushnew css (page-stylesheet-files pobj) :test #'equal)) + (dolist (js (htcomponent-class-initscripts obj)) + (pushnew js (page-class-initscripts pobj) :test #'equal)) + (unless (null (htcomponent-instance-initscript obj)) + (pushnew (htcomponent-instance-initscript obj) (page-instance-initscripts pobj) :test #'equal))) + (if (listp template) + (dolist (tag template) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag pobj))) + (htcomponent-prerender template pobj)) + (when (null previous-print-status) + (setf (page-can-print pobj) nil))) + (wcomponent-after-prerender obj pobj)) + +(defmethod wcomponent-before-prerender ((obj wcomponent) (pobj page))) +(defmethod wcomponent-after-prerender ((obj wcomponent) (pobj page))) + +(defmethod htcomponent-render ((obj wcomponent) (pobj page)) + (let ((template (wcomponent-template obj)) + (previous-print-status (page-can-print pobj))) + (when (null previous-print-status) + (setf (page-can-print pobj) (htcomponent-can-print obj)) + (htcomponent-json-print-start-component obj)) + (wcomponent-before-render obj pobj) + (unless (listp template) + (setf template (list template))) + (dolist (tag template) + (if (stringp tag) + (htcomponent-render ($> tag) pobj) + (htcomponent-render tag pobj))) + (wcomponent-after-render obj pobj) + (when (null previous-print-status) + (setf (page-can-print pobj) nil) + (htcomponent-json-print-end-component obj)))) + +(defmethod wcomponent-before-render ((obj wcomponent) (pobj page))) +(defmethod wcomponent-after-render ((obj wcomponent) (pobj page))) Added: trunk/main/claw-core/tests/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/tests/packages.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,35 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: tests/packages.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-tests + (:use :cl :claw :hunchentoot) + (:export :claw-tst-start + :claw-tst-stop)) \ No newline at end of file Added: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/tests/test1.lisp Tue Jan 22 01:44:06 2008 @@ -0,0 +1,220 @@ +;;; -*- 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 *clawserver-base-path* "/claw") + +(defvar *test-lisplet*) +(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test")) + +(defvar *test-lisplet2*) +(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) + + + +(defparameter *clawserver* (make-instance 'clawserver :port 4242)) +;;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 +;;; :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" +;;; :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) + +(clawserver-register-lisplet *clawserver* *test-lisplet*) +(clawserver-register-lisplet *clawserver* *test-lisplet2*) + +(defun claw-tst-start () + (clawserver-start *clawserver*)) + +(defun claw-tst-stop () + (clawserver-stop *clawserver*)) + + +;;;--------------------template-------------------------------- + +(defcomponent site-template () ()) + +(defmethod wcomponent-parameters ((o site-template)) + (list :title :required)) + +(defmethod wcomponent-template ((o site-template)) + (html> + (head> + (title> + (wcomponent-parameter-value o ':title))) + (body> + (wcomponent-informal-parameters o) + (p> + (a> :href "/claw/test/index.html")) + (htcomponent-body o)))) + + +;;;--------------------index testing page-------------------------------- +(defclass index-page (page) ()) + +(defmethod page-content ((o index-page)) + (site-template> :title "Home test page" + (p> :id "p" + (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> (a> :href "id-tests.html" "id generation test")) + (li> (a> :href "form.html" ($> "form components test"))))))) + +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" t) + +;;;--------------------realm test page-------------------------------- +(defclass realm-page (page) ()) + +(defmethod page-content ((o realm-page)) + (let ((lisplet (page-lisplet o))) + (when (or (null *session*) (not (string= (session-realm *session*) (lisplet-realm lisplet)))) + (progn + (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (page-lisplet o)))) + (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: " (lisplet-realm (page-lisplet o))) + (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" + "\"<escaping>test\"" + (hr>) + (div> :id "foo" :class "goo" + :onclick "this.innerHTML = this.id" + "passed id: 'foo'[click me, to see generated id]") + (div> :id "foo" + :onclick "this.innerHTML = this.id" + "passed id: 'foo'[click me, to see generated id]") + (div> :static-id uid + :onclick "this.innerHTML = this.id" + "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") + (div> :static-id uid2 + :onclick "this.innerHTML = this.id" + "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-------------------------------- +(defclass form-page (page) + ((name :initarg :name + :accessor form-page-name) + (surname :initarg :surname + :accessor form-page-surname) + (gender :initarg :gender + :reader form-page-gender + :writer setf-gender) + (colors :initarg :colors + :accessor form-page-colors)) + + (:default-initargs :name "kiuma" + :surname "surnk" + :colors nil + :gender '("M"))) + +(defmethod page-content ((o form-page)) + (site-template> :title "a page title" + (cform> :id "testform" :method "post" + (table> + (tr> + (td> "Name") + (td> + (cinput> :id "name" + :type "text" + :accessor 'form-page-name))) + (tr> + (td> "Surname") + (td> + (cinput> :id "surname" + :type "text" + :accessor 'form-page-surname))) + (tr> + (td> "Gender") + (td> + (cselect> :id "gender" + :writer 'setf-gender + (loop for gender in (list "M" "F") + collect (option> :value gender + (when (string= gender (first (form-page-gender o))) + '(:selected "selected")) + (if (string= gender "M") + "Male" + "Female")))))) + (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 (member 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"))))) + (div> (format nil "Name: ~a" (form-page-name o))) + (div> (format nil "Surname: ~a" (form-page-surname o))) + (div> (format nil "Gender: ~a" (first (form-page-gender o)))))) + +(lisplet-register-page-location *test-lisplet* 'form-page "form.html") + + +