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 @@
+
+
+
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