[claw-cvs] r134 - in trunk/main/claw-as: . src
Andrea Chiumenti
achiumenti at common-lisp.net
Wed Nov 12 07:05:09 UTC 2008
Author: achiumenti
Date: Wed Nov 12 07:05:09 2008
New Revision: 134
Log:
claw application server package/system renaming
Added:
trunk/main/claw-as/claw-as.asd
trunk/main/claw-as/src/
trunk/main/claw-as/src/auth.lisp
trunk/main/claw-as/src/connector.lisp
trunk/main/claw-as/src/lisplet.lisp
trunk/main/claw-as/src/local-time.lisp
trunk/main/claw-as/src/logger.lisp
trunk/main/claw-as/src/mime-type.lisp
trunk/main/claw-as/src/misc.lisp
trunk/main/claw-as/src/packages.lisp
trunk/main/claw-as/src/server.lisp
trunk/main/claw-as/src/service.lisp
trunk/main/claw-as/src/session-manager.lisp
Added: trunk/main/claw-as/claw-as.asd
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/claw-as.asd Wed Nov 12 07:05:09 2008
@@ -0,0 +1,46 @@
+;;; -*- 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-as
+ :name "claw-as"
+ :author "Andrea Chiumenti"
+ :description "claw-as is a Common Lisp Application Server"
+ :depends-on (:closer-mop :cl-ppcre :cl-fad :alexandria :local-time :split-sequence :bordeaux-threads :md5)
+ :components ((:module src
+ :components ((:file "packages")
+ (:file "mime-type" :depends-on ("packages"))
+ (:file "misc" :depends-on ("mime-type"))
+ (:file "local-time" :depends-on ("packages"))
+ (:file "service" :depends-on ("packages"))
+ (:file "connector" :depends-on ("misc" "service"))
+ (:file "logger" :depends-on ("misc" "service"))
+ (:file "auth" :depends-on ("packages"))
+ (:file "session-manager" :depends-on ("misc" "service" "auth"))
+ (:file "server" :depends-on ("misc" "service" "logger" "connector" "session-manager"))
+ (:file "lisplet" :depends-on ("server"))))))
Added: trunk/main/claw-as/src/auth.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/auth.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,61 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/auth.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :claw-as)
+
+;;------------------------------------------------------------------------------------------
+
+(defgeneric configuration-login (configuration)
+ (:documentation "Authenticate a user creating a principal object that will be stored into the http session.
+If no session is present one will be created, if the authentication succeds the principal instance is returned"))
+
+
+(defclass configuration ()
+ ()
+ (:documentation "A configuration class for CLAW server realm login configurations"))
+
+(defmethod configuration-login ((configuration configuration))
+ nil)
+
+(defclass principal ()
+ ((name :initarg :name
+ :reader principal-name
+ :documentation "The principal username who is logged into the application")
+ (roles :initarg :roles
+ :accessor principal-roles
+ :documentation "The roles where that owns the user logged into the application"))
+ (:default-initargs :roles nil)
+ (:documentation "An instance of PRINCIPAL is stored into session after a user successfully login into the application."))
+
+
+(defun login ()
+ "Performs user authentication for the reaml where the request has been created"
+ (let* ((login-config (gethash *claw-current-realm* (clawserver-login-config *clawserver*))))
+ (when (and login-config (null (current-principal)))
+ (setf (current-principal) (configuration-login login-config)))))
\ No newline at end of file
Added: trunk/main/claw-as/src/connector.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/connector.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,258 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/connector.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-as)
+
+(defgeneric connector-host (connector)
+ (:documentation "
+Returns the value of the incoming Host http header. \(This corresponds to the environment variable HTTP_HOST in CGI scripts.)"))
+
+(defgeneric connector-request-method (connector)
+ (:documentation "Returns the request method as a keyword, i.e. something like :POST. \(This corresponds to the environment variable REQUEST_METHOD in CGI scripts.)"))
+
+(defgeneric connector-script-name (connector)
+ (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any).
+\(This corresponds to the environment variable SCRIPT_NAME in CGI scripts.)"))
+
+(defgeneric connector-request-uri (connector)
+ (:documentation "Returns the URI for request.
+Note that this not the full URI but only the part behind the scheme and authority components, so that if the user has typed http://user:password@www.domain.com/xxx/frob.html?foo=bar into his browser, this function will return \"/xxx/frob.html?foo=bar\". \(This corresponds to the environment variable REQUEST_URI in CGI scripts."))
+
+(defgeneric connector-query-string (connector)
+ (:documentation "Returns the query component of the URI for request, i.e. the part of the string returned by REQUEST-URI behind the first question mark \(if any).
+\(This corresponds to the environment variable QUERY_STRING in CGI scripts.) See also CONNECTOR-GET-PARAMETER and CONNECTOR-GET-PARAMETERS."))
+
+(defgeneric connector-get-parameter (connector name)
+ (:documentation "Returns the value of the GET parameter \(as provided via the request URI) named by the string name as a string \(or NIL if there ain't no GET parameter with this name).
+Note that only the first value will be returned if the client provided more than one GET parameter with the name name. See also CONNECTOR-GET-PARAMETERS"))
+
+(defgeneric connector-get-parameters (connector)
+ (:documentation "Returns an alist of all GET parameters \(as provided via the request URI). The car of each element of this list is the parameter's name while the cdr is its value \(as a string).
+The elements of this list are in the same order as they were within the request URI. See also CONNECTOR-GET-PARAMETER."))
+
+(defgeneric connector-post-parameter (connector name)
+ (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name.
+Note that only the first value will be returned if the client provided more than one POST parameter with the name name.
+This value will usually be a string \(or NIL if there ain't no POST parameter with this name).
+If, however, the browser sent a file through a multipart/form-data form, the value of this function is a three-element list
+
+\(path file-name content-type)
+
+where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser.
+The file denoted by path will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it."))
+
+(defgeneric connector-post-parameters (connector)
+ (:documentation "Returns an alist of all POST parameters (as provided via the request's body). The car of each element of this list is the parameter's name while the cdr is its value. The elements of this list are in the same order as they were within the request's body.
+See also CONNECTOR-POST-PARAMETER."))
+
+(defgeneric connector-parameter (connector name)
+ (:documentation "Returns the value of the GET or POST parameter named by the string name as a string \(or NIL if there ain't no parameter with this name).
+If both a GET and a POST parameter with the name name exist, the GET parameter will be returned. See also CONNECTOR-GET-PARAMETER and CONNECTOR-POST-PARAMETER."))
+
+(defgeneric connector-header-in (connector name)
+ (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name).
+Note that this queries the headers sent to Hunchentoot by the client or by mod_lisp.
+In the latter case this may not only include the incoming http headers but also some headers sent by mod_lisp.
+For backwards compatibility, name can also be a string which is matched case-insensitively. See also CONNECTOR-HEADERS-IN."))
+
+(defgeneric connector-headers-in (connector)
+ (:documentation "Returns an alist of all incoming headers.
+The car of each element of this list is the headers's name \(a Lisp keyword) while the cdr is its value (as a string).
+There's no guarantee about the order of this list. See also CONECTOR-HEADER-IN and the remark about incoming headers there."))
+
+(defgeneric connector-authorization (connector)
+ (:documentation "Returns as two values the user and password \(if any) from the incoming Authorization http header.
+Returns NIL if there is no such header."))
+
+(defgeneric connector-remote-addr (connector)
+ (:documentation "Returns the IP address \(as a string) of the client which sent the request. \(This corresponds to the environment variable REMOTE_ADDR in CGI scripts.) See also CONNECTOR-REAL-REMOTE-ADDR."))
+
+(defgeneric connector-remote-port (connector)
+ (:documentation "Returns the IP port (as a number) of the client which sent the request."))
+
+(defgeneric connector-real-remote-addr (connector)
+ (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists.
+Otherwise returns the value of CONNECTOR-REMOTE-ADDR as the only value."))
+
+(defgeneric connector-server-addr (connector)
+ (:documentation "Returns the IP address \(as a string) where the request came in.
+\(This corresponds to the environment variable SERVER_ADDR in CGI scripts.)"))
+
+(defgeneric connector-server-port (connector)
+ (:documentation "Returns the IP port \(as a number) where the request came in."))
+
+(defgeneric connector-server-protocol (connector)
+ (:documentation "Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either :HTTP/1.0 or :HTTP/1.1.
+\(This corresponds to the environment variable SERVER_PROTOCOL in CGI scripts."))
+
+(defgeneric connector-user-agent (connector)
+ (:documentation "Returns the value of the incoming User-Agent http header.
+\(This corresponds to the environment variable HTTP_USER_AGENT in CGI scripts.)"))
+
+
+(defgeneric connector-referer (connector)
+ (:documentation "Returns the value of the incoming Referer \(sic!) http header. \(This corresponds to the environment variable HTTP_REFERER in CGI scripts.)"))
+
+(defgeneric connector-cookie-in (connector name)
+ (:documentation "Returns the value of the incoming cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CONNECTOR-COOKIES-IN"))
+
+(defgeneric connector-cookies-in (connector)
+ (:documentation "Returns an alist of all incoming cookies.
+The car of each element of this list is the cookie's name while the cdr is the cookie's value. See also CONNECTOR-COOKIE-IN"))
+
+(defgeneric connector-aux-request-value (connector symbol)
+ (:documentation "Returns values VALUE, PRESENTP.
+This accessor associates arbitrary data with the the symbol symbol in the REQUEST object request.
+PRESENTP is true if such data was found, otherwise NIL"))
+
+(defgeneric (setf connector-aux-request-value) (value connector symbol)
+ (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request."))
+
+(defgeneric connector-delete-aux-request-value (connector symbol)
+ (:documentation "Completely removes any data associated with the symbol symbol from the REQUEST object request. Note that this is different from using AUX-REQUEST-VALUE to set the data to NIL"))
+
+;;---------------------------
+
+(defgeneric connector-header-out (connector name)
+ (:documentation "Returns the outgoing http header named by the keyword name if there is one, otherwise NIL \(name parameter must be a symbol).
+Note that the headers Set-Cookie, Content-Length, and Content-Type cannot be queried by HEADER-OUT.
+See also CONNECTOR-HEADERS-OUT, CONNECTOR-CONTENT-TYPE, CONNECTOR-CONTENT-LENGTH, CONNECTOR-COOKIES-OUT, and CONNECTOR-COOKIE-OUT"))
+
+(defgeneric (setf connector-header-out) (value connector name)
+ (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol).
+If no header named name exists it is created.
+Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT.
+Also, there are a couple of \"technical\" headers like Connection or Transfer-Encoding that you're not supposed to set yourself.
+See also CONNECTOR-HEADERS-OUT, CONNECTOR-CONTENT-TYPE, CONNECTOR-CONTENT-LENGTH, CONNECTOR-COOKIES-OUT, and CONNECTOR-COOKIE-OUT"))
+
+(defgeneric connector-headers-out (connector)
+ (:documentation "Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type).
+The car of each element of this list is the headers's name while the cdr is its value.
+This alist should not be manipulated directly, use SETF of CONNECTOR-HEADER-OUT instead"))
+
+(defgeneric connector-cookie-out (connector name)
+ (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CONNECTOR-COOKIES-OUT and the CLAW-COOKIE class definition."))
+
+(defgeneric (setf connector-cookie-out) (cookie-instance connector name)
+ (:documentation "Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply.
+If a cookie with the same name \(case-sensitive) already exists, it is replaced.
+ The default for value is the empty string."))
+
+(defgeneric connector-cookies-out (connector)
+ (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CONNECTOR-COOKIES-OUT and the CLAW-COOKIE class definition."))
+
+(defgeneric connector-return-code (connector)
+ (:documentation "CONNECTOR-RETURN-CODE returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)"))
+
+(defgeneric (setf connector-return-code) (value connector)
+ (:documentation "Setf CONNECTOR-RETURN-CODE sets the http return code of the reply."))
+
+(defgeneric connector-content-type (connector)
+ (:documentation "CONNECTOR-CONTENT-TYPE returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."))
+
+(defgeneric (setf connector-content-type) (value connector)
+ (:documentation "SETF CONNECTOR-CONTENT-TYPE sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."))
+
+(defgeneric connector-reply-external-format-encoding (connector)
+ (:documentation "CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING returns the symbol of the reply charset encoding \(Such as UTF-8)."))
+
+(defgeneric (setf connector-reply-external-format-encoding) (value connector)
+ (:documentation "SETF CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING sets the symbol of the reply charset encoding \(Such as UTF-8)."))
+
+(defgeneric connector-writer (connector)
+ (:documentation "Returns the output stream writer to generate replies. It's default to *standard-output*"))
+
+(defgeneric connector-redirect (connector target &key host port protocol add-session-id code)
+ (:documentation "Sends back appropriate headers to redirect the client to target \(a string).
+If target is a full URL starting with a scheme, host, port, and protocol are ignored.
+Otherwise, target should denote the path part of a URL, protocol must be one of the keywords :HTTP or :HTTPS, and the URL to redirect to will be constructed from host, port, protocol, and target.
+If code is a 3xx redirection code, it will be sent as status code.
+In case of NIL, a 302 status code will be sent to the client. If host is not provided, the current host \(see CONNECTOR-HOST) will be used.
+If protocol is the keyword :HTTPS, the client will be redirected to a https URL, if it's :HTTP it'll be sent to a http URL.
+If both host and protocol aren't provided, then the value of protocol will match the current request."))
+
+(defgeneric connector-content-length (connector)
+ (:documentation "Returns the outgoing Content-Length http header"))
+
+(defgeneric (setf connector-content-length) (value connector)
+ (:documentation "Sets the outgoing Content-Length http header"))
+
+(defclass connector (claw-service)
+ ((port :initarg :port
+ :accessor connector-port
+ :documentation "The port under which normal http requests are handled")
+ (sslport :initarg :sslport
+ :accessor connector-sslport
+ :documentation "The port under which https requests are handled")
+ (address :initarg :address
+ :accessor connector-address
+ :documentation "The address whe the connector is bound to"))
+ (:default-initargs :port 80 :sslport 443
+ :address *claw-default-server-address*
+ :name 'connector)
+ (:documentation "CONNECTOR is an interface, so you cannot directly use it.
+A Connector subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides.
+To properly work a CLAWSERVER instance must be provided with a CONNECTOR implementation.
+A CONNECTOR implementation to properly work, must implement all the CONNECTOR- methods."))
+
+(defmethod connector-writer ((connector connector)))
+
+(defclass claw-cookie ()
+ ((name :initarg :name
+ :reader claw-cookie-name
+ :type string
+ :documentation "The name of the claw-cookie - a string.")
+ (value :initarg :value
+ :accessor claw-cookie-value
+ :initform ""
+ :documentation "The value of the claw-cookie. Will be URL-encoded when sent to the browser.")
+ (expires :initarg :expires
+ :initform nil
+ :accessor claw-cookie-expires
+ :documentation "The time \(a universal time) when the claw-cookie expires \(or NIL).")
+ (path :initarg :path
+ :initform nil
+ :accessor claw-cookie-path
+ :documentation "The path this claw-cookie is valid for \(or NIL).")
+ (domain :initarg :domain
+ :initform nil
+ :accessor claw-cookie-domain
+ :documentation "The domain this claw-cookie is valid for \(or NIL).")
+ (secure :initarg :secure
+ :initform nil
+ :accessor claw-cookie-secure
+ :documentation "A generalized boolean denoting whether this is a secure claw-cookie.")
+ (http-only :initarg :http-only
+ :initform nil
+ :accessor claw-cookie-http-only
+ :documentation "A generalized boolean denoting whether this is a HttpOnly claw-cookie.")))
+
Added: trunk/main/claw-as/src/lisplet.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/lisplet.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,262 @@
+;;; -*- 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-as)
+
+(defgeneric clawserver-register-lisplet (clawserver lisplet)
+ (:documentation "This method registers a lisplet for request dispatching
+- CLAWSERVER the CLAWSERVER instance
+- LISPLET the LISPLET instance"))
+
+(defgeneric clawserver-unregister-lisplet (clawserver lisplet)
+ (:documentation "This method unregisters a lisplet from request dispatching
+- CLAWSERVER the CLAWSERVER instance
+- LISPLET the LISPLET instance"))
+
+(defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p)
+ (:documentation "Registers a function into a lisplet for dispatching.
+parameters:
+- LISPLET the lisplet that will dispatch the function
+- FUNCTION the function to register for dispatching
+- LOCATION The url location where the function will be registered (relative to the lisplet base path)
+keys:
+- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
+- :LOGIN-PAGE-P Marks the function as a login page"))
+
+(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type)
+ (:documentation "Registers a resource (file or directory) into a lisplet for dispatching.
+parameters:
+- LISPLET the lisplet that will dispatch the page
+- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching
+- LOCATION The url location where the resource will be registered (relative to the lisplet base path)
+- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type"))
+
+(defgeneric lisplet-dispatch-method (lisplet)
+ (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST
+- LISPLET the lisplet object"))
+
+(defgeneric lisplet-dispatch-request (lisplet uri)
+ (:documentation "Dispatches the http request.
+- LISPLET the lisplet object"))
+
+(defgeneric lisplet-protect (lisplet location roles)
+ (:documentation "protects all the resources that start with the given LOCATION, making them available only if the
+user is logged and belongs at least to one of the given roles.
+parameters:
+- LISPLET the lisplet object.
+- LOCATION the location that must be protected.
+- ROLES a string list containing all the roles allowed to acces the given location."))
+
+(defgeneric lisplet-check-authorization (lisplet)
+ (:documentation "Performs authentication and authorization checking.
+Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the
+lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login."))
+
+(defgeneric lisplet-authentication-type (lisplet)
+ (:documentation "When there is no page or function registered into the lisplet as login page returns :BASIC, otherwise returns :FORM.
+parameters:
+- LISPLET the lisplet object."))
+
+(defgeneric build-lisplet-location (lisplet)
+ (:documentation "Constructs a full path prepending the lisplet base path to the given location"))
+
+(defclass lisplet (claw-service)
+ ((base-path :initarg :base-path
+ :reader lisplet-base-path
+ :documentation "common base path all resources registered into this lisplet")
+ (server-address :initarg :server-address
+ :accessor lisplet-server-address
+ :documentation "Server address used on redirections")
+ (welcome-page :initarg :welcome-page
+ :accessor lisplet-welcome-page
+ :documentation "url location for the welcome page")
+ (login-page :initarg :login-page
+ :accessor lisplet-login-page
+ :documentation "url location for the welcome page")
+ (realm :initarg :realm
+ :reader lisplet-realm
+ :documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
+ (pages :initform nil
+ :accessor lisplet-pages
+ :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
+ (error-handlers :initform (make-hash-table)
+ :accessor lisplet-error-handlers
+ :documentation "An hash table where keys are http error codes and values are functions with no parameters")
+ (protected-resources :initform nil
+ :accessor lisplet-protected-resources
+ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
+ (redirect-protected-resources-p :initarg :redirect-protected-resources-p
+ :accessor lisplet-redirect-protected-resources-p
+ :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
+ (:default-initargs :server-address *claw-default-server-address*
+ :welcome-page nil
+ :login-page nil
+ :realm "claw"
+ :redirect-protected-resources-p nil)
+ (:documentation "A lisplet is a container for resources provided trhough the clawserver.
+It is similar, for purposes, to a JAVA servlet"))
+
+(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet))
+ (let ((lisplets (clawserver-lisplets clawserver))
+ (location (lisplet-base-path lisplet)))
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
+ (setf (lisplet-server-address lisplet) (clawserver-address clawserver)
+ (clawserver-lisplets clawserver) (sort-by-location (pushnew-location
+ (cons location
+ lisplet)
+ lisplets)))))
+
+(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
+ (let ((lisplets (clawserver-lisplets clawserver))
+ (location (lisplet-base-path lisplet)))
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
+ (remove-by-location location lisplets)))
+
+
+(defmethod build-lisplet-location ((lisplet lisplet))
+ "Constructs a full path prepending the lisplet base path to the given location"
+ (format nil "~a~a" (clawserver-base-path *clawserver*) (lisplet-base-path lisplet)))
+
+(defmethod lisplet-authentication-type ((lisplet lisplet))
+ (if (lisplet-login-page lisplet)
+ :form
+ :basic))
+
+(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
+ (let ((pages (lisplet-pages lisplet)))
+ (setf (lisplet-pages lisplet)
+ (sort-by-location (pushnew-location (cons location function) pages)))
+ (when welcome-page-p
+ (setf (lisplet-welcome-page lisplet) location))
+ (when login-page-p
+ (setf (lisplet-login-page lisplet) location))))
+
+(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
+ (let ((pages (lisplet-pages lisplet)))
+ (setf (lisplet-pages lisplet)
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (claw-script-name)
+ (+ (length (clawserver-base-path *clawserver*))
+ (length (lisplet-base-path lisplet))
+ (length location) )))
+ resource-path)))
+ (claw-handle-static-file resource-full-path content-type)))
+ #'(lambda () (claw-handle-static-file resource-path content-type))))
+ pages)))))
+
+
+(defmethod lisplet-dispatch-request ((lisplet lisplet) uri)
+ (let ((dispatchers (lisplet-pages lisplet))
+ (rel-script-name (subseq uri (length (build-lisplet-location lisplet)))))
+ (setf (claw-return-code) +http-not-found+)
+ (loop for dispatcher in dispatchers
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (when (starts-with-subseq url rel-script-name)
+ (setf (claw-return-code) +http-ok+)
+ (return (funcall action))))))
+
+(defmethod lisplet-dispatch-method ((lisplet lisplet))
+ (let* ((*claw-current-realm* (lisplet-realm lisplet))
+ (*claw-current-lisplet* lisplet)
+ (*claw-session* (default-session-manager-session-verify *session-manager*))
+ (*root-path* (format nil "~a~a" *server-path* (lisplet-base-path lisplet)))
+ (base-path (build-lisplet-location lisplet))
+ (uri (claw-script-name))
+ (welcome-page (lisplet-welcome-page lisplet)))
+ (lisplet-check-authorization lisplet)
+ (when (= (claw-return-code) +http-ok+)
+ (if (and welcome-page (or (string= uri base-path) (string= uri (concatenate 'string base-path "/"))))
+ (funcall (cdr (assoc welcome-page (lisplet-pages lisplet))))
+ (lisplet-dispatch-request lisplet uri)))))
+
+(defmethod lisplet-protect ((lisplet lisplet) location roles)
+ (let ((protected-resources (lisplet-protected-resources lisplet)))
+ (setf (lisplet-protected-resources lisplet)
+ (sort-protected-resources (pushnew-location
+ (cons location roles)
+ protected-resources)))))
+
+(defun redirect-to-https (&optional uri)
+ "Redirects a request sent through http using https"
+ (let* ((connector (clawserver-connector *clawserver*))
+ (path (or uri (claw-request-uri)))
+ (sslport (if (claw-proxified-p)
+ (clawserver-proxy-https-port *clawserver*)
+ (connector-sslport connector))))
+ (claw-redirect path :host (claw-host-name) :port sslport
+ :protocol :https)))
+
+(defmethod lisplet-check-authorization ((lisplet lisplet))
+ (let* ((connector (clawserver-connector *clawserver*))
+ (uri (claw-script-name))
+ (base-path (build-lisplet-location lisplet))
+ (protected-resources (lisplet-protected-resources lisplet))
+ (princp (current-principal))
+ (login-config (current-config))
+ (login-page-url (format nil "~a~a" base-path (lisplet-login-page lisplet)))
+ (sslport (connector-sslport connector))
+ (auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
+ (when (or (string= uri base-path) (string= uri (concatenate 'string base-path "/")))
+ (setf uri (format nil "~a/~a" base-path uri)))
+ (setf (claw-return-code) +http-ok+)
+ (when login-config
+ (when (and auth-basicp (null princp))
+ (configuration-login login-config))
+ (setf princp (current-principal))
+ (loop for protected-resource in (append (list (cons (lisplet-login-page lisplet) nil)) protected-resources)
+ for match = (format nil "~a/~a" base-path (car protected-resource))
+ for allowed-roles = (cdr protected-resource)
+ do
+ (progn
+ (when (or (starts-with-subseq match uri) (string= login-page-url uri))
+ (cond
+ ((and princp allowed-roles (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+ (setf (claw-return-code) +http-forbidden+)
+ (throw 'handler-done nil))
+ ((and (null princp) auth-basicp)
+ (setf (claw-return-code) +http-authorization-required+
+ (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*))
+ (throw 'handler-done nil))
+ ((and (null princp)
+ (string-not-equal (claw-script-name) login-page-url))
+ (redirect-to-https (format nil "~a~a" *root-path* (lisplet-login-page lisplet))))
+ ((and sslport (not (= (claw-server-port) sslport)))
+ (redirect-to-https (format nil "~a/~a" *root-path* (car protected-resource)))
+ (throw 'handler-done nil)))))))))
Added: trunk/main/claw-as/src/local-time.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/local-time.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,146 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/local-time.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-as)
+
+(defun local-time-add-year (local-time value)
+ "Adds or removes years, expressed by the value parameter, to a local-time instance"
+ (multiple-value-bind (ns ss mm hh day month year)
+ (decode-local-time local-time)
+ (encode-local-time ns ss mm hh day month (+ year value))))
+
+(defun local-time-add-month (local-time value)
+ "Adds or removes monthes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (multiple-value-bind (d-month d-year)
+ (floor (abs value) 12)
+ (when (< value 0)
+ (setf d-month (- d-month)
+ d-year (- d-year))
+ (multiple-value-bind (ns ss mm hh day month year)
+ (decode-local-time local-time)
+ (multiple-value-bind (ns ss mm hh day month-ignore year)
+ (decode-local-time (encode-local-time ns ss mm hh day 1 (+ year d-year)))
+ (declare (ignore month-ignore))
+ (encode-local-time ns ss mm hh day month year))))))
+
+(defun local-time-add-day (local-time value)
+ "Adds or removes days, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (let* ((curr-day (day-of local-time))
+ (local-time-result (make-instance 'local-time
+ :day curr-day
+ :sec (sec-of local-time)
+ :nsec (nsec-of local-time)
+ :time-zone (timezone-of local-time))))
+ (setf (day-of local-time-result) (+ curr-day value))
+ local-time-result))
+
+(defun local-time-add-hour (local-time value)
+ "Adds or removes hours, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (multiple-value-bind (ns-ignore ss-ignore mm-ignore hh day-ignore month-ignore year-ignore)
+ (decode-local-time local-time)
+ (declare (ignore ns-ignore ss-ignore mm-ignore day-ignore month-ignore year-ignore))
+ (multiple-value-bind (d-hour d-day)
+ (floor (abs value) 24)
+ (when (< value 0)
+ (setf d-hour (- d-hour)
+ d-day (- d-day)))
+ (let ((local-time-result (local-time-add-day local-time d-day)))
+ (multiple-value-bind (ns2 ss2 mm2 hh-ignore day2 month2 year2)
+ (decode-local-time local-time-result)
+ (declare (ignore hh-ignore))
+ (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2))))))
+
+(defun local-time-add-min (local-time value)
+ "Adds or removes minutes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (multiple-value-bind (ns-ignore ss-ignore mm hh-ignore day-ignore month-ignore year-ignore)
+ (decode-local-time local-time)
+ (declare (ignore ns-ignore ss-ignore hh-ignore day-ignore month-ignore year-ignore))
+ (multiple-value-bind (d-min d-hour)
+ (floor (abs value) 60)
+ (when (< value 0)
+ (setf d-min (- d-min)
+ d-hour (- d-hour)))
+ (let ((local-time-result (local-time-add-hour local-time d-hour)))
+ (multiple-value-bind (ns2 ss2 mm-ignore hh2 day2 month2 year2)
+ (decode-local-time local-time-result)
+ (declare (ignore mm-ignore))
+ (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2))))))
+
+(defun local-time-add-sec (local-time value)
+ "Adds or removes seconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (multiple-value-bind (ns-ignore ss mm-ignore hh-ignore day-ignore month-ignore year-ignore)
+ (decode-local-time local-time)
+ (declare (ignore ns-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore))
+ (multiple-value-bind (d-sec d-min)
+ (floor (abs value) 60)
+ (when (< value 0)
+ (setf d-sec (- d-sec)
+ d-min (- d-min)))
+ (let ((local-time-result (local-time-add-min local-time d-min)))
+ (multiple-value-bind (ns2 ss-ignore mm2 hh2 day2 month2 year2)
+ (decode-local-time local-time-result)
+ (declare (ignore ss-ignore))
+ (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2))))))
+
+(defun local-time-add-nsec (local-time value)
+ "Adds or removes nanoseconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
+ (multiple-value-bind (ns ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore)
+ (decode-local-time local-time)
+ (declare (ignore ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore))
+ (multiple-value-bind (d-nsec d-sec)
+ (floor (abs value) 10000000)
+ (when (< value 0)
+ (setf d-nsec (- d-nsec)
+ d-sec (- d-sec)))
+ (let ((local-time-result (local-time-add-sec local-time d-sec)))
+ (multiple-value-bind (ns-ignore ss2 mm2 hh2 day2 month2 year2)
+ (decode-local-time local-time-result)
+ (declare (ignore ns-ignore))
+ (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2))))))
+
+(defun local-time-add (local-time field value)
+ "Adds the specified amount of VALUE to the LOCAL_TIME.
+FIELD may be any of:
+* 'NSEC nano-seconds
+* 'MSEC milli-seconds
+* 'SEC seconds
+* 'MIN minutes
+* 'HR hours
+* 'DAY days
+* 'MONTH monthes
+* 'YEARS years.
+And other FIELD value will produce an error condition."
+ (ccase field
+ (NSEC (local-time-add-nsec local-time value))
+ (SEC (local-time-add-sec local-time value))
+ (MIN (local-time-add-min local-time value))
+ (HR (local-time-add-hour local-time value))
+ (DAY (local-time-add-day local-time value))
+ (MONTH (local-time-add-month local-time value))
+ (YEAR (local-time-add-year local-time value))))
Added: trunk/main/claw-as/src/logger.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/logger.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,52 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/logger.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-as)
+
+(defgeneric logger-log (logger level control-string &rest args)
+ (:documentation "Logs a message.
+log-level should be one of the keywords :EMERG, :ALERT, :CRIT, :ERROR, :WARNING, :NOTICE, :INFO, or :DEBUG which correspond to the various Apache log levels.
+Form the rest this method behaves like the FORMAT function."))
+
+(defclass logger (claw-service)
+ ()
+ (:documentation "The logger is a class that logs messages sent via LOGGER-LOG method.
+LOGGER is an interface, so you cannot directly use it.
+A LOGGER subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides.
+To properly work a CLAWSERVER instance must be provided with a LOGGER implementation.
+A LOG implementation to properly work, must implement all the LOGGER-LOG method."))
+
+(defun log-message (level control-string &rest args)
+ "Logs a message.
+log-level should be one of the keywords :EMERG, :ALERT, :CRIT, :ERROR, :WARNING, :NOTICE, :INFO, or :DEBUG which correspond to the various Apache log levels.
+Form the rest this method behaves like the FORMAT function."
+ (apply #'logger-log (clawserver-log-manager *clawserver*)
+ level
+ control-string
+ args))
\ No newline at end of file
Added: trunk/main/claw-as/src/mime-type.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/mime-type.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,362 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/mime-type.lisp $
+
+;;; Copyright (c) 2004-2008, 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 :claw-as)
+
+(defparameter *mime-type-list* '(("application/andrew-inset" "ez")
+ ("application/cu-seeme" "cu")
+ ("application/dsptype" "tsp")
+ ("application/futuresplash" "spl")
+ ("application/hta" "hta")
+ ("application/java-archive" "jar")
+ ("application/java-serialized-object" "ser")
+ ("application/java-vm" "class")
+ ("application/mac-binhex40" "hqx")
+ ("application/mac-compactpro" "cpt")
+ ("application/mathematica" "nb")
+ ("application/msaccess" "mdb")
+ ("application/msword" "doc" "dot")
+ ("application/octet-stream" "bin")
+ ("application/oda" "oda")
+ ("application/ogg" "ogg")
+ ("application/pdf" "pdf")
+ ("application/pgp-keys" "key")
+ ("application/pgp-signature" "pgp")
+ ("application/pics-rules" "prf")
+ ("application/postscript" "ps" "ai" "eps")
+ ("application/rar" "rar")
+ ("application/rdf+xml" "rdf")
+ ("application/rss+xml" "rss")
+ ("application/smil" "smi" "smil")
+ ("application/wordperfect" "wpd")
+ ("application/wordperfect5.1" "wp5")
+ ("application/xhtml+xml" "xhtml" "xht")
+ ("application/xml" "fo" "xml" "xsl")
+ ("application/zip" "zip")
+ ("application/vnd.cinderella" "cdy")
+ ("application/vnd.mozilla.xul+xml" "xul")
+ ("application/vnd.ms-excel" "xls" "xlb" "xlt")
+ ("application/vnd.ms-pki.seccat" "cat")
+ ("application/vnd.ms-pki.stl" "stl")
+ ("application/vnd.ms-powerpoint" "ppt" "pps")
+ ("application/vnd.oasis.opendocument.chart" "odc")
+ ("application/vnd.oasis.opendocument.database" "odb")
+ ("application/vnd.oasis.opendocument.formula" "odf")
+ ("application/vnd.oasis.opendocument.graphics" "odg")
+ ("application/vnd.oasis.opendocument.graphics-template" "otg")
+ ("application/vnd.oasis.opendocument.image" "odi")
+ ("application/vnd.oasis.opendocument.presentation" "odp")
+ ("application/vnd.oasis.opendocument.presentation-template" "otp")
+ ("application/vnd.oasis.opendocument.spreadsheet" "ods")
+ ("application/vnd.oasis.opendocument.spreadsheet-template" "ots")
+ ("application/vnd.oasis.opendocument.text" "odt")
+ ("application/vnd.oasis.opendocument.text-master" "odm")
+ ("application/vnd.oasis.opendocument.text-template" "ott")
+ ("application/vnd.oasis.opendocument.text-web" "oth")
+ ("application/vnd.rim.cod" "cod")
+ ("application/vnd.smaf" "mmf")
+ ("application/vnd.stardivision.calc" "sdc")
+ ("application/vnd.stardivision.draw" "sda")
+ ("application/vnd.stardivision.impress" "sdd" "sdp")
+ ("application/vnd.stardivision.math" "smf")
+ ("application/vnd.stardivision.writer" "sdw" "vor")
+ ("application/vnd.stardivision.writer-global" "sgl")
+ ("application/vnd.sun.xml.calc" "sxc")
+ ("application/vnd.sun.xml.calc.template" "stc")
+ ("application/vnd.sun.xml.draw" "sxd")
+ ("application/vnd.sun.xml.draw.template" "std")
+ ("application/vnd.sun.xml.impress" "sxi")
+ ("application/vnd.sun.xml.impress.template" "sti")
+ ("application/vnd.sun.xml.math" "sxm")
+ ("application/vnd.sun.xml.writer" "sxw")
+ ("application/vnd.sun.xml.writer.global" "sxg")
+ ("application/vnd.sun.xml.writer.template" "stw")
+ ("application/vnd.symbian.install" "sis")
+ ("application/vnd.visio" "vsd")
+ ("application/vnd.wap.wbxml" "wbxml")
+ ("application/vnd.wap.wmlc" "wmlc")
+ ("application/vnd.wap.wmlscriptc" "wmlsc")
+ ("application/x-123" "wk")
+ ("application/x-abiword" "abw")
+ ("application/x-apple-diskimage" "dmg")
+ ("application/x-bcpio" "bcpio")
+ ("application/x-bittorrent" "torrent")
+ ("application/x-cdf" "cdf")
+ ("application/x-cdlink" "vcd")
+ ("application/x-chess-pgn" "pgn")
+ ("application/x-cpio" "cpio")
+ ("application/x-csh" "csh")
+ ("application/x-debian-package" "deb" "udeb")
+ ("application/x-director" "dcr" "dir" "dxr")
+ ("application/x-dms" "dms")
+ ("application/x-doom" "wad")
+ ("application/x-dvi" "dvi")
+ ("application/x-flac" "flac")
+ ("application/x-font" "pfa" "pfb" "gsf" "pcf")
+ ("application/x-freemind" "mm")
+ ("application/x-futuresplash" "spl")
+ ("application/x-gnumeric" "gnumeric")
+ ("application/x-go-sgf" "sgf")
+ ("application/x-graphing-calculator" "gcf")
+ ("application/x-gtar" "gtar" "tgz" "taz")
+ ("application/x-hdf" "hdf")
+ ("application/x-httpd-php" "phtml" "pht" "php")
+ ("application/x-httpd-php-source" "phps")
+ ("application/x-httpd-php3" "php3")
+ ("application/x-httpd-php3-preprocessed" "php3p")
+ ("application/x-httpd-php4" "php4")
+ ("application/x-ica" "ica")
+ ("application/x-internet-signup" "ins" "isp")
+ ("application/x-iphone" "iii")
+ ("application/x-iso9660-image" "iso")
+ ("application/x-java-jnlp-file" "jnlp")
+ ("application/x-javascript" "js")
+ ("application/x-jmol" "jmz")
+ ("application/x-kchart" "chrt")
+ ("application/x-killustrator" "kil")
+ ("application/x-koan" "skp" "skd" "skt" "skm")
+ ("application/x-kpresenter" "kpr" "kpt")
+ ("application/x-kspread" "ksp")
+ ("application/x-kword" "kwd" "kwt")
+ ("application/x-latex" "latex")
+ ("application/x-lha" "lha")
+ ("application/x-lzh" "lzh")
+ ("application/x-lzx" "lzx")
+ ("application/x-maker" "frm" "maker" "frame" "fm" "fb" "book" "fbdoc")
+ ("application/x-mif" "mif")
+ ("application/x-ms-wmd" "wmd")
+ ("application/x-ms-wmz" "wmz")
+ ("application/x-msdos-program" "com" "exe" "bat" "dll")
+ ("application/x-msi" "msi")
+ ("application/x-netcdf" "nc")
+ ("application/x-ns-proxy-autoconfig" "pac")
+ ("application/x-nwc" "nwc")
+ ("application/x-object" "o")
+ ("application/x-oz-application" "oza")
+ ("application/x-pkcs7-certreqresp" "p7r")
+ ("application/x-pkcs7-crl" "crl")
+ ("application/x-python-code" "pyc" "pyo")
+ ("application/x-quicktimeplayer" "qtl")
+ ("application/x-redhat-package-manager" "rpm")
+ ("application/x-sh" "sh")
+ ("application/x-shar" "shar")
+ ("application/x-shockwave-flash" "swf" "swfl")
+ ("application/x-stuffit" "sit")
+ ("application/x-sv4cpio" "sv4cpio")
+ ("application/x-sv4crc" "sv4crc")
+ ("application/x-tar" "tar")
+ ("application/x-tcl" "tcl")
+ ("application/x-tex-gf" "gf")
+ ("application/x-tex-pk" "pk")
+ ("application/x-texinfo" "texinfo" "texi")
+ ("application/x-trash" "~%" "" "bak" "old" "sik")
+ ("application/x-troff" "tt" "r" "roff")
+ ("application/x-troff-man" "man")
+ ("application/x-troff-me" "me")
+ ("application/x-troff-ms" "ms")
+ ("application/x-ustar" "ustar")
+ ("application/x-wais-source" "src")
+ ("application/x-wingz" "wz")
+ ("application/x-x509-ca-cert" "crt")
+ ("application/x-xcf" "xcf")
+ ("application/x-xfig" "fig")
+ ("application/x-xpinstall" "xpi")
+ ("audio/basic" "au" "snd")
+ ("audio/midi" "mid" "midi" "kar")
+ ("audio/mpeg" "mpga" "mpega" "mp2" "mp3" "m4a")
+ ("audio/mpegurl" "m3u")
+ ("audio/prs.sid" "sid")
+ ("audio/x-aiff" "aif" "aiff" "aifc")
+ ("audio/x-gsm" "gsm")
+ ("audio/x-mpegurl" "m3u")
+ ("audio/x-ms-wma" "wma")
+ ("audio/x-ms-wax" "wax")
+ ("audio/x-pn-realaudio" "ra" "rm" "ram")
+ ("audio/x-realaudio" "ra")
+ ("audio/x-scpls" "pls")
+ ("audio/x-sd2" "sd2")
+ ("audio/x-wav" "wav")
+ ("chemical/x-alchemy" "alc")
+ ("chemical/x-cache" "cac" "cache")
+ ("chemical/x-cache-csf" "csf")
+ ("chemical/x-cactvs-binary" "cbin" "cascii" "ctab")
+ ("chemical/x-cdx" "cdx")
+ ("chemical/x-cerius" "cer")
+ ("chemical/x-chem3d" "c3d")
+ ("chemical/x-chemdraw" "chm")
+ ("chemical/x-cif" "cif")
+ ("chemical/x-cmdf" "cmdf")
+ ("chemical/x-cml" "cml")
+ ("chemical/x-compass" "cpa")
+ ("chemical/x-crossfire" "bsd")
+ ("chemical/x-csml" "csml" "csm")
+ ("chemical/x-ctx" "ctx")
+ ("chemical/x-cxf" "cxf" "cef")
+ ("chemical/x-embl-dl-nucleotide" "emb" "embl")
+ ("chemical/x-galactic-spc" "spc")
+ ("chemical/x-gamess-input" "inp" "gam" "gamin")
+ ("chemical/x-gaussian-checkpoint" "fch" "fchk")
+ ("chemical/x-gaussian-cube" "cub")
+ ("chemical/x-gaussian-input" "gau" "gjc" "gjf")
+ ("chemical/x-gaussian-log" "gal")
+ ("chemical/x-gcg8-sequence" "gcg")
+ ("chemical/x-genbank" "gen")
+ ("chemical/x-hin" "hin")
+ ("chemical/x-isostar" "istr" "ist")
+ ("chemical/x-jcamp-dx" "jdx" "dx")
+ ("chemical/x-kinemage" "kin")
+ ("chemical/x-macmolecule" "mcm")
+ ("chemical/x-macromodel-input" "mmd" "mmod")
+ ("chemical/x-mdl-molfile" "mol")
+ ("chemical/x-mdl-rdfile" "rd")
+ ("chemical/x-mdl-rxnfile" "rxn")
+ ("chemical/x-mdl-sdfile" "sd" "sdf")
+ ("chemical/x-mdl-tgf" "tgf")
+ ("chemical/x-mmcif" "mcif")
+ ("chemical/x-mol2" "mol2")
+ ("chemical/x-molconn-Z" "b")
+ ("chemical/x-mopac-graph" "gpt")
+ ("chemical/x-mopac-input" "mop" "mopcrt" "mpc" "dat" "zmt")
+ ("chemical/x-mopac-out" "moo")
+ ("chemical/x-mopac-vib" "mvb")
+ ("chemical/x-ncbi-asn1" "asn")
+ ("chemical/x-ncbi-asn1-ascii" "prt" "ent")
+ ("chemical/x-ncbi-asn1-binary" "val" "aso")
+ ("chemical/x-ncbi-asn1-spec" "asn")
+ ("chemical/x-pdb" "pdb" "ent")
+ ("chemical/x-rosdal" "ros")
+ ("chemical/x-swissprot" "sw")
+ ("chemical/x-vamas-iso14976" "vms")
+ ("chemical/x-vmd" "vmd")
+ ("chemical/x-xtel" "xtel")
+ ("chemical/x-xyz" "xyz")
+ ("image/gif" "gif")
+ ("image/ief" "ief")
+ ("image/jpeg" "jpeg" "jpg" "jpe")
+ ("image/pcx" "pcx")
+ ("image/png" "png")
+ ("image/svg+xml" "svg" "svgz")
+ ("image/tiff" "tiff" "tif")
+ ("image/vnd.djvu" "djvu" "djv")
+ ("image/vnd.wap.wbmp" "wbmp")
+ ("image/x-cmu-raster" "ras")
+ ("image/x-coreldraw" "cdr")
+ ("image/x-coreldrawpattern" "pat")
+ ("image/x-coreldrawtemplate" "cdt")
+ ("image/x-corelphotopaint" "cpt")
+ ("image/x-icon" "ico")
+ ("image/x-jg" "art")
+ ("image/x-jng" "jng")
+ ("image/x-ms-bmp" "bmp")
+ ("image/x-photoshop" "psd")
+ ("image/x-portable-anymap" "pnm")
+ ("image/x-portable-bitmap" "pbm")
+ ("image/x-portable-graymap" "pgm")
+ ("image/x-portable-pixmap" "ppm")
+ ("image/x-rgb" "rgb")
+ ("image/x-xbitmap" "xbm")
+ ("image/x-xpixmap" "xpm")
+ ("image/x-xwindowdump" "xwd")
+ ("model/iges" "igs" "iges")
+ ("model/mesh" "msh" "mesh" "silo")
+ ("model/vrml" "wrl" "vrml")
+ ("text/calendar" "ics" "icz")
+ ("text/comma-separated-values" "csv")
+ ("text/css" "css")
+ ("text/h323" "323")
+ ("text/html" "html" "htm" "shtml")
+ ("text/iuls" "uls")
+ ("text/mathml" "mml")
+ ("text/plain" "asc" "txt" "text" "diff" "pot")
+ ("text/richtext" "rtx")
+ ("text/rtf" "rtf")
+ ("text/scriptlet" "sct" "wsc")
+ ("text/texmacs" "tm" "ts")
+ ("text/tab-separated-values" "tsv")
+ ("text/vnd.sun.j2me.app-descriptor" "jad")
+ ("text/vnd.wap.wml" "wml")
+ ("text/vnd.wap.wmlscript" "wmls")
+ ("text/x-bibtex" "bib")
+ ("text/x-boo" "boo")
+ ("text/x-c++hdr" "h++" "hpp" "hxx" "hh")
+ ("text/x-c++src" "c++" "cpp" "cxx" "cc")
+ ("text/x-chdr" "h")
+ ("text/x-component" "htc")
+ ("text/x-csh" "csh")
+ ("text/x-csrc" "c")
+ ("text/x-dsrc" "d")
+ ("text/x-haskell" "hs")
+ ("text/x-java" "java")
+ ("text/x-literate-haskell" "lhs")
+ ("text/x-moc" "moc")
+ ("text/x-pascal" "pp" "as")
+ ("text/x-pcs-gcd" "gcd")
+ ("text/x-perl" "pl" "pm")
+ ("text/x-python" "py")
+ ("text/x-setext" "etx")
+ ("text/x-sh" "sh")
+ ("text/x-tcl" "tcl" "tk")
+ ("text/x-tex" "tex" "ltx" "sty" "cls")
+ ("text/x-vcalendar" "vcs")
+ ("text/x-vcard" "vcf")
+ ("video/dl" "dl")
+ ("video/dv" "dif" "dv")
+ ("video/fli" "fli")
+ ("video/gl" "gl")
+ ("video/mpeg" "mpeg" "mpg" "mpe")
+ ("video/mp4" "mp4")
+ ("video/quicktime" "qt" "mov")
+ ("video/vnd.mpegurl" "mxu")
+ ("video/x-la-asf" "lsf" "lsx")
+ ("video/x-mng" "mng")
+ ("video/x-ms-asf" "asf" "asx")
+ ("video/x-ms-wm" "wm")
+ ("video/x-ms-wmv" "wmv")
+ ("video/x-ms-wmx" "wmx")
+ ("video/x-ms-wvx" "wvx")
+ ("video/x-msvideo" "avi")
+ ("video/x-sgi-movie" "movie")
+ ("x-conference/x-cooltalk" "ice")
+ ("x-world/x-vrml" "vrm" "vrml" "wrl"))
+ "An alist where the cars are MIME types and the cdrs are list
+of file suffixes for the corresponding type.")
+
+(defparameter *mime-type-hash*
+ (let ((hash (make-hash-table :test #'equalp)))
+ (loop for (type . suffixes) in *mime-type-list* do
+ (loop for suffix in suffixes do
+ (setf (gethash suffix hash) type)))
+ hash)
+ "A hash table which maps file suffixes to MIME types.")
+
+(defun mime-type (pathspec)
+ "Given a pathname designator PATHSPEC returns the MIME type
+\(as a string) corresponding to the suffix of the file denoted by
+PATHSPEC \(or NIL)."
+ (gethash (pathname-type pathspec) *mime-type-hash*))
\ No newline at end of file
Added: trunk/main/claw-as/src/misc.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/misc.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,569 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/misc.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-as)
+
+(defconstant +buffer-length+ 8192
+ "Length of buffers used for internal purposes.")
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+
+ (defvar *clawserver* nil
+ "The current serving CLAWSERVER instance")
+
+ (defvar *session-manager* nil
+ "The SESSION-MANAGER used by the *CLAWSERVER*")
+
+ (defvar *apache-http-port* 80
+ "Default apache http port when claw is running in mod_lisp mode, or behind mod_proxy")
+ (defvar *apache-https-port* 443
+ "Default apache https port when claw is running in mod_lisp mode, or behind mod_proxy")
+
+ (defvar *claw-default-server-address* nil
+ "Default host address given as default server address for lisplets used on redirections")
+
+ (defvar *claw-libraries-resources* ()
+ "Global variable to hold exposed web resources")
+
+ (defvar *claw-current-realm* "CLAW"
+ "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.")
+
+ (defvar *claw-current-lisplet* nil
+ "The liplet currently serving")
+
+ (defvar *claw-session* nil
+ "The session bound to the current request")
+
+ (defvar *http-reason-phrase-map* (make-hash-table)
+ "Used to map numerical return codes to reason phrases.")
+
+ (defvar *day-names*
+ '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
+ "The three-character names of the seven days of the week - needed
+for cookie date format.")
+
+ (defvar *month-names*
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+ "The three-character names of the twelve months - needed for cookie
+date format.")
+
+ (defvar *root-path*
+ nil
+ "The eventually froxified lisplet path ")
+
+ (defvar *server-path*
+ nil
+ "The eventually froxified claw server path ")
+
+ (defmacro def-http-return-code (name value reason-phrase)
+ "Shortcut to define constants for return codes. NAME is a
+Lisp symbol, VALUE is the numerical value of the return code, and
+REASON-PHRASE is the phrase \(a string) to be shown in the
+server's status line."
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'."
+ value reason-phrase))
+ (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase)))
+
+ (defvar *http-reason-phrase-map* (make-hash-table)
+ "Used to map numerical return codes to reason phrases."))
+
+(def-http-return-code +http-continue+ 100 "Continue")
+(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols")
+(def-http-return-code +http-ok+ 200 "OK")
+(def-http-return-code +http-created+ 201 "Created")
+(def-http-return-code +http-accepted+ 202 "Accepted")
+(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information")
+(def-http-return-code +http-no-content+ 204 "No Content")
+(def-http-return-code +http-reset-content+ 205 "Reset Content")
+(def-http-return-code +http-partial-content+ 206 "Partial Content")
+(def-http-return-code +http-multi-status+ 207 "Multi-Status")
+(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices")
+(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently")
+(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily")
+(def-http-return-code +http-see-other+ 303 "See Other")
+(def-http-return-code +http-not-modified+ 304 "Not Modified")
+(def-http-return-code +http-use-proxy+ 305 "Use Proxy")
+(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect")
+(def-http-return-code +http-bad-request+ 400 "Bad Request")
+(def-http-return-code +http-authorization-required+ 401 "Authorization Required")
+(def-http-return-code +http-payment-required+ 402 "Payment Required")
+(def-http-return-code +http-forbidden+ 403 "Forbidden")
+(def-http-return-code +http-not-found+ 404 "Not Found")
+(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed")
+(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable")
+(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required")
+(def-http-return-code +http-request-time-out+ 408 "Request Time-out")
+(def-http-return-code +http-conflict+ 409 "Conflict")
+(def-http-return-code +http-gone+ 410 "Gone")
+(def-http-return-code +http-length-required+ 411 "Length Required")
+(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed")
+(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large")
+(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large")
+(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type")
+(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable")
+(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed")
+(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency")
+(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error")
+(def-http-return-code +http-not-implemented+ 501 "Not Implemented")
+(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway")
+(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable")
+(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out")
+(def-http-return-code +http-version-not-supported+ 505 "Version not supported")
+
+(defvar *approved-return-codes* '(#.+http-ok+
+ #.+http-no-content+
+ #.+http-multi-status+
+ #.+http-not-modified+)
+ "A list of return codes the server should not treat as an error -
+see *HANDLE-HTTP-ERRORS-P*.")
+
+;;--------------------------------------------------------------------------------------------
+;;---------------------------------------- WRAPPERS -----------------------------------------
+;;--------------------------------------------------------------------------------------------
+
+(defun claw-request-method ()
+ "Wrapper function around CLAWSERVER-REQUEST-METHOD.
+Returns :GET or POST. respectively."
+ (clawserver-request-method *clawserver*))
+
+(defun claw-script-name ()
+ "Wrapper function around CLAWSERVER-SCRIPT-NAME.
+Returns the file name \(or path) component of the URI for request \(before the question mark),"
+ (clawserver-script-name *clawserver*))
+
+(defun claw-request-uri ()
+ "Wrapper function around CLAWSERVER-REQUEST-URI.
+Returns the URI for request."
+ (clawserver-request-uri *clawserver*))
+
+(defun claw-query-string ()
+ "Wrapper function around CLAWSERVER-QUERY-STRING.
+Returns the query component of the URI for request \(the part behing the question mark)"
+ (clawserver-query-string *clawserver*))
+
+(defun claw-get-parameter (name)
+ "Wrapper function around CLAWSERVER-GET-PARAMETER.
+Returns the value of the GET parameter as a string \(or nil), identified by NAME \(a string too)"
+ (clawserver-get-parameter *clawserver* name))
+
+(defun claw-get-parameters ()
+ "Wrapper function around CLAWSERVER-GET-PARAMETERS.
+Returns an alist of all GET parameters."
+ (clawserver-get-parameters *clawserver*))
+
+(defun claw-post-parameter (name)
+ "Wrapper function around CLAWSERVER-POST-PARAMETER.
+Returns the value of the POST parameter as a string \(or nil), identified by NAME \(a string too)"
+ (clawserver-post-parameter *clawserver* name))
+
+(defun claw-post-parameters ()
+ "Wrapper function around CLAWSERVER-POST-PARAMETERS.
+Returns an alist of all POST parameters."
+ (clawserver-post-parameters *clawserver*))
+
+(defun claw-parameter (name)
+ "Wrapper function around CLAWSERVER-PARAMETER.
+Returns the value of the GET or POST parameter as a string \(or nil), identified by NAME \(a string too)"
+ (clawserver-parameter *clawserver* name))
+
+(defun claw-header-in (symbol)
+ "Wrapper function around CLAWSERVER-HEADER-IN.
+Returns the incoming header named by the keyword SYMBOL, as a string."
+ (clawserver-header-in *clawserver* symbol))
+
+(defun claw-headers-in ()
+ "Wrapper function around CLAWSERVER-HEADERS-IN."
+ (clawserver-headers-in *clawserver*))
+
+(defun claw-authorization ()
+ "Wrapper function around CLAWSERVER-AUTHORIZATION.
+Returns as two values the user and password \(if any) from the incoming Authorization http header."
+ (clawserver-authorization *clawserver*))
+
+(defun claw-remote-addr ()
+ "Wrapper function around CLAWSERVER-REMOTE-ADDR.
+Returns the IP address \(as a string) of the client which sent the request."
+ (clawserver-remote-addr *clawserver*))
+
+(defun claw-remote-port ()
+ "Wrapper function around CLAWSERVER-REMOTE-PORT.
+Returns the IP port \(as a number) of the client which sent the request."
+ (clawserver-remote-port *clawserver*))
+
+(defun claw-real-remote-addr ()
+ "Wrapper function around CLAWSERVER-REAL-REMOTE-ADDR see it for more info."
+ (clawserver-real-remote-addr *clawserver*))
+
+(defun claw-server-addr ()
+ "Wrapper function around CLAWSERVER-SERVER-ADDR.
+Returns the IP address \(as a string) where the request came in."
+ (clawserver-server-addr *clawserver*))
+
+(defun claw-server-port ()
+ "Wrapper function around CLAWSERVER-SERVER-PORT.
+Returns the IP port \(as a number) where the request came in."
+ (clawserver-server-port *clawserver*))
+
+(defun claw-user-agent ()
+ "Wrapper function around CLAWSERVER-USER-AGENT.
+Returns the value of the incoming User-Agent http header."
+ (clawserver-user-agent *clawserver*))
+
+(defun claw-referer ()
+ "Wrapper function around CLAWSERVER-REFERER see it for more info."
+ (clawserver-referer *clawserver*))
+
+(defun claw-cookie-in (name)
+ "Wrapper function around CLAWSERVER-COOKIE-IN.
+Returns the value \(a CLAW-COOKIE instance or nil) of the incoming cookie named by the string NAME."
+ (clawserver-cookie-in *clawserver* name))
+
+(defun claw-cookies-in ()
+ "Wrapper function around CLAWSERVER-COOKIES-IN.
+Returns the value \(as CLAW-COOKIE instance) of the incoming cookies."
+ (clawserver-cookies-in *clawserver*))
+
+(defun claw-aux-request-value (symbol)
+ "Wrapper function around CLAWSERVER-AUX-REQUEST-VALUE.
+Returns values VALUE, PRESENTP.
+This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request.
+present-p is true if such data was found, otherwise NIL"
+ (clawserver-aux-request-value *clawserver* symbol))
+
+(defun (setf claw-aux-request-value) (value symbol)
+ "Wrapper function around (SETF CLAWSERVER-AUX-REQUEST-VALUE).
+This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request."
+ (setf (clawserver-aux-request-value *clawserver* symbol) value))
+
+(defun claw-delete-aux-request-value (symbol)
+ "Wrapper function around CLAWSERVER-DELETE-AUX-REQUEST-VALUE.
+Completely removes any data associated with the symbol symbol from the REQUEST object request."
+ (clawserver-delete-aux-request-value *clawserver* symbol))
+
+(defun claw-content-type ()
+ "Returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."
+ (clawserver-content-type *clawserver*))
+
+(defun (setf claw-content-type) (value)
+ "Sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."
+ (setf (clawserver-content-type *clawserver*) value))
+
+(defun claw-content-length ()
+ "Returns the outgoing Content-Length http header"
+ (clawserver-content-length *clawserver*))
+
+(defun (setf claw-content-length) (value)
+ "Sets the outgoing Content-Length http header"
+ (setf (clawserver-content-length *clawserver*) value))
+
+;;---------------------------
+
+(defun claw-header-out (symbol)
+ "Wrapper function around CLAWSERVER-HEADER-OUT.
+Returns the outgoing http header named by the keyword name if there is one, otherwise NIL."
+ (clawserver-header-out *clawserver* symbol))
+
+(defun (setf claw-header-out) (value symbol)
+ "Wrapper function around \(SETF CLAWSERVER-HEADER-OUT).
+SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol).
+If no header named name exists it is created."
+ (setf (clawserver-header-out *clawserver* symbol) value))
+
+(defun claw-headers-out ()
+ "Wrapper function around CLAWSERVER-HEADERS-OUT.
+Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type)."
+ (clawserver-headers-out *clawserver*))
+
+(defun claw-cookie-out (name)
+ "Wrapper function around CLAWSERVER-COOKIE-OUT.
+Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)."
+ (clawserver-cookie-out *clawserver* name))
+
+(defun (setf claw-cookie-out) (cookie-instance name)
+ "Wrapper function around \(SETF CLAWSERVER-COOKIE-OUT).
+Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply."
+ (setf (clawserver-cookie-out *clawserver* name) cookie-instance))
+
+(defun claw-cookies-out ()
+ "Wrapper function around CLAWSERVER-COOKIES-OUT.
+Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)."
+ (clawserver-cookies-out *clawserver*))
+
+(defun claw-return-code ()
+ "Wrapper function around CLAWSERVER-COOKIES-OUT.
+Returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)"
+ (clawserver-return-code *clawserver*))
+
+(defun (setf claw-return-code) (value)
+ "Wrapper function around \(SETF CLAWSERVER-COOKIES-OUT).
+Sets the http return code of the reply."
+ (setf (clawserver-return-code *clawserver*) value))
+
+(defun claw-reply-external-format-encoding ()
+ "Wrapper function around CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING.
+Returns the symbol of the reply charset encoding \(Such as UTF-8)."
+ (clawserver-reply-external-format-encoding *clawserver*))
+
+(defun (setf claw-reply-external-format-encoding) (value)
+ "Wrapper function around (SETF CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING).
+Sets the symbol of the reply charset encoding \(Such as UTF-8)."
+ (setf (clawserver-reply-external-format-encoding *clawserver*) value))
+
+(defun claw-writer ()
+ "Wrapper function around CLAWSERVER-WRITER.
+Returns the output stream writer to generate replies. It's default to *standard-output*"
+ (clawserver-writer *clawserver*))
+
+(defun claw-redirect (target &key host port protocol add-session-id code)
+ "Wrapper function around CLAWSERVER-REDIRECT.
+Sends back appropriate headers to redirect the client to target \(a string)."
+ (clawserver-redirect *clawserver* target
+ :host (or host (claw-host-name))
+ :port port
+ :protocol protocol
+ :add-session-id add-session-id :code code))
+
+(defun claw-session-value (symbol)
+ "Wrapper function around SESSION-MANAGER-SESSION-VALUE.
+Returns the value identified by SYMBOL, bounded to the user session."
+ (session-manager-session-value (clawserver-session-manager *clawserver*) symbol))
+
+(defun (setf claw-session-value) (value symbol)
+ "Wrapper function around (SETF SESSION-MANAGER-SESSION-VALUE).
+Sets or modifies the value identified by SYMBOL, bounded to the user session"
+ (setf (session-manager-session-value (clawserver-session-manager *clawserver*) symbol) value))
+
+(defun claw-delete-session-value (symbol)
+ "Wrapper function around SESSION-MANAGER-DELETE-SESSION-VALUE.
+Deletes the value identified by SYMBOL, bounded to the user session.
+This is different from setting the value to null."
+ (session-manager-delete-session-value (clawserver-session-manager *clawserver*) symbol))
+;;--------------------------------------------------------------------------------------------
+;;---------------------------------------- WRAPPERS --------------------------------------END
+;;--------------------------------------------------------------------------------------------
+
+
+(defun duplicate-back-slashes (string)
+ (regex-replace-all "\\" string "\\\\\\\\"))
+
+(defun sort-by-location (location-list)
+ "Sorts a list of location items by their first element (the location itself)."
+ (sort location-list #'(lambda (item1 item2)
+ (string-not-lessp (first item1) (first item2)))))
+
+(defun sort-protected-resources (protected-resources)
+ "Sorts a list of protected resources. A protected resource is a cons where the car is the url
+of the resource and the cdr is a list of roles allowhed to access that resource."
+ (sort protected-resources #'(lambda (item1 item2)
+ (string-lessp (car item1) (car item2)))))
+
+(defun remove-by-location (location location-list)
+ "Removes an item from LOCATION-LIST checking its first element
+against the LOCATION parameter"
+ (delete-if #'(lambda (item) (string= (first item) location)) location-list))
+
+(defun pushnew-location (location-items location-list)
+ "Isert a new location info items into a list, or replace the one that has the same location
+registered (its first element)."
+ (let ((result (remove-by-location (first location-items) location-list)))
+ (setf result (push location-items result))))
+
+(defun claw-start-session (&key max-time domain)
+ "Starts a session bound to the current lisplet base path"
+ (session-manager-start-session (clawserver-session-manager *clawserver*)
+ :path (format nil "~a/" *root-path*)
+ :max-time max-time
+ :domain domain))
+
+(defun claw-remove-session ()
+ "Disposes user session if present"
+ (session-manager-remove-session (clawserver-session-manager *clawserver*)))
+
+(defun current-principal ()
+ "Returns the principal(user) that logged into the application"
+ (when *claw-session*
+ (claw-session-value 'principal)))
+
+(defun (setf current-principal) (principal)
+ "Setf the principal(user) that logged into the application"
+ (unless *claw-session*
+ (setf *claw-session* (claw-start-session)))
+ (setf (claw-session-value 'principal) principal))
+
+(defun user-in-role-p (roles)
+ "Detects if current principal belongs to any of the expressed roles"
+ (let ((principal (current-principal)))
+ (when principal
+ (loop for el in (principal-roles principal) thereis (member el roles :test #'string-equal)))))
+
+(defun current-config ()
+ "Returns the current configuration object for the realm of the request"
+ (gethash *claw-current-realm* (clawserver-login-config *clawserver*)))
+
+(defun flatten (tree &optional result-list)
+ "Traverses the tree in order, collecting even non-null leaves into a list."
+ (let ((result result-list))
+ (loop for element in tree
+ do (cond
+ ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
+ (t (push element result))))
+ (nreverse result)))
+
+(defun user-locale ()
+ "This function returns the user locale. If no locale was directly set, the browser default locale is used."
+ (let ((locale (when *claw-session* (claw-session-value 'locale))))
+ (or locale
+ (first (loop for str in (all-matches-as-strings
+ "[A-Z|a-z|_]+"
+ (regex-replace-all "-" (regex-replace-all ";.*" (claw-header-in 'ACCEPT-LANGUAGE) "") "_"))
+ collect (if (> (length str) 2)
+ (string-upcase str :start 2)
+ str))))))
+
+(defun (setf user-locale) (locale)
+ "This function forces the locale for the current user, binding it to the user session,
+that is created if no session exists."
+ (unless *claw-session*
+ (setf *claw-session* (claw-start-session)))
+ (setf (claw-session-value 'locale) locale))
+
+(deftype unsigned-byte-8 ()
+ '(unsigned-byte 8))
+
+(defun claw-handle-static-file (path &optional content-type (server *clawserver*))
+ "A function which acts like a Hunchentoot handler for the file
+denoted by PATH. Send a content type header corresponding to
+CONTENT-TYPE or \(if that is NIL) tries to determine the content
+type via the file's suffix."
+ (unless (and (fad:file-exists-p path)
+ (not (fad:directory-exists-p path)))
+ ;; does not exist
+ (setf (claw-return-code) 404)
+ (throw 'handler-done nil))
+ (let ((time (or (file-write-date path) (get-universal-time)))
+ (if-modified-since (claw-header-in :if-modified-since)))
+ (setf (claw-content-type) (or content-type
+ (mime-type path)
+ "application/octet-stream"))
+ (when (and if-modified-since (equal if-modified-since (rfc-1123-date time)))
+ (setf (claw-return-code) +http-not-modified+)
+ (throw 'handler-done nil))
+ (with-open-file (file path
+ :direction :input
+ :element-type 'unsigned-byte-8
+ :if-does-not-exist nil)
+ (setf (claw-header-out "Last-Modified") (rfc-1123-date time)
+ (claw-content-length) (file-length file))
+ (let ((out (clawserver-writer server)))
+ (loop with buf = (make-array +buffer-length+ :element-type 'unsigned-byte-8)
+ for pos = (read-sequence buf file)
+ until (zerop pos)
+ do (write-sequence buf out :end pos)
+ (finish-output out))))))
+
+(defun claw-write-response-string (content &key (content-type "text/html") last-modified)
+ (when content
+ (when last-modified
+ (setf (claw-header-out "Last-Modified") (rfc-1123-date last-modified)))
+ (setf (claw-content-length) (length content)
+ (claw-content-type) content-type)
+ (let ((out (clawserver-writer *clawserver*)))
+ (write-sequence content out)
+ (finish-output out))
+ content))
+
+(defun register-library-resource (location resource-path &optional content-type)
+ "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
+ (unless (string= "/" (subseq location 0 1))
+ (setf location (concatenate 'string "/" location)))
+ (setf *claw-libraries-resources*
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (claw-script-name)
+ (+ (length (clawserver-base-path *clawserver*))
+ (length location))))
+ resource-path)))
+ (claw-handle-static-file resource-full-path content-type)))
+ #'(lambda () (claw-handle-static-file resource-path content-type))))
+ *claw-libraries-resources*))))
+
+(defun uri-to-pathname (uri &optional (relative t))
+ "Convert an URI to a pathname"
+ (let* ((splitted-uri (split-sequence #\/ uri))
+ (directory-list (butlast splitted-uri))
+ (file (first (last splitted-uri)))
+ (pos (position #\. file :from-end t))
+ (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) ""))
+ (list (subseq file 0 pos)(subseq file (1+ pos)))
+ (list file))))
+ (make-pathname :directory (if relative
+ (cons :relative directory-list)
+ (cons :absolute directory-list))
+ :name (first file-name-and-type)
+ :type (second file-name-and-type))))
+
+(defun rfc-1123-date (&optional (time (get-universal-time)))
+ "Generates a time string according to RFC 1123. Default is current time."
+ (multiple-value-bind
+ (second minute hour date month year day-of-week)
+ (decode-universal-time time 0)
+ (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
+ (nth day-of-week *day-names*)
+ date
+ (nth (1- month) *month-names*)
+ year
+ hour
+ minute
+ second)))
+
+(defun claw-host-name ()
+ "Extracts the host name from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+ (first (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-port ()
+ "Extracts the host port from the HOST header-in parameter or the X-FORWARDED-HOST, if present"
+ (second (split-sequence #\: (or (claw-header-in 'x-forwarded-host) (claw-header-in 'host)))))
+
+(defun claw-host-protocol ()
+ "Return :HTTP or :HTTPS depending on the header HOST parameter"
+ (let ((port (parse-integer (second (split-sequence #\: (claw-header-in 'host)))))
+ (connector (clawserver-connector *clawserver*)))
+ (if (= port (connector-port connector))
+ :http
+ :https)))
+
+(defun claw-proxified-p ()
+ "Retrun a non NIL value when the request is handled by a proxy"
+ (claw-header-in 'x-forwarded-host))
\ No newline at end of file
Added: trunk/main/claw-as/src/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/packages.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,191 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/package.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+
+(defpackage :claw-as
+ (:use :cl :closer-mop :alexandria :cl-ppcre :local-time :split-sequence :bordeaux-threads :md5)
+ (:shadow :flatten)
+ (:import-from :cl-fad :directory-pathname-p)
+ (:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
+ (:export #:*clawserver-base-path*
+ #:*apache-http-port*
+ #:*apache-https-port*
+ #:*claw-default-server-address*
+ #:*clawserver*
+ #:*session-manager*
+ #:*claw-current-lisplet*
+ #:*claw-current-realm*
+ #:*claw-session*
+ #:claw-request-method
+ #:claw-script-name
+ #:claw-request-uri
+ #:claw-query-string
+ #:claw-get-parameter
+ #:claw-get-parameters
+ #:claw-post-parameter
+ #:claw-post-parameters
+ #:claw-parameter
+ #:claw-header-in
+ #:claw-headers-in
+ #:claw-authorization
+ #:claw-host-name
+ #:claw-host-port
+ #:claw-host-protocol
+ #:claw-proxified-p
+ #:claw-remote-addr
+ #:claw-remote-port
+ #:claw-real-remote-addr
+ #:claw-server-addr
+ #:claw-server-port
+ #:claw-user-agent
+ #:claw-referer
+ #:claw-cookie-in
+ #:claw-cookies-in
+ #:claw-aux-request-value
+ #:claw-delete-aux-request-value
+ #:claw-content-type
+ #:claw-header-out
+ #:claw-headers-out
+ #:claw-cookie-out
+ #:claw-cookies-out
+ #:claw-return-code
+ #:claw-reply-external-format-encoding
+ #:claw-writer
+ #:claw-redirect
+ #:claw-session-value
+ #:claw-start-session
+ #:claw-remove-session
+ #:claw-delete-session-value
+ #:log-message
+ #:claw-cookie
+ #:claw-cookie-name
+ #:claw-cookie-value
+ #:claw-cookie-expires
+ #:claw-cookie-path
+ #:claw-cookie-domain
+ #:claw-cookie-secure
+ #:claw-cookie-http-only
+
+ #:connector
+ #:connector-host
+ #:connector-request-method
+ #:connector-script-name
+ #:connector-request-uri
+ #:connector-query-string
+ #:connector-get-parameter
+ #:connector-get-parameters
+ #:connector-post-parameter
+ #:connector-post-parameters
+ #:connector-parameter
+ #:connector-header-in
+ #:connector-headers-in
+ #:connector-authorization
+ #:connector-remote-addr
+ #:connector-remote-port
+ #:connector-real-remote-addr
+ #:connector-server-addr
+ #:connector-server-port
+ #:connector-server-protocol
+ #:connector-user-agent
+ #:connector-referer
+ #:connector-cookie-in
+ #:connector-cookies-in
+ #:connector-aux-request-value
+ #:connector-delete-aux-request-value
+ #:connector-header-out
+ #:connector-headers-out
+ #:connector-cookie-out
+ #:connector-cookies-out
+ #:connector-return-code
+ #:connector-content-type
+ #:connector-reply-external-format-encoding
+ #:connector-writer
+ #:connector-redirect
+ #:connector-content-length
+ #:connector-port
+ #:connector-sslport
+ #:connector-address
+
+ #:logger
+ #:logger-log
+
+ #:session-manager
+ #:default-session-manager
+ #:error-renderer
+
+ #:mime-type
+ #:duplicate-back-slashes
+ #:lisplet
+ #:lisplet-log-manager
+ #:lisplet-server-addrss
+ #:lisplet-error-handlers
+ #:lisplet-pages
+ #:lisplet-register-function-location
+ #:lisplet-register-resource-location
+ #:lisplet-protect
+ #:lisplet-authentication-type
+ #:lisplet-reverse-proxy-path
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;#:build-lisplet-location
+ #:*root-path*
+ #:*server-path*
+ ;; claw-service
+ #:claw-service
+ #:claw-service-name
+ #:claw-service-start
+ #:claw-service-stop
+ #:claw-service-running-p
+ ;; clawserver
+ #:clawserver
+ #:clawserver-start
+ #:clawserver-stop
+
+ #:clawserver-dispatch-method
+ #:clawserver-log-manager
+ #:clawserver-add-service
+ #:clawserver-base-path
+ #:clawserver-register-lisplet
+ #:clawserver-unregister-lisplet
+ #:clawserver-login-config
+
+ #:clawserver-register-configuration
+
+ #:configuration
+ #:configuration-login
+
+ #:principal
+ #:current-principal
+ #:principal-name
+ #:principal-roles
+ #:user-locale
+ #:user-in-role-p
+ #:login
+ #:register-library-resource))
\ No newline at end of file
Added: trunk/main/claw-as/src/server.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/server.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,591 @@
+;;; -*- 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-as)
+
+;;------------------------------------------------------------------------------------------
+(defgeneric error-renderer (clawserver &key error-code)
+ (:documentation "Method for rendering http errors. This method should be overridden."))
+
+(defgeneric clawserver-host (clawserver)
+ (:documentation "
+Returns the value of the incoming Host http header. \(This corresponds to the environment variable HTTP_HOST in CGI scripts.)"))
+
+(defgeneric clawserver-request-method (clawserver)
+ (:documentation "Returns the request method as a keyword, i.e. something like :POST. \(This corresponds to the environment variable REQUEST_METHOD in CGI scripts.)"))
+
+(defgeneric clawserver-request-uri (clawserver)
+ (:documentation "Returns the URI for request.
+Note that this not the full URI but only the part behind the scheme and authority components, so that if the user has typed http://user:password@www.domain.com/xxx/frob.html?foo=bar into his browser, this function will return \"/xxx/frob.html?foo=bar\". \(This corresponds to the environment variable REQUEST_URI in CGI scripts."))
+
+(defgeneric clawserver-script-name (connector)
+ (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any).
+\(This corresponds to the environment variable SCRIPT_NAME in CGI scripts.)"))
+
+(defgeneric clawserver-query-string (clawserver)
+ (:documentation "Returns the query component of the URI for request, i.e. the part of the string returned by REQUEST-URI behind the first question mark \(if any).
+\(This corresponds to the environment variable QUERY_STRING in CGI scripts.) See also CLAWSERVER-GET-PARAMETER and CLAWSERVER-GET-PARAMETERS."))
+
+(defgeneric clawserver-get-parameter (clawserver name)
+ (:documentation "Returns the value of the GET parameter \(as provided via the request URI) named by the string name as a string \(or NIL if there ain't no GET parameter with this name).
+Note that only the first value will be returned if the client provided more than one GET parameter with the name name. See also CLAWSERVER-GET-PARAMETERS"))
+
+(defgeneric clawserver-get-parameters (clawserver)
+ (:documentation "Returns an alist of all GET parameters \(as provided via the request URI). The car of each element of this list is the parameter's name while the cdr is its value \(as a string).
+The elements of this list are in the same order as they were within the request URI. See also CLAWSERVER-GET-PARAMETER."))
+
+(defgeneric clawserver-post-parameter (clawserver name)
+ (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name.
+Note that only the first value will be returned if the client provided more than one POST parameter with the name name.
+This value will usually be a string \(or NIL if there ain't no POST parameter with this name).
+If, however, the browser sent a file through a multipart/form-data form, the value of this function is a three-element list
+
+\(path file-name content-type)
+
+where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser.
+The file denoted by path will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it."))
+
+(defgeneric clawserver-post-parameters (clawserver)
+ (:documentation "Returns an alist of all POST parameters (as provided via the request's body). The car of each element of this list is the parameter's name while the cdr is its value. The elements of this list are in the same order as they were within the request's body.
+See also CLAWSERVER-POST-PARAMETER."))
+
+(defgeneric clawserver-parameter (clawserver name)
+ (:documentation "Returns the value of the GET or POST parameter named by the string name as a string \(or NIL if there ain't no parameter with this name).
+If both a GET and a POST parameter with the name name exist, the GET parameter will be returned. See also CLAWSERVER-GET-PARAMETER and CLAWSERVER-POST-PARAMETER."))
+
+(defgeneric clawserver-header-in (clawserver name)
+ (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name).
+Note that this queries the headers sent to Hunchentoot by the client or by mod_lisp. In the latter case this may not only include the incoming http headers but also some headers sent by mod_lisp.
+For backwards compatibility, name can also be a string which is matched case-insensitively. See also CLAWSERVER-HEADERS-IN."))
+
+(defgeneric clawserver-headers-in (clawserver)
+ (:documentation "Returns an alist of all incoming headers.
+The car of each element of this list is the headers's name \(a Lisp keyword) while the cdr is its value (as a string).
+There's no guarantee about the order of this list. See also CLAWSERVER-HEADER-IN and the remark about incoming headers there."))
+
+(defgeneric clawserver-authorization (clawserver)
+ (:documentation "Returns as two values the user and password \(if any) from the incoming Authorization http header.
+Returns NIL if there is no such header."))
+
+(defgeneric clawserver-remote-addr (clawserver)
+ (:documentation "Returns the IP address \(as a string) of the client which sent the request. \(This corresponds to the environment variable REMOTE_ADDR in CGI scripts.) See also CLAWSERVER-REAL-REMOTE-ADDR."))
+
+(defgeneric clawserver-remote-port (clawserver)
+ (:documentation "Returns the IP port (as a number) of the client which sent the request."))
+
+(defgeneric clawserver-real-remote-addr (clawserver)
+ (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists.
+Otherwise returns the value of CLAWSERVER-REMOTE-ADDR as the only value."))
+
+(defgeneric clawserver-server-addr (clawserver)
+ (:documentation "Returns the IP address \(as a string) where the request came in.
+\(This corresponds to the environment variable SERVER_ADDR in CGI scripts.)"))
+
+(defgeneric clawserver-server-port (clawserver)
+ (:documentation "Returns the IP port \(as a number) where the request came in."))
+
+(defgeneric clawserver-server-protocol (clawserver)
+ (:documentation "Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either :HTTP/1.0 or :HTTP/1.1.
+\(This corresponds to the environment variable SERVER_PROTOCOL in CGI scripts."))
+
+(defgeneric clawserver-user-agent (clawserver)
+ (:documentation "Returns the value of the incoming User-Agent http header.
+\(This corresponds to the environment variable HTTP_USER_AGENT in CGI scripts.)"))
+
+
+(defgeneric clawserver-referer (clawserver)
+ (:documentation "Returns the value of the incoming Referer \(sic!) http header. \(This corresponds to the environment variable HTTP_REFERER in CGI scripts.)"))
+
+(defgeneric clawserver-cookie-in (clawserver name)
+ (:documentation "Returns the value of the incoming cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CLAWSERVER-COOKIES-IN"))
+
+(defgeneric clawserver-cookies-in (clawserver)
+ (:documentation "Returns an alist of all incoming cookies.
+The car of each element of this list is the cookie's name while the cdr is the cookie's value. See also CLAWSERVER-COOKIE-IN"))
+
+(defgeneric clawserver-aux-request-value (clawserver symbol)
+ (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. present-p is true if such data was found, otherwise NIL"))
+
+(defgeneric (setf clawserver-aux-request-value) (value clawserver symbol)
+ (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. present-p is true if such data was found, otherwise NIL"))
+
+(defgeneric clawserver-delete-aux-request-value (clawserver symbol)
+ (:documentation "Completely removes any data associated with the symbol symbol from the REQUEST object request. Note that this is different from using AUX-REQUEST-VALUE to set the data to NIL"))
+
+(defgeneric clawserver-header-out (clawserver name)
+ (:documentation "Returns the outgoing http header named by the keyword name if there is one, otherwise NIL \(name parameter must be a symbol).
+Note that the headers Set-Cookie, Content-Length, and Content-Type cannot be queried by HEADER-OUT.
+See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT"))
+
+(defgeneric (setf clawserver-header-out) (value clawserver name)
+ (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol).
+If no header named name exists it is created.
+Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT.
+Also, there are a couple of \"technical\" headers like Connection or Transfer-Encoding that you're not supposed to set yourself.
+See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT"))
+
+(defgeneric clawserver-headers-out (clawserver)
+ (:documentation "Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type).
+The car of each element of this list is the headers's name while the cdr is its value.
+This alist should not be manipulated directly, use SETF of CLAWSERVER-HEADER-OUT instead"))
+
+(defgeneric clawserver-cookie-out (clawserver name)
+ (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CLAWSERVER-COOKIES-OUT and the CLAW-COOKIE class definition."))
+
+(defgeneric (setf clawserver-cookie-out) (cookie-instance clawserver name)
+ (:documentation "Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply.
+If a cookie with the same name \(case-sensitive) already exists, it is replaced.
+ The default for value is the empty string."))
+
+(defgeneric clawserver-cookies-out (clawserver)
+ (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name).
+See also CLAWSERVER-COOKIES-OUT and the CLAW-COOKIE class definition."))
+
+(defgeneric clawserver-return-code (clawserver)
+ (:documentation "CLAWSERVER-RETURN-CODE returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)"))
+
+(defgeneric (setf clawserver-return-code) (value clawserver)
+ (:documentation "Setf CLAWSERVER-RETURN-CODE sets the http return code of the reply."))
+
+(defgeneric clawserver-content-type (clawserver)
+ (:documentation "CLAWSERVER-CONTENT-TYPE returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."))
+
+(defgeneric (setf clawserver-content-type) (value clawserver)
+ (:documentation "SETF CLAWSERVER-CONTENT-TYPE sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")."))
+
+(defgeneric clawserver-content-length (clawserver)
+ (:documentation "Returns the outgoing Content-Length http header"))
+
+(defgeneric (setf clawserver-content-length) (value clawserver)
+ (:documentation "Sets the outgoing Content-Length http header"))
+
+(defgeneric clawserver-reply-external-format-encoding (clawserver)
+ (:documentation "CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING returns the symbol of the reply charset encoding \(Such as UTF-8)."))
+
+(defgeneric (setf clawserver-reply-external-format-encoding) (value clawserver)
+ (:documentation "SETF CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING sets the symbol of the reply charset encoding \(Such as UTF-8)."))
+
+(defgeneric clawserver-writer (clawserver)
+ (:documentation "Returns the output stream writer to generate replies. It's default to *standard-output*"))
+
+(defgeneric clawserver-redirect (clawserver target &key host port protocol add-session-id code)
+ (:documentation "Sends back appropriate headers to redirect the client to target \(a string).
+If target is a full URL starting with a scheme, host, port, and protocol are ignored.
+Otherwise, target should denote the path part of a URL, protocol must be one of the keywords :HTTP or :HTTPS, and the URL to redirect to will be constructed from host, port, protocol, and target.
+If code is a 3xx redirection code, it will be sent as status code.
+In case of NIL, a 302 status code will be sent to the client. If host is not provided, the current host \(see CLAWSERVER-HOST) will be used.
+If protocol is the keyword :HTTPS, the client will be redirected to a https URL, if it's :HTTP it'll be sent to a http URL. If both host and protocol aren't provided, then the value of protocol will match the current request."))
+;;------------------------------------------------------------------------------------------
+
+
+(defgeneric clawserver-dispatch-request (clawserver)
+ (:documentation "Dispatches http requests through registered dispatchers"))
+
+(defgeneric clawserver-dispatch-method (clawserver)
+ (:documentation "Uses CLAWSERVER-DISPATCH-REQUEST to perform dispatching"))
+
+(defgeneric clawserver-start (clawserver)
+ (:documentation "Starts the server"))
+
+(defgeneric clawserver-stop (clawserver)
+ (:documentation "Stops the server"))
+
+(defgeneric (setf clawserver-port) (port clawserver)
+ (:documentation "Sets the claw server http port. When server is started an error will be signaled."))
+
+(defgeneric (setf clawserver-sslport) (sslport clawserver)
+ (:documentation "Sets the claw server https port. When server is started an error will be signaled."))
+
+(defgeneric clawserver-address (clawserver)
+ (:documentation "Binds the claw server to a specific address. When server is started an error will be signaled."))
+
+;;-----------------------------------------------------------------------------------------------
+(defgeneric (setf clawserver-read-timeout) (read-timeout clawserver)
+ (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled."))
+
+(defgeneric (setf clawserver-write-timeout) (write-timeout clawserver)
+ (:documentation "Sets the write timeout in seconds. When server is started an error will be signaled."))
+
+(defgeneric clawserver-add-service (clawserver service)
+ (:documentation "Registers a service for the given CLAWSERVER object with the given SERVICE name.
+A service may be added if the CLAWSERVER object is not running."))
+
+;;------------------------------------------------------------
+
+(defgeneric clawserver-register-configuration(clawserver realm configuration)
+ (:documentation "Registers a configuration object for the given realm into the server. The configuration
+will perform the authentication logic."))
+
+(defclass clawserver ()
+ ((base-path :initarg :base-path
+ :accessor clawserver-base-path
+ :documentation "This slot is used to keep all server resources under a common URL")
+ (proxy-http-port :initarg :proxy-http-port
+ :accessor clawserver-proxy-http-port
+ :documentation "The port eventually used to proxify http requests")
+ (proxy-https-port :initarg :proxy-https-port
+ :accessor clawserver-proxy-https-port
+ :documentation "The port eventually used to proxify https requests")
+ (reverse-proxy-path :initarg :reverse-proxy-path
+ :accessor clawserver-reverse-proxy-path
+ :documentation "When request is sent via proxy, use this value to build absolute paths")
+ (connector :initarg :connector
+ :accessor clawserver-connector
+ :documentation "Reads or sets the server connector that dispatches requests and processes replies from the remote host.")
+ (log-manager :initarg :log-manager
+ :accessor clawserver-log-manager
+ :documentation "Required log meanager used to log application messages when no lisplet one is provided")
+ (session-manager :initarg :session-manager
+ :accessor clawserver-session-manager
+ :documentation "Accessor for the session manager. See the definition of the SESSION-MANAGER class.")
+ (services :initarg :services
+ :accessor clawserver-services
+ :documentation "A hash map of services handled by the current server")
+ (login-config :initform (make-hash-table :test 'equal)
+ :accessor clawserver-login-config
+ :documentation "An hash table holding a pair of realm,
+expressed as string, and a function. The function should take two arguments (login and password), and return a principal instance if the login call
+succeeds.")
+ (lisplets :initform nil
+ :accessor clawserver-lisplets
+ :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is the lisplet"))
+ (:default-initargs :base-path ""
+ :proxy-http-port *apache-http-port*
+ :proxy-https-port *apache-https-port*
+ :reverse-proxy-path nil
+ :services (make-hash-table))
+ (:documentation "CLAWSERVER is built around huncentoot and has the
+instructions for lisplet dispatching, so use this class to start and stop
+3hunchentoot server."))
+
+;;;-------------------------- WRITERS ----------------------------------------
+
+(defmethod clawserver-add-service ((server clawserver) (service claw-service))
+ (setf (gethash (claw-service-name service) (clawserver-services server)) service))
+
+
+;;;-------------------------- METHODS ----------------------------------------
+
+(defmethod clawserver-register-configuration ((clawserver clawserver) realm (configuration configuration))
+ (setf (gethash realm (clawserver-login-config clawserver)) configuration))
+
+(defmethod clawserver-dispatch-request ((clawserver clawserver))
+ (let* ((*clawserver* clawserver)
+ (*session-manager* (clawserver-session-manager clawserver))
+ (connector (clawserver-connector clawserver))
+ (base-path (clawserver-base-path clawserver))
+ (lisplets (clawserver-lisplets clawserver))
+ (script-name (connector-script-name connector))
+ (*server-path* (or (when (claw-proxified-p)
+ (clawserver-reverse-proxy-path clawserver))
+ (clawserver-base-path clawserver)))
+ (rel-script-name)
+ (rel-script-name-libs)
+ (http-result nil))
+ (handler-case
+ (progn
+ (unwind-protect
+ (catch 'handler-done
+ (progn
+ (setf (claw-return-code) +http-not-found+)
+ (if (starts-with-subseq base-path script-name)
+ (progn
+ (setf rel-script-name (subseq script-name (length base-path))
+ rel-script-name-libs (subseq script-name (length base-path)))
+ (setf http-result (or
+ (loop for dispatcher in *claw-libraries-resources*
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (when (starts-with-subseq url rel-script-name-libs)
+ (setf (claw-return-code) +http-ok+)
+ (funcall action)))
+ (loop for lisplet-cons in lisplets
+ for url = (car lisplet-cons)
+ for lisplet = (cdr lisplet-cons)
+ do (when (starts-with-subseq url rel-script-name)
+ (setf (claw-return-code) +http-ok+)
+ (return (funcall #'lisplet-dispatch-method lisplet)))))))))))
+ (or http-result
+ (and (>= (claw-return-code) 400)
+ (or
+ (let ((error-handler (and *claw-current-lisplet*
+ (gethash (or
+ (let ((return-code (claw-return-code)))
+ (if (= return-code +http-ok+)
+ nil
+ return-code))
+ +http-not-found+)
+ (lisplet-error-handlers *claw-current-lisplet*)))))
+ (when error-handler
+ (funcall error-handler)))
+ (with-output-to-string (*standard-output*)
+ (error-renderer clawserver :error-code (or
+ (let ((return-code (claw-return-code)))
+ (if (= return-code +http-ok+)
+ nil
+ return-code))
+ +http-not-found+)))))
+ ))
+ (error (cond)
+ (logger-log (clawserver-log-manager clawserver) :error "~a" cond)
+ (with-output-to-string (*standard-output*) (error-renderer clawserver :error-code +http-internal-server-error+))))))
+
+
+(defmethod clawserver-dispatch-method ((clawserver clawserver))
+ #'(lambda () (clawserver-dispatch-request clawserver)))
+
+(defmethod clawserver-start ((clawserver clawserver))
+ (let ((*clawserver* clawserver)
+ (log-manager (clawserver-log-manager clawserver))
+ (connector (clawserver-connector clawserver))
+ (sm (clawserver-session-manager clawserver))
+ (lisplets (clawserver-lisplets clawserver)))
+ (unless (claw-service-running-p log-manager)
+ (claw-service-start log-manager))
+ (unless (claw-service-running-p connector)
+ (claw-service-start connector))
+ (claw-service-start sm)
+ (when lisplets
+ (loop for lisplet-cons in lisplets
+ for url = (car lisplet-cons)
+ for lisplet = (cdr lisplet-cons)
+ do (claw-service-start lisplet)))))
+
+(defmethod clawserver-stop ((clawserver clawserver))
+ (let ((*clawserver* clawserver)
+ (log-manager (clawserver-log-manager clawserver))
+ (connector (clawserver-connector clawserver))
+ (sm (clawserver-session-manager clawserver))
+ (lisplets (clawserver-lisplets clawserver)))
+ (when lisplets
+ (loop for lisplet-cons in lisplets
+ for url = (car lisplet-cons)
+ for lisplet = (cdr lisplet-cons)
+ do (claw-service-start lisplet)))
+ (when (claw-service-running-p connector)
+ (claw-service-stop connector))
+ (when (claw-service-running-p log-manager)
+ (claw-service-stop log-manager))
+ (claw-service-stop sm)))
+
+
+
+;;-------------------------------------------------------------------------------------------------------
+
+(defmethod clawserver-host ((clawserver clawserver))
+ (connector-host (clawserver-connector clawserver)))
+
+(defmethod clawserver-request-method ((clawserver clawserver))
+ (connector-request-method (clawserver-connector clawserver)))
+
+(defmethod clawserver-request-uri ((clawserver clawserver))
+ (connector-request-uri (clawserver-connector clawserver)))
+
+(defmethod clawserver-query-string ((clawserver clawserver))
+ (connector-query-string (clawserver-connector clawserver)))
+
+(defmethod clawserver-get-parameter ((clawserver clawserver) name)
+ (connector-get-parameter (clawserver-connector clawserver) name))
+
+(defmethod clawserver-get-parameters ((clawserver clawserver))
+ (connector-get-parameters (clawserver-connector clawserver)))
+
+(defmethod clawserver-post-parameter ((clawserver clawserver) name)
+ (connector-post-parameter (clawserver-connector clawserver) name))
+
+(defmethod clawserver-post-parameters ((clawserver clawserver))
+ (connector-post-parameters (clawserver-connector clawserver)))
+
+(defmethod clawserver-parameter ((clawserver clawserver) name)
+ (connector-parameter (clawserver-connector clawserver) name))
+
+(defmethod clawserver-header-in ((clawserver clawserver) name)
+ (connector-header-in (clawserver-connector clawserver) name))
+
+(defmethod clawserver-headers-in ((clawserver clawserver))
+ (connector-headers-in (clawserver-connector clawserver)))
+
+(defmethod clawserver-authorization ((clawserver clawserver))
+ (connector-authorization (clawserver-connector clawserver)))
+
+(defmethod clawserver-remote-addr ((clawserver clawserver))
+ (connector-remote-addr (clawserver-connector clawserver)))
+
+(defmethod clawserver-remote-port ((clawserver clawserver))
+ (connector-remote-port (clawserver-connector clawserver)))
+
+(defmethod clawserver-real-remote-addr ((clawserver clawserver))
+ (connector-real-remote-addr (clawserver-connector clawserver)))
+
+(defmethod clawserver-server-addr ((clawserver clawserver))
+ (connector-server-addr (clawserver-connector clawserver)))
+
+(defmethod clawserver-server-port ((clawserver clawserver))
+ (connector-server-port (clawserver-connector clawserver)))
+
+(defmethod clawserver-server-protocol ((clawserver clawserver))
+ (connector-server-protocol (clawserver-connector clawserver)))
+
+(defmethod clawserver-user-agent ((clawserver clawserver))
+ (connector-user-agent (clawserver-connector clawserver)))
+
+(defmethod clawserver-referer ((clawserver clawserver))
+ (connector-referer (clawserver-connector clawserver)))
+
+(defmethod clawserver-cookie-in ((clawserver clawserver) name)
+ (connector-cookie-in (clawserver-connector clawserver) name))
+
+(defmethod clawserver-cookies-in ((clawserver clawserver))
+ (connector-cookies-in (clawserver-connector clawserver)))
+
+(defmethod clawserver-aux-request-value ((clawserver clawserver) symbol)
+ (connector-aux-request-value (clawserver-connector clawserver) symbol))
+
+(defmethod (setf clawserver-aux-request-value) (value (clawserver clawserver) symbol)
+ (setf (connector-aux-request-value (clawserver-connector clawserver) symbol) value))
+
+(defmethod clawserver-delete-aux-request-value ((clawserver clawserver) symbol)
+ (connector-delete-aux-request-value (clawserver-connector clawserver) symbol))
+
+(defmethod clawserver-header-out ((clawserver clawserver) name)
+ (connector-header-out (clawserver-connector clawserver) name))
+
+(defmethod (setf clawserver-header-out) (value (clawserver clawserver) name)
+ (setf (connector-header-out (clawserver-connector clawserver) name) value))
+
+(defmethod clawserver-headers-out ((clawserver clawserver))
+ (connector-headers-out (clawserver-connector clawserver)))
+
+(defmethod clawserver-cookie-out ((clawserver clawserver) name)
+ (connector-cookie-out (clawserver-connector clawserver) name))
+
+(defmethod (setf clawserver-cookie-out) (cookie-instance (clawserver clawserver) name)
+ (setf (connector-cookie-out (clawserver-connector clawserver) name) cookie-instance))
+
+(defmethod clawserver-cookies-out ((clawserver clawserver))
+ (connector-cookies-out (clawserver-connector clawserver)))
+
+(defmethod clawserver-return-code ((clawserver clawserver))
+ (connector-return-code (clawserver-connector clawserver)))
+
+(defmethod (setf clawserver-return-code) (value (clawserver clawserver))
+ (setf (connector-return-code (clawserver-connector clawserver)) value))
+
+(defmethod clawserver-content-type ((clawserver clawserver))
+ (connector-content-type (clawserver-connector clawserver)))
+
+(defmethod (setf clawserver-content-type) (value (clawserver clawserver))
+ (setf (connector-content-type (clawserver-connector clawserver)) value))
+
+(defmethod clawserver-content-length ((clawserver clawserver))
+ (connector-content-length (clawserver-connector clawserver)))
+
+(defmethod (setf clawserver-content-length) (value (clawserver clawserver))
+ (setf (connector-content-length (clawserver-connector clawserver)) value))
+
+(defmethod clawserver-reply-external-format-encoding ((clawserver clawserver))
+ (connector-reply-external-format-encoding (clawserver-connector clawserver)))
+
+(defmethod (setf clawserver-reply-external-format-encoding) (value (clawserver clawserver))
+ (setf (connector-reply-external-format-encoding (clawserver-connector clawserver)) value))
+
+(defmethod clawserver-writer ((clawserver clawserver))
+ (connector-writer (clawserver-connector clawserver)))
+
+(defmethod clawserver-redirect (clawserver target &key host port protocol add-session-id code)
+ (connector-redirect (clawserver-connector clawserver) target :host host :port port :protocol protocol :add-session-id add-session-id :code code))
+
+(defmethod clawserver-script-name ((clawserver clawserver))
+ (connector-script-name (clawserver-connector clawserver)))
+
+(defmethod clawserver-address ((clawserver clawserver))
+ (connector-address (clawserver-connector clawserver)))
+
+(defmethod error-renderer ((clawserver clawserver) &key (error-code 404))
+ (let ((request-uri (format nil "~a/~a" *server-path* (subseq (claw-script-name) (1+ (length (clawserver-base-path clawserver))))))
+ (connector (clawserver-connector clawserver))
+ (style "body {
+ font-family: arial, elvetica;
+ font-size: 7pt;
+}
+span.blue {
+ padding: 0 3px;
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ margin-right: .25em;
+}
+p.h1, p.h2 {
+ padding: 0 3px;
+ background-color: #525D76;
+ color: white;
+ font-weight: bolder;
+ font-size: 2em;
+ margin: 0;
+ margin-bottom: .5em;
+}
+p.h2 {font-size: 1.5em;}"))
+ (setf (connector-return-code connector) error-code)
+ (format t "<html>
+<head>
+ <title>Error ~a</title>
+ <style>~a</style>
+</head>
+<body>
+ <p>
+ <p class='h1'>
+ HTTP Status ~a - ~a
+ </p>
+ <hr noshade='noshade'>
+ <p>
+ <span class='blue'>type</span>
+ Status report
+ </p>
+ <p>
+ <span class='blue'>url</span>
+ ~a
+ </p>
+ <p>
+ <span class='blue'>description</span>
+ ~a
+ </p>
+ <hr noshade='noshade'>
+ <p class='h2'>
+ CLAW server
+ </p>
+ </p>
+</body>
+</html>"
+ error-code ;title
+ style ;tyle
+ error-code request-uri
+ request-uri
+ (gethash error-code *http-reason-phrase-map*))))
\ No newline at end of file
Added: trunk/main/claw-as/src/service.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/service.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,53 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/service.lisp $
+
+;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; * Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+
+;;; * Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials
+;;; provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :claw-as)
+
+(defgeneric claw-service-start (claw-service)
+ (:documentation "Starts the service"))
+
+(defgeneric claw-service-stop (claw-service)
+ (:documentation "Stop the service"))
+
+(defclass claw-service ()
+ ((running-p :initform nil
+ :accessor claw-service-running-p
+ :documentation "Returns if the server is running or not.")
+ (name :initarg :name
+ :type symbol
+ :reader claw-service-name
+ :documentation "Mandatory and unique service name that will be used inside the CLAWSERVER object."))
+ (:documentation "Generic claw service, must implement claw-service-start and claw-service-stop.
+A service injected into a CLAWSERVER oject via CLAWSERVER-ADD-SERVICE method is automatically started or stopped when the CLAWSERVER object is started or stopped"))
+
+(defmethod claw-service-start ((claw-service claw-service))
+ (setf (claw-service-running-p claw-service) t))
+
+(defmethod claw-service-stop ((claw-service claw-service))
+ (setf (claw-service-running-p claw-service) nil))
Added: trunk/main/claw-as/src/session-manager.lisp
==============================================================================
--- (empty file)
+++ trunk/main/claw-as/src/session-manager.lisp Wed Nov 12 07:05:09 2008
@@ -0,0 +1,382 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: src/session-manager.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-as)
+
+
+(defgeneric session-manager-start-session (session-manager &key path max-time domain)
+ (:documentation "Creates a new session if none exists"))
+
+(defgeneric session-manager-session-value (session-manager symbol)
+ (:documentation "Returns the value bound to the given session symbol.
+It returns nil if no symbol is defined for the current session."))
+
+(defgeneric (setf session-manager-session-value) (value session-manager symbol)
+ (:documentation "Sets the session symbol with the given value."))
+
+(defgeneric session-manager-delete-session-value (session-manager symbol)
+ (:documentation "Completely removes any data associated with the symbol symbol from the session.
+Note that this is different from using SESSION-VALUE to set the data to NIL"))
+
+(defgeneric session-manager-remove-session (session-manager &optional session) (:documentation "Removes the user session."))
+
+(defgeneric session-manager-reset-sessions (session-manager)
+ (:documentation "Invalidates and destroy all sessions"))
+
+(defgeneric session-manager-session-cookie-value (session-manager)
+ (:documentation "Returns a unique string that's associated with the user session"))
+
+(defgeneric session-manager-session-max-time (session-manager)
+ (:documentation "This gets or sets the maximum time (in seconds) the session should be valid before it's invalidated.
+If a request associated with this session comes in and the last request for the same session was more than seconds seconds ago than the session is deleted and a new one is started for this client"))
+
+(defgeneric session-manager-session-remote-addr (session-manager)
+ (:documentation "Returns the 'real' remote address (see CONNECTOR-REAL-REMOTE-ADDR) of the client for which the session was initiated."))
+
+(defgeneric session-manager-session-user-agent (session-manager)
+ (:documentation "Returns the 'User-Agent' http header (see USER-AGENT) of the client for which the session was initiated."))
+
+(defgeneric session-manager-session-gc (session-manager)
+ (:documentation "Deletes sessions which are too old - see SESSION-MANAGER-SESSION-TOO-OLD-P. Usually, you don't call this function directly"))
+
+(defgeneric session-manager-session-too-old-p (session-manager)
+ (:documentation "Returns a true value if the session is too old and would be deleted during the next session GC."))
+
+(defgeneric session-manager-start (session-manager)
+ (:documentation "Starts the session manager."))
+
+(defgeneric session-manager-stop (session-manager)
+ (:documentation "Stops the session manager."))
+
+(let ((session-id-counter 0))
+ (defun get-next-session-id ()
+ "Returns the next sequential session id."
+ (incf session-id-counter)))
+
+;;-------------------------------------------------------------------------
+(defvar *session-default-max-time* (* 30 60)
+ "The default time \(in seconds) after which this
+session expires if it's not used.")
+
+(defclass session ()
+ ((session-id :initform (get-next-session-id)
+ :reader session-id
+ :type integer
+ :documentation "The unique ID \(an INTEGER) of the session.")
+ (realm :initarg :realm
+ :accessor session-realm
+ :documentation "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")
+ (session-string :accessor 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 (connector-user-agent (clawserver-connector *clawserver*))
+ :reader session-user-agent
+ :documentation "The incoming 'User-Agent' header that
+was sent when this session was created.")
+ (remote-addr :initform (connector-remote-addr (clawserver-connector *clawserver*));(connector-real-remote-addr (clawserver-connector *clawserver*))
+ :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 (make-hash-table)
+ :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-default-max-time*
+ :accessor session-max-time
+ :type fixnum
+ :documentation "The time \(in seconds) after which this
+session expires if it's not used."))
+ (:default-initargs :realm *claw-current-realm*)
+ (: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."))
+
+;;-------------------------------------------------------------------------
+(defvar *session-manager* nil
+ "The session manager used during the request cycle.")
+
+(defclass session-manager (claw-service)
+ ((max-time :initarg :max-time
+ :accessor session-manager-max-time
+ :type fixnum
+ :documentation "The time \(in seconds) after which this session expires if it's not used."))
+ (:default-initargs :name 'session-manager :max-time 1800)
+ (:documentation "SESSION-MANAGER is an interface, so you cannot directly use it.
+A SESSION-MANAGER subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides.
+To properly work a CLAWSERVER instance must be provided with a SESSION-MANAGER implementation.
+A SESSION-MANAGER implementation to properly work, must implement all the CONNECTOR- methods.
+As the name suggests this is a server that handles user sessions."))
+
+
+(defgeneric default-session-manager-session-verify (session-manager)
+ (:documentation "Tries to get a session identifier from the cookies \(oralternatively from the GET parameters) sent by the client.
+This identifier is then checked for validity against the REQUEST.
+On success the corresponding session object \(if not too old) is returned \(and updated). Otherwise NIL is returned."))
+
+;;-------------------------------------------------------------------------
+(defgeneric default-session-manager-session-too-old-p (default-session-manager session)
+ (:documentation "Returns true if the SESSION has not been active in the last \(SESSION-MANAGER-MAX-TIME SESSION-MANAGER) seconds."))
+
+(defgeneric default-session-manager-encode-session-string (default-session-manager id user-agent remote-addr start realm)
+ (:documentation "Create a uniquely encoded session string based on the values ID, USER-AGENT, REMOTE-ADDR, START and REALM"))
+
+(defgeneric default-session-manager-current-session (default-session-manager)
+ (:documentation "Returns the session bouded to the current request"))
+
+(defclass default-session-manager (session-manager)
+ ((gc-timeout :initarg :gc-timeout
+ :accessor default-session-manager-gc-timeout
+ :documentation "The period the service waits before calling the session garbage collector")
+ (sessions :initform (make-hash-table)
+ :accessor default-session-manager-sessions
+ :documentation "A hash table containing all sessions identified by their id")
+ (service-lock :accessor default-session-manager-service-lock
+ :documentation "This is a thread lock that is used when adding or removing sessions, or when calling the session garbage collector.")
+ (session-cookie-name :initarg :session-cookie-name
+ :accessor default-session-manager-session-cookie-name
+ :documentation "The name of the cookie that stores the session id.")
+ (use-user-agent-for-sessions-p :initarg :use-user-agent-for-sessions-p
+ :reader use-user-agent-for-sessions-p
+ :documentation "")
+ (use-remote-addr-for-sessions-p :initarg :use-remote-addr-for-sessions-p
+ :reader use-remote-addr-for-sessions-p
+ :documentation "")
+ (session-secret :initarg :session-secret
+ :accessor default-session-manager-random-secret
+ :documentation "A random letter used to encode sessin into a string in a random way."))
+ (:default-initargs :gc-timeout 1 :session-cookie-name "CLAWSID"
+ :use-user-agent-for-sessions-p t
+ :use-remote-addr-for-sessions-p t
+ :session-secret (format nil "~VR" 36 (random 36 (make-random-state t))))
+ (:documentation "This is the CLAW default session manager."))
+
+(defmethod initialize-instance :after ((session-manager default-session-manager) &rest keys)
+ (declare (ignore keys))
+ (setf (default-session-manager-service-lock session-manager)
+ (bt:make-lock (symbol-name 'session-manager))))
+
+(defmethod default-session-manager-current-session ((session-manager default-session-manager))
+ (or *claw-session*
+ (let* ((connector (clawserver-connector *clawserver*))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (sessions (default-session-manager-sessions session-manager))
+ (session-identifier (or (connector-cookie-in connector cookie-name)
+ (connector-get-parameter connector cookie-name))))
+ (when session-identifier
+ (destructuring-bind (id-string session-string)
+ (split ":" session-identifier :limit 2)
+ (declare (ignore session-string))
+ (let ((id (and (scan "^\\d+$" id-string)
+ (parse-integer id-string :junk-allowed t))))
+ (and id (gethash id sessions))))))))
+
+(defmethod claw-service-start :after ((session-manager default-session-manager))
+ (unless (claw-service-running-p session-manager)
+ (bt:make-thread #'(lambda ()
+ (do ((continue (claw-service-running-p session-manager) (funcall #'claw-service-running-p session-manager)))
+ ((null continue))
+ (session-manager-session-gc session-manager))))))
+
+(defun md5-hex (string)
+ "Calculates the md5 sum of the string STRING and returns it as a hex string."
+ (with-output-to-string (s)
+ (loop for code across (md5:md5sum-sequence string)
+ do (format s "~2,'0x" code))))
+
+(defmethod default-session-manager-encode-session-string ((session-manager default-session-manager) id user-agent remote-addr start realm)
+ ;; *SESSION-SECRET* is used twice due to known theoretical
+ ;; vulnerabilities of MD5 encoding
+ (let ((session-secret (default-session-manager-random-secret session-manager)))
+ (md5-hex (concatenate 'string
+ session-secret
+ (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A~@[~A~]"
+ session-secret
+ id
+ user-agent
+ remote-addr
+ start
+ realm))))))
+
+(defmethod default-session-manager-session-verify ((session-manager default-session-manager))
+ (let* ((connector (clawserver-connector *clawserver*))
+ (sessions (default-session-manager-sessions session-manager))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (session-identifier (or (connector-cookie-in connector cookie-name)
+ (connector-get-parameter connector cookie-name))))
+ (unless (and session-identifier
+ (stringp session-identifier)
+ (plusp (length session-identifier)))
+ (return-from default-session-manager-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
+ (gethash id sessions)))
+ (user-agent (connector-user-agent connector))
+ (remote-addr (connector-remote-addr connector))
+ (realm (when session (session-realm session))))
+ (unless (and session
+ session-string
+ (string= session-string
+ (session-string session))
+ (string= session-string
+ (default-session-manager-encode-session-string session-manager
+ id
+ (and (use-user-agent-for-sessions-p session-manager)
+ user-agent)
+ (and (use-remote-addr-for-sessions-p session-manager)
+ remote-addr)
+ (session-start session)
+ realm)))
+ (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 (and session-identifier *claw-current-lisplet*)
+ (let ((cookie (make-instance 'claw-cookie
+ :name cookie-name
+ :expires (get-universal-time)
+ :path (format nil "~a/" *root-path*)
+ :domain nil
+ :value "")))
+ (setf (connector-cookie-out connector cookie-name) cookie)))
+ (when session
+ (session-manager-remove-session session-manager session))
+ (setf *claw-session* nil)
+ (return-from default-session-manager-session-verify *claw-session*))
+ (incf (slot-value session 'session-counter))
+ (setf (slot-value session 'last-click) (get-universal-time)
+ *claw-session* session)))))
+
+
+(defmethod default-session-manager-session-too-old-p ((session-manager default-session-manager) (session session))
+ (< (+ (session-last-click session) (or (session-max-time session) (session-manager-max-time session-manager)))
+ (get-universal-time)))
+
+(defmethod session-manager-start-session ((session-manager default-session-manager) &key (path "/") max-time domain)
+ (let* ((connector (clawserver-connector *clawserver*))
+ (sessions (default-session-manager-sessions session-manager))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (session-identifier (or (connector-cookie-in connector cookie-name)
+ (connector-get-parameter connector cookie-name))))
+ (if (and session-identifier (gethash (parse-integer session-identifier :junk-allowed t) sessions))
+ (destructuring-bind (id-string session-string)
+ (split ":" session-identifier :limit 2)
+ (declare (ignore session-string))
+ (let* ((id (and (scan "^\\d+$" id-string)
+ (parse-integer id-string :junk-allowed t)))
+ (session (and id (gethash id sessions))))
+ (unless (and session (default-session-manager-session-too-old-p session-manager session))
+ (return-from session-manager-start-session session))))
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (let* ((session (make-instance 'session
+ :max-time (or max-time (session-manager-max-time session-manager))))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (cookie))
+ (setf (session-string session) (default-session-manager-encode-session-string session-manager
+ (session-id session)
+ (session-user-agent session)
+ (session-remote-addr session)
+ (session-start session)
+ (session-realm session))
+ cookie (make-instance 'claw-cookie
+ :name cookie-name
+ :expires nil
+ :path path
+ :domain domain
+ :value (format nil "~a:~a" (session-id session) (session-string session))))
+ (setf (connector-cookie-out connector cookie-name) cookie)
+ (setf (gethash (session-id session) (default-session-manager-sessions session-manager)) session
+ *claw-session* session))))))
+
+(defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session)
+ (let ((connector (clawserver-connector *clawserver*))
+ (cookie-name (default-session-manager-session-cookie-name session-manager))
+ (current-session (or session (default-session-manager-current-session session-manager))))
+ (when current-session
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (remhash (session-id current-session) (default-session-manager-sessions session-manager))
+ (let ((cookie (make-instance 'claw-cookie
+ :name cookie-name
+ :expires (get-universal-time)
+ :path (format nil "~a/" *root-path*)
+ :domain nil
+ :value "")))
+ (setf (connector-cookie-out connector cookie-name) cookie))))))
+
+(defmethod session-manager-session-value ((session-manager default-session-manager) symbol)
+ (let ((session (default-session-manager-current-session session-manager)))
+ (when session
+ (gethash symbol (session-data session)))))
+
+(defmethod (setf session-manager-session-value) (value (session-manager default-session-manager) symbol)
+ (let ((session (default-session-manager-current-session session-manager)))
+ (when session
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (setf (gethash symbol (session-data session)) value)))))
+
+
+(defmethod session-manager-delete-session-value ((session-manager default-session-manager) symbol)
+ (let ((session (default-session-manager-current-session session-manager)))
+ (when session
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (remhash symbol (session-data session))))))
+
+(defmethod session-manager-reset-sessions ((session-manager default-session-manager))
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (setf (default-session-manager-sessions session-manager) (make-hash-table))))
+
+(defmethod session-manager-session-gc ((session-manager default-session-manager))
+ (let ((sessions (default-session-manager-sessions session-manager)))
+ (loop for session-id being the hash-key of sessions using (hash-value session)
+ do (when (default-session-manager-session-too-old-p session-manager session)
+ (bt:with-lock-held ((default-session-manager-service-lock session-manager))
+ (remhash session-id sessions))))))
+
More information about the Claw-cvs
mailing list