From achiumenti at common-lisp.net Tue Jan 22 14:50:27 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 22 Jan 2008 09:50:27 -0500 (EST) Subject: [claw-cvs] r2 - trunk/doc/chapters Message-ID: <20080122145027.CF2A8620D6@common-lisp.net> Author: achiumenti Date: Tue Jan 22 09:50:27 2008 New Revision: 2 Added: trunk/doc/chapters/intro.texinfo trunk/doc/chapters/server.texinfo Log: first commit Added: trunk/doc/chapters/intro.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/intro.texinfo Tue Jan 22 09:50:27 2008 @@ -0,0 +1,36 @@ + at node Introduction + at comment node-name, next, previous, up + at chapter Introduction + + at value{claw} is a comprehensive web application for Common Lisp programming language. + + at section What is @value{claw} + + at value{claw} is a comprehensive web application framework for the Common Lisp programming language. + at value{claw} is based on components, highly reusable building blocks the make easy and fast the creation of a web application. +By using and creating new components, the developer can create robust and consistent web application with the minimal effort. + +The main aim of @value{claw} is @cite{`divide et impera'}, that means that dividing problems into small problems let programmers +work on different part of an application, creating ad hoc components for both generic and specific tasks. + + at value{claw} can easily handle all the request cycle,letting you to concentrate only in application business side problems, letting + at value{claw} automatically manage all the mechanism of the web layer, such as form submission and user interactions. + + at value{claw} comes integrated with the dojotoolkit, giving you the possibility to easily and quickly create full WEB 2.0 eye candy application, +with powerful and very user friendly UI. + + at subsection The request cycle + +When a user asks for a page the request is sent to the woserver that dispatches the request to the registered lisplets. + +Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, under a common path. + +When a matching lisplet is then found, it dispatches the request to a registered resource that can be a page or a file. + +If the request is sent for a file, this is then sent pack to the browser if found. + +If the request is sent for a page, usually mapped to a html url, the dispatcher calls the page rendering function to display the page as an html resource. + +If no resource is found a 404 message page, is sent to the user as feedback. + + at image{figure1,15cm,,,png} Added: trunk/doc/chapters/server.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/server.texinfo Tue Jan 22 09:50:27 2008 @@ -0,0 +1,442 @@ + at node Server + at comment node-name, next, previous, up + at chapter The server + + at value{claw} wraps the Hunchentoot (see: @url{http://www.weitz.de/hunchentoot/, unchentoot}), a wonderful as powerful web server written in Common Lisp, +into the @code{CLAWSERVER} class. + +As an Hunchentoot wrapper @code{CLAWSERVER} ``provides facilities like automatic session handling (with and without cookies), logging +(to Apache's log files or to a file in the file system), customizable error handling, and easy access to GET and POST parameters sent by the client.'' + + at section Understanding the clawserver + + at code{CLAWSERVER} is not only a Hunchentoot wrapper, it is also the common place where you put your web applications +built with @value{claw} into lisplet that you can see as application resource containers and request dispatchers. + + at subsection @code{CLAWSERVER} instance initialization + +When you want to instantiate a @code{CLAWSERVER} class, remember that it accepts the following initialization arguments: + at itemize @minus + at item + at emph{port} The port the server will be listening on, default is 80 + at item + at emph{sslport} The SSL port the server will be listening on, default is 443 if the server has a certificate file defined. + at item + at emph{address} A string denoting an IP address, if provided then the server only receives connections for that address. +If address is NIL, then the server will receive connections to all IP addresses on the machine (default). + at item + at emph{name} Should be a symbol which can be used to name the server. +This name can utilized when defining easy handlers. The default name is an uninterned symbol as returned by GENSYM + at item + at emph{sslname} Should be a symbol which can be used to name the server running in SSL mode when a certificate file is provided. +This name can utilized when defining easy handlers. The default name is an uninterned symbol as returned by GENSYM + at item + at emph{mod-lisp-p} If true (the default is NIL), the server will act as a back-end for mod_lisp, otherwise it will be a stand-alone web server. + at item + at emph{use-apache-log-p} If true (which is the default), log messages will be written to the Apache log file - this parameter has no effect if @emph{mod-lisp-p} is NIL. + at item + at emph{input-chunking-p} If true (which is the default), the server will accept request bodies without a Content-Length header if the client uses chunked transfer encoding. + at item + at emph{read-timeout} Is the read timeout (in seconds) for the socket stream used by the server. +The default value is @url{http://www.weitz.de/hunchentoot/#*default-read-timeout*,HUNCHENTOOT:*DEFAULT-READ-TIMEOUT*} (20 seconds) + at item + at emph{write-timeout} Is the write timeout (in seconds) for the socket stream used by the server. +The default value is @url{http://www.weitz.de/hunchentoot/#*default-write-timeout*,HUNCHENTOOT:*DEFAULT-WRITE-TIMEOUT*} (20 seconds) + at item + at emph{setuid} On Unix systems, changes the UID of the process directly after the server has been started. + at item + at emph{setgid} On Unix systems, changes the GID of the process directly after the server has been started. + at item + at emph{ssl-certificate-file} If you want your server to use SSL, you must provide the pathname designator(s) for the certificate file (must be in PEM format). + at item + at emph{ssl-privatekey-file} the pathname designator(s) for the private key file (must be in PEM format). + at item + at emph{ssl-privatekey-password} If private key file needs a password set this parameter to the required password + at end itemize + + at subsection @code{CLAWSERVER} class methods + + at sp 1 + at fnindex clawserver-port + at noindent + at code{clawserver-port obj}@* + at code{(setf clawserver-port) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The numeric value of listening port to assign + at end itemize +Returns and sets the port on which the server is listening to (default 80). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-sslport + at noindent + at code{clawserver-sslport obj}@* + at code{(setf clawserver-sslport) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The numeric value of listening port to assign for SSL connections + at end itemize +Returns and sets the port on which the server is listening to in SSL mode if a certificate file is provided (default 443). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-address + at noindent + at code{clawserver-address obj}@* + at code{(setf clawserver-address) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The string value denoting the IP address + at end itemize +Returns and sets the IP address where the server is bound to (default @code{NIL} @result{} any). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-name + at noindent + at code{clawserver-name obj}@* + at code{(setf clawserver-name) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The symbol value denoting the server name + at end itemize +Should be a symbol which can be used to name the server. +This name can utilized when defining easy handlers. The default name is an uninterned symbol as returned by GENSYM + + at sp 1 + at fnindex clawserver-sslname + at noindent + at code{clawserver-sslname obj}@* + at code{(setf clawserver-sslname) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The symbol value denoting the server name running in SSL mode + at end itemize +Should be a symbol which can be used to name the server running in SSL mode, when a certificate file is provided. +This name can utilized when defining easy handlers. The default name is an uninterned symbol as returned by GENSYM + + at sp 1 + at fnindex clawserver-mod-lisp-p + at noindent + at code{clawserver-mod-lisp-p obj}@* + at code{(setf clawserver-mod-lisp-p) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The boolean value denoting the use of mod_lisp. + at end itemize +Returns and sets the server startup modality . +If true (the default is @code{NIL}), the server will act as a back-end for mod_lisp, otherwise it will be a stand-alone web server. +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-use-apache-log-p + at noindent + at code{clawserver-use-apache-log-p obj}@* + at code{(setf clawserver-use-apache-log-p) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The boolean value denoting the use of Apache log. + at end itemize +Returns and sets where the server should log messages. This parameter has no effects if clawserver-mod-lisp-p is set to @code{NIL}. (default @code{T} if @code{mod_lisp} +is activated. +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-input-chunking-p + at noindent + at code{clawserver-input-chunking-p obj}@* + at code{(setf clawserver-input-chunking-p) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The boolean value denoting the ability to accept request bodies without a Content-Length header. + at end itemize +Returns and sets the ability to accept request bodies without a Content-Length header (default is @code{T}) +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-read-timeout + at noindent + at code{clawserver-read-timeout obj}@* + at code{(setf clawserver-read-timeout) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The integer value denoting the server read timeout. + at end itemize +Returns and sets the server read timeout in seconds (default is @code{T}) +(default to @url{http://www.weitz.de/hunchentoot/#*default-read-timeout*,HUNCHENTOOT:*DEFAULT-READ-TIMEOUT*} [20 seconds]). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-write-timeout + at noindent + at code{clawserver-write-timeout obj}@* + at code{(setf clawserver-write-timeout) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The integer value denoting the server write timeout. + at end itemize +Returns and sets the server write timeout in seconds (default is @code{T}) +(default to @url{http://www.weitz.de/hunchentoot/#*default-read-timeout*,HUNCHENTOOT:*DEFAULT-WRITE-TIMEOUT*} [20 seconds]). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-setuid + at noindent + at code{clawserver-setuid obj}@* + at code{(setf clawserver-setuid) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The string or integer value of the UID with which the server instance will run. + at end itemize +Returns and sets the server instance UID (user id). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-setgid + at noindent + at code{clawserver-setgid obj}@* + at code{(setf clawserver-setgid) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} The string or integer value of the GID with which the server instance will run. + at end itemize +Returns and sets the server instance GID (group id). +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-ssl-certificate-file + at noindent + at code{clawserver-ssl-certificate-file obj}@* + at code{(setf clawserver-ssl-certificate-file) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} Pathname designator(s) for the certificate file + at end itemize +Returns and sets the pathname designator(s) for the certificate file if the @code{CLAWSERVER} is SSL enabled +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-ssl-privatekey-file + at noindent + at code{clawserver-ssl-privatekey-file obj}@* + at code{(setf clawserver-ssl-privatekey-file) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} Pathname designator(s) for the private key file + at end itemize +Returns and sets the pathname designator(s) for the private key file if the @code{CLAWSERVER} is SSL enabled +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-ssl-privatekey-password + at noindent + at code{clawserver-ssl-privatekey-password obj}@* + at code{(setf clawserver-ssl-privatekey-password) val obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{val} Password for the private key file + at end itemize +Returns and sets the password for the private key file if the @code{CLAWSERVER} is SSL enabled +If the server is started and you try to change the listening value an error will be signaled + + at sp 1 + at fnindex clawserver-start + at noindent + at code{clawserver-start obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at end itemize +Make the @code{CLAWSERVER} begin to dispatch requests + + at sp 1 + at fnindex clawserver-stop + at noindent + at code{clawserver-stop obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at end itemize +Make the @code{CLAWSERVER} stop. + + at sp 1 + at fnindex clawserver-register-lisplet + at fnindex lisplet + at noindent + at code{clawserver-register-lisplet clawserver lisplet-obj}@* + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{lisplet-obj} A @code{LISPLET} class instance + at end itemize +Registers a @code{LISPLET}, that is an `application container` for request dispatching. + + at sp 1 + at fnindex clawserver-unregister-lisplet + at noindent + at code{clawserver-unregister-lisplet clawserver lisplet-obj} + at indent + + at itemize + at item + at emph{obj} The @code{CLAWSERVER} instance + at item + at emph{lisplet-obj} A @code{LISPLET} class instance + at end itemize +Unregisters a @code{LISPLET}, that is an `application container`, an so all it's resources, from the @code{CLAWSERVER} instance. + + at section Starting the server + +Starting @value{claw} is very easy and requires a minimal effort. + at value{claw} supports both http and https protocols, thought enabling SSL connection for @value{claw} requires +a little more work then having it responding only to http calls. + + at subsection Making @value{claw} work on http protocol + +To simply start @value{claw} server, without enabling SSL requests handling, you just need few steps: + + at cartouche + at lisp +(defparameter *clawserver* (make-instance 'clawserver)) +(clawserver-start *clawserver*) + at end lisp + at end cartouche + +This will start the web server on port 80 that is the default. + + +Of course you can create a parametrized version of @code{CLAWSERVER} instance for example specifying the listening port as the following: + + at cartouche + at lisp +(defparameter *clawserver* (make-instance 'clawserver :port 4242)) +(clawserver-start *clawserver*) + at end lisp + at end cartouche + + at subsection Making @value{claw} work on both http and https protocols + +To enable @value{claw} to https firt you need a certificate file. +A quick way to get one on a Linux system is to use openssl to generate the a certificate PEM file, the following example explains how to do. + +Firstly you'll generate the private key file: + + at cartouche + at example +#> openssl genrsa -out privkey.pem 2048 + at sp 1 +Generating RSA private key, 2048 bit long modulus +............................+++ +..................................................+++ +e is 65537 (0x10001) + at sp 1 +#> + at end example + at end cartouche + +Then the certificate file: + + at cartouche + at example +#> openssl req -new -x509 -key privkey.pem -out cacert.pem -days 1095 + at sp 1 +You are about to be asked to enter information that will be incorporated +into your certificate request. +What you are about to enter is what is called a Distinguished Name or a DN. +There are quite a few fields but you can leave some blank +For some fields there will be a default value, +If you enter '.', the field will be left blank. +----- +Country Name (2 letter code) [AU]:IT +State or Province Name (full name) [Some-State]: bla-bla +Locality Name (eg, city) []: bla-bla +Organization Name (eg, company) [Internet Widgits Pty Ltd]: mycompany +Organizational Unit Name (eg, section) []: +Common Name (eg, YOUR name) []:www.mycompany.com +Email Address []:admin@@mycompany.com + at sp 1 +#> + at end example + at end cartouche + +Now you can start @code{CLAWSERVER} in both http and https mode: + + at cartouche + at lisp +(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4443 + :ssl-certificate-file #P"/path/to/certificate/cacert.pem" + :ssl-privatekey-file #P"/path/to/certificate/privkey.pem"))) +(clawserver-start *clawserver*) + at end lisp + at end cartouche + + at value{claw} is now up and you can browse it with your browser using address http://www.yourcompany.com:4242 and http://www.yourcompany.com:4443. +Of course you will have only a 404 response page! From achiumenti at common-lisp.net Tue Jan 22 14:50:48 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 22 Jan 2008 09:50:48 -0500 (EST) Subject: [claw-cvs] r3 - trunk/doc/blender Message-ID: <20080122145048.CFC33620D6@common-lisp.net> Author: achiumenti Date: Tue Jan 22 09:50:47 2008 New Revision: 3 Added: trunk/doc/blender/figure1.blend (contents, props changed) Log: first commit Added: trunk/doc/blender/figure1.blend ============================================================================== Binary file. No diff available. From achiumenti at common-lisp.net Tue Jan 22 06:44:14 2008 From: achiumenti at common-lisp.net (achiumenti at common-lisp.net) Date: Tue, 22 Jan 2008 01:44:14 -0500 (EST) Subject: [claw-cvs] r1 - in trunk: . doc doc/blender doc/chapters logo main main/claw-core main/claw-core/src main/claw-core/tests Message-ID: <20080122064414.3E9A225134@common-lisp.net> 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-*- + + at c %**start of header + at setfilename claw.info + at settitle CLAW User Manual + at c %**end of header + + at set claw CLAW + at set VERSION 0.1 + at set UPDATE-MONTH genuary 2008 + at settitle @value{claw} @value{VERSION} User Manual + + at copying + at quotation +This manual is part of the @value{claw} software system. See the + at 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 + at file{CREDITS} files for more information. + at end quotation + at end copying + + at titlepage + at title @value{claw} User Manual + at subtitle @value{claw} version @value{VERSION} + at subtitle @value{UPDATE-MONTH} + + at c The following two commands start the copyright page. + at page + at vskip 0pt plus 1filll + at insertcopying + + at end titlepage + + at contents + + at ifnottex + + at node Top + at comment node-name, next, previous, up + at top About this manual + + at insertcopying + + at menu +* Introduction:: +* Server:: +* Function index:: + at c * Starting and Stopping:: + at c * Compiler:: + at c * Debugger:: + at c * Efficiency:: + at c * Beyond the ANSI Standard:: + at c * Type Index:: + at end menu + + at end ifnottex + + at include chapters/intro.texinfo + at include chapters/server.texinfo + + at node Function index + at unnumbered Function index + at printindex fn + + at 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 @@ + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + 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