From de82da84115f8e2a6ad7add24cb73e7876c89a3b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 16 Jul 2003 16:02:21 +0000 Subject: [PATCH] r5315: *** empty log message *** --- LICENSE | 30 +++++++ classes.lisp | 85 ++++++++++++++++++ debian/changelog | 5 ++ debian/compat | 1 + debian/control | 13 +++ debian/copyright | 39 ++++++++ debian/postinst | 41 +++++++++ debian/prerm | 34 +++++++ debian/rules | 81 +++++++++++++++++ genpage.lisp | 230 +++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 59 ++++++++++++ project.lisp | 198 ++++++++++++++++++++++++++++++++++++++++ sessions.lisp | 62 +++++++++++++ uri.lisp | 208 ++++++++++++++++++++++++++++++++++++++++++ wol.asd | 36 ++++++++ 15 files changed, 1122 insertions(+) create mode 100644 LICENSE create mode 100644 classes.lisp create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100755 debian/postinst create mode 100755 debian/prerm create mode 100755 debian/rules create mode 100644 genpage.lisp create mode 100644 package.lisp create mode 100644 project.lisp create mode 100644 sessions.lisp create mode 100644 uri.lisp create mode 100644 wol.asd diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c7dbb3a --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2003 Kevin Rosenberg +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. + + * The name of the author may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS 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 COPYRIGHT +OWNER OR CONTRIBUTORS 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. diff --git a/classes.lisp b/classes.lisp new file mode 100644 index 0000000..869cc9e --- /dev/null +++ b/classes.lisp @@ -0,0 +1,85 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: classes.lisp +;;;; Purpose: Classes for Wol library +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: July 2003 +;;;; +;;;; $Id: classes.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:wol) + + +(defclass session-master () + ((lifetime :initarg lifetime :initform nil :accessor lifetime) + (cookie-name :initarg cookie-name :accessor cookie-name) + (counter :initform 0 :accessor counter) + (prefix :initform "/" :accessor prefix) + (sessions :initform nil :accessor sessions))) + + +(defclass websession () + ((key :initarg :key :accessor websession-key) + (lastref :initarg :lastref :accessor websession-lastref) + (data :initform nil :accessor websession-data) + (method :initarg :method :accessor websession-method) + (variables :initform (make-hash-table :test 'equal) + :accessor websession-variables))) + +(defclass wol-project () + ((name :initarg :name :initform "" :type string :accessor project-name) + (project-prefix :initarg :project-prefix :type string + :initform "/" :accessor project-prefix) + (map :initarg :map :initform nil :type list :accessor project-map) + (hash :initarg :hash :initform nil :accessor project-hash-map) + (index :initarg :index :initform "index" :type string + :accessor project-index) + (server :initarg :server :initform nil :accessor project-server) + (session-master :initform (make-instance 'session-master) + :accessor session-master))) + +(defclass entity () + ((project :initarg :project :accessor entity-project)) + ) + +(defclass http-request () + ((method :initarg :method :accessor request-method) + (uri :initarg :uri :accessor request-uri) + (raw-uri :initarg :raw-uri :accessor request-raw-uri) + (protocol :initarg :protocol :reader request-protocol) + (protocol-string :initarg :protocol-string :reader request-protocol-string) + (socket :initarg :socket :reader request-socket) + (ml-server :initarg :ml-server :reader request-ml-server) + (vhost :initarg :vhost :accessor request-vhost) + (posted-content :initarg :posted-content :accessor request-posted-content) + (headers :initarg :headers :accessor request-headers) + (project :initarg :project :accessor project) + (page :initarg :page :initform nil :accessor request-page) + (plist :initarg :plist :initform nil :accessor request-plist) + (next-plists :initarg :next-plists :initform nil + :accessor request-next-plists) + (uri-query :initarg :uri-query :initform nil + :accessor request-uri-query) + (query-alist :initarg :query-alist :initform nil + :accessor request-query-alist) + (session :initarg :session :initform nil + :accessor websession-from-req) + )) + +(defvar *reap-interval* 300) +(defvar *reaper-process* nil) + +(defvar *active-projects* (make-hash-table :test 'equal)) + +(defvar +asp-header+ "lsp") +(defvar +full-asp-header+ "/lsp") + +(defvar +plist-header+ "/sdata" + "string that starts an encoded plist") + +(defvar *wol-version* "0.1.0") diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..7ea53b0 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +cl-wol (0.1.0-1) unstable; urgency=low + + * Initial release + + -- Kevin M. Rosenberg Tue, 15 Jul 2003 15:55:39 -0600 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..2b53718 --- /dev/null +++ b/debian/control @@ -0,0 +1,13 @@ +Source: cl-wol +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>= 4.0.0) +Standards-Version: 3.6.0 + +Package: cl-wol +Architecture: all +Depends: common-lisp-controller (>= 3.37), cl-modlisp, cl-lml2, cl-hyperobject, cl-kmrcl, cl-base64, cl-acl-compat +Description: Common Lisp Web Object Library + wol provides a framework for web objects in Common Lisp programs. + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..7bbc29e --- /dev/null +++ b/debian/copyright @@ -0,0 +1,39 @@ +This package was debianized by Kevin M. Rosenberg +in July 2003. + +It was downloaded from http://wol.b9.com/ + +Upstream Author: Kevin Rosenberg +Debian Maintainer: Kevin M. Rosenberg + + +Copyright (c) 2003 Kevin Rosenberg +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. + + * The name of the author may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS 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 COPYRIGHT +OWNER OR CONTRIBUTORS 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. diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..86de9eb --- /dev/null +++ b/debian/postinst @@ -0,0 +1,41 @@ +#! /bin/sh +set -e + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see /usr/share/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + register-common-lisp-source wol + ;; + abort-upgrade|abort-remove|abort-deconfigure) + unregister-common-lisp-source wol + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..de2c944 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,34 @@ +#! /bin/sh + +set -e + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see /usr/share/doc/packaging-manual/ + +case "$1" in + remove|upgrade|deconfigure) + unregister-common-lisp-source wol + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..e27361c --- /dev/null +++ b/debian/rules @@ -0,0 +1,81 @@ +#!/usr/bin/make -f + +pkg := wol +debpkg := cl-wol + +DESTDIR := debian/$(debpkg) +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-wol:= $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-wol.postinst.* debian/cl-wol.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + + # Add here commands to install the package into debian/wol. + dh_installdirs $(clc-systems) $(clc-wol) $(doc-dir) + dh_install *.asd $(shell echo *.lisp) $(clc-wol) + dh_link $(clc-wol)/wol.asd $(clc-systems)/wol.asd + chmod 0644 $(DESTDIR)/$(clc-wol)/* + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs doc/index.html +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs CHANGELOG + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/genpage.lisp b/genpage.lisp new file mode 100644 index 0000000..bc5d57d --- /dev/null +++ b/genpage.lisp @@ -0,0 +1,230 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: genpage.lisp +;;;; Purpose: HTML Pages creation functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jun 2003 +;;;; +;;;; $Id: genpage.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:wol) + +(defvar *header-table* (make-hash-table :size 100 :test 'eq) + "Table of header functions indexed by site") +(defvar *banner-table* (make-hash-table :size 100 :test 'eq) + "Table of banner functions indexed by site") +(defvar *contents-table* (make-hash-table :size 100 :test 'eq) + "Table of table of content functions indexed by site") +(defvar *page-table* (make-hash-table :size 100 :test 'equal) + "Table of page functions indexed by site-pagename") +(defvar *footer-table* (make-hash-table :size 100 :test 'eq) + "Table of footer functions indexed by site") + +(defun maybe-gen-header (site plist command) + (awhen (gethash site *header-table*) (funcall it plist command))) + +(defun maybe-gen-footer (site plist command) + (awhen (gethash site *footer-table*) (funcall it plist command))) + +(defun maybe-gen-banner (site plist command) + (awhen (gethash site *banner-table*) (funcall it plist command))) + +(defun maybe-gen-contents (site plist command) + (awhen (gethash site *contents-table*) (funcall it plist command))) + +(defmacro def-stdsite-header (site &body body) + `(setf (gethash ',site *header-table*) + #'(lambda (plist command) + (declare (ignorable plist command)) + ,@body))) + +(defmacro def-stdsite-footer (site &body body) + `(setf (gethash ',site *footer-table*) + #'(lambda (plist command) + (declare (ignorable plist command)) + ,@body))) + +(defmacro def-stdsite-banner (site &body body) + `(setf (gethash ',site *banner-table*) + #'(lambda (plist command) + (declare (ignorable plist command)) + ,@body))) + +(defmacro def-stdsite-contents (site &body body) + `(setf (gethash ',site *contents-table*) + #'(lambda (plist command) + (declare (ignorable plist command)) + ,@body))) + + +(defmacro gen-std-head (title site plist command &body body) + `(html + (:head + (when ,title + (html (:title ,title))) + (maybe-gen-header ',site ,plist ,command) + ,@body))) + +(defmacro gen-std-footer (site plist command) + `(html + ((:div class "disclaimsec") + (maybe-gen-footer ',site ,plist ,command)))) + + +(defmacro gen-std-body (site plist command &body body) + `(progn + ;;(maybe-gen-banner ',site ,plist ,command) + (html + ((:div class "stdbodytable") + ((:div :style "width:160px;position:fixed;left:3;right:auto;top:0") + ((:img :src "/images/umlisp-logo.png" :alt "logo" + :style "border:0;width:160;height:55")) + (maybe-gen-contents ',site ,plist ,command)) + ((:div :style "position:absolute;left:170px;top:0") + ((:div :style + "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt") + "High Performance Common Lisp Interface to the Unified Medical Langauge System") + ,@body + (gen-std-footer ,site ,plist ,command)))))) + + +(defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss) + (html + (:head + ((:link :rel "stylesheet" :href css :type "text/css")) + (when altcss + (html + ((:link :rel "stylesheet" :type "text/css" + :href (if (eq altcss t) + "http://b9.com/umls.css" altcss))))) + (when title-str + (html (:title (lml-write-string title-str))))))) + + +(defun page-prologue (title format css altcss) + (ecase format + (:xml + (dtd-prologue format) + (lml-format "~%" + (aif css it "http://b9.com/umlsxml.css")) + (lml-write-string "") + (lml-write-char #\Newline) + (when title + (lml-format "~A" title)) + (lml-write-char #\Newline)) + (:html + (dtd-prologue format) + (lml-write-string "") + (ml-head title (aif css it "http://b9.com/main.css") altcss) + (lml-write-string "")) + ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional + :xhtml10-frameset) + (dtd-prologue format) + (lml-write-string + "") + (ml-head title (aif css it "http://b9.com/main.css") altcss) + (lml-write-string "")) + (:text + ;; nothing to do + ))) + +(defun page-epilogue (format) + (ecase format + ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional + :xhtml10-frameset) + (lml-write-string "")) + (:xml + (lml-print "")) + (:text + ;; nothing to do + ))) + + + +(defun page-keyword-format (format) + (ecase format + ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional + :xhtml10-frameset) + :html) + (:xml + :xml) + (:text + :text))) + +(defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t)) + &rest body) + (let ((fmt (gensym "FMT-"))) + `(let ((,fmt ,format)) + (with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute) + (let ((*html-stream* *modlisp-socket*)) + (prog1 + (progn + (page-prologue ,title ,format ,css ,altcss) + ,@body) + (page-epilogue ,format))))))) + + +(defmacro gen-std-page ((site plist command title &key css altcss + (precompute t) (format :xhtml)) + &body body) + `(let ((*print-circle* nil)) + (with-lml-page (,title :css ,css :altcss ,altcss :format ,format + :precompute ,precompute) + (gen-std-body ,site ,plist ,command ,@body)))) + + + + +(defmacro with-ml-link ((href &key (format :html)) &rest body) + `(case ,format + (:xml + (lml-princ "") + ,@body + (lml-princ "")) + (:ie-xml + (lml-princ "") + ,@body + (lml-princ "")) + ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional + :xhtml10-frameset) + (lml-princ "") + ,@body + (lml-princ "")))) + +(defun ml-link (page name session-id &key (format :html)) + (case format + ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional + :xhtml10-frameset) + (html + ((:div class "homelink") + "Return to " + (with-ml-link ((make-ml-url page :session-id session-id :html t)) + (lml-write-string name)) + " page."))) + ((:xml :ie-xml) + (lml-princ "Return to ") + (with-ml-link ((make-ml-url page :session-id session-id :html t) + :format format) + (lml-write-string name)) + (lml-write-string " page.")))) + +(defun ml-home-link (session-id &key (format :html)) + (ml-link "index" "home" session-id :format format)) + +(defun ml-search-link (session-id &key (format :html)) + (ml-link "search" "search" session-id :format format)) + + + + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..78a1e1d --- /dev/null +++ b/package.lisp @@ -0,0 +1,59 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for wol +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: April 2001 +;;;; +;;;; $Id: package.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + + +(in-package #:cl-user) + +(defpackage #:wol + (:use #:kmrcl #:hyperobject #:common-lisp + #:lml2 #:base64 #:modlisp) + (:export + + ;; classes.lisp + #:project-name + #:entity-project + #:websession-from-req + #:websession-data + #:websession-variable + #:websession-key + #:request-plist + #:request-posted-content + #:request-raw-uri + + ;; projects.lisp + #:wol-project + #:header-slot-value + #:request-query + #:websession-variable + + ;; sessions.lisp + + ;; uri.lisp + #:plist-to-url-string + #:url-string-to-plist + #:make-ml-url + #:home-page-url? + #:base-html-page-name + #:make-url-object + #:page + #:make-html-url + #:make-wol-url + ) + + (:shadowing-import-from #+allegro :mp #-allegro :acl-compat-mp + :with-process-lock :make-process-lock + :process-kill :process-run-function + ) + ) + diff --git a/project.lisp b/project.lisp new file mode 100644 index 0000000..ac0e5a8 --- /dev/null +++ b/project.lisp @@ -0,0 +1,198 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: project.lisp +;;;; Purpose: Project handler for wol library +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: July 2003 +;;;; +;;;; $Id: project.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:wol) + +(defun wol-project (name &key (project-prefix "/") map index + (sessions t) (session-lifetime 18000) + (reap-interval 300) (server *ml-server*)) + (unless server + (warn "Can't start project without server") + (return-from wol-project nil)) + + (multiple-value-bind (project found) (gethash name *active-projects*) + (unless found + (setq project (make-instance 'wol-project)) + (setf (gethash name *active-projects*) project)) + + (setf (project-name project) name) + (setf (project-prefix project) project-prefix) + (setf (project-map project) map) + (setf (project-index project) index) + (setf (project-server project) server) + (setf (lifetime (session-master project)) session-lifetime) + (setf (cookie-name (session-master project)) name) + + (let ((hash (make-hash-table :size (length map) :test 'equal))) + (dolist (map-item map) + (setf (gethash (first map-item) hash) (second map-item))) + (setf (project-hash-map project) hash)) + + (setf (ml::processor server) 'wol-ml-processor) + + (if sessions + (when (null (sessions (session-master project))) + (setf (sessions (session-master project)) + (make-hash-table :test 'eq))) + (when (sessions (session-master project)) + (setf (sessions (session-master project)) nil))) + + (setq *reap-interval* reap-interval) + (when (and sessions (null *reaper-process*)) + (setq *reaper-process* (start-reaper))))) + +(defun wol-ml-processor (command) + "Processes an incoming modlisp command" + (let ((req (command->request command + :ml-server *ml-server*))) + (unless (dispatch-request req) + (no-url-handler req)))) + + +(defun command->request (command &key ml-server) + "Convert a cl-modlisp command into a wol request" + (let ((req + (make-instance 'http-request + :vhost (header-value command :host) + :raw-uri (header-value command :url) + :uri (create-uri (header-value command :host) + (awhen (header-value + command :server-ip-port) + (parse-integer it)) + (header-value command :url)) + :protocol (ensure-keyword (header-value command :server-protocol)) + :protocol-string (header-value command :server-protocol) + :method (ensure-keyword (header-value command :method)) + :posted-content (header-value command :posted-content) + :headers command + :socket *modlisp-socket* + :ml-server ml-server))) + req)) + +(defun header-slot-value (req slot) + (header-value (request-headers req) slot)) + +(defun create-uri (host port page) + (format nil "http://~A:~D~A" host port page)) + +(defun is-index-request (req ent) + (string= (request-raw-uri req) + (project-prefix (entity-project ent)))) + +(defun dispatch-request (req) + (let ((ent (find-entity-for-request req))) + (when ent + (let ((proj (entity-project ent))) + (if (is-index-request req ent) + (progn + (redirect-to-location + (format nil "~A~A" + (project-prefix proj) + (project-index proj))) + t) + (progn + (request-decompile-uri req ent) + (compute-session req ent) + (dispatch-entity req ent)))) + ent))) + +(defun make-entity (&key project) + (make-instance 'entity :project project)) + +(defun find-entity-for-request (req) + (maphash (lambda (name project) + (declare (ignore name)) + (when (request-matches-prefix req (project-prefix project)) + (return-from find-entity-for-request + (make-entity :project project)))) + *active-projects*)) + +(defun request-matches-prefix (req prefix) + "Returns project if request matches project" + (string-starts-with prefix (request-raw-uri req))) + + +(defun dispatch-entity (req ent) + (let ((handler (request-find-handler req ent))) + (if handler + (handle-request handler req ent) + (no-url-handler req)))) + +(defun request-find-handler (req ent) + (nth-value 0 (gethash (request-page req) + (project-hash-map (entity-project ent))))) + +(defun action-redirect (page req ent) + (cmsg "redirect to ~A" page)) + +(defun handle-request (handler req ent) + (typecase handler + (null + nil) + ((or symbol function) + (when (and (symbolp handler) + (not (fboundp handler))) + (cmsg "handler given a symbol without a function ~S" handler) + (return-from handle-request nil)) + (let ((res (funcall handler req ent))) + (typecase res + (string + (action-redirect res req ent)) + (null + t) + (t + (cmsg "handler should return nil or a string")))) + t) + (string + (cmsg "string handler not supported: ~A" handler) + nil) + (t + (cmsg "unknown handler type: ~S" handler) + nil))) + +(defun no-url-handler (req) + (print (request-socket req)) + (with-ml-page () + (html-stream + *modlisp-socket* + (:html + (:head + (:title "404 - NotFound")) + (:body + (:h1 "Not Found") + (:p "The request for " + (:b (:write-string (request-uri req))) + " was not found on this server.") + (:hr) + (:div (:i "WOL " + (:write-string *wol-version*)))))))) + + +(defun request-query (req &key (uri t) (post t)) + (append + (when (and uri (request-uri-query req)) + (aif (request-query-alist req) + it + (setf (request-query-alist req) + (query-to-alist (request-uri-query req))))) + (when (and post (request-posted-content req)) + (query-to-alist (request-posted-content req))))) + +(defun websession-variable (ws name) + (when ws + (gethash name (websession-variables ws)))) + +(defun (setf websession-variable) (value ws name) + (when ws + (setf (gethash name (websession-variables ws)) value))) diff --git a/sessions.lisp b/sessions.lisp new file mode 100644 index 0000000..227483b --- /dev/null +++ b/sessions.lisp @@ -0,0 +1,62 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sessions.lisp +;;;; Purpose: Session handler +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: July 2003 +;;;; +;;;; $Id: sessions.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:wol) + +(defun start-reaper () + (process-run-function "wol-reaper" + (lambda () (reap-sessions) (kmrcl::process-sleep *reap-interval*)))) + +(defun reap-sessions () + (cmsg-c :debug "Reaping")) + +(defun make-new-session-id () + (random-string :length 24 :set :lower-alphanumeric)) + +(defun ensure-websession (key req ent method) + "Find or make websession for key" + (let ((sessions (sessions (session-master (entity-project ent))))) + ;; if sessions doesn't exist, then project is not session enabled + (when session + (cond + ((null key) + (make-websession req ent method)) + (t + (maphash + (lambda (k v) + (declare (ignore k)) + (when (equal key (websession-key v)) + (setf (websession-lastref v) (get-universal-time)) + (return-from ensure-websession v))) + sessions) + (make-websession req ent method)))))) + + +(defun make-websession (req ent method) + (let* ((key (random-string :length 24 :set :lower-alphanumeric)) + (sess (make-instance 'websession + :key key + :lastref (get-universal-time) + :method method)) + (hash (sessions (session-master (entity-project ent))))) + (when hash + (setf (gethash key hash) sess) + (setf (websession-from-req req) sess) + sess))) + +(defun compute-session (req ent) + (awhen (and (request-plist req) + (getf (request-plist req) :session-id)) + (setf (websession-from-req req) + (ensure-websession it req ent :uri)))) diff --git a/uri.lisp b/uri.lisp new file mode 100644 index 0000000..371f045 --- /dev/null +++ b/uri.lisp @@ -0,0 +1,208 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: uri.lisp +;;;; Purpose: URI functions for wol +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: July 2003 +;;;; +;;;; $Id: uri.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:wol) + + +(defun request-decompile-uri (req ent) + "returns (VALUE PAGE PLIST QUERY-ALIST)" + (multiple-value-bind (page plists query) + (decode-url (request-raw-uri req)) + (when page + (setf (request-page req) (base-page-name page ent))) + (when plists + (setf (request-plist req) (car plists)) + (setf (request-next-plists req) (cdr plists)) + (when (null page) + (awhen (getf (request-plist req) :page) + (setf (request-page req) it)))) + (setf (request-uri-query req) query)) + req) + + +;;; URI Functions + +(defun base-page-name (page ent) + "Return the base page name for a html url" + (let ((len-prefix (length (project-prefix (entity-project ent))))) + (assert (>= (length page) len-prefix)) + (string-strip-ending (subseq page len-prefix) + '(".html" ".lsp")))) + +(defun split-plist-url (url) + (string-delimited-string-to-list url +plist-header+)) + +(defun decode-url (url) + "Decode raw url. Returns (values `.html' list-of-plists query)" + (let* ((plists '()) + (qsplit (delimited-string-to-list url #\?)) + (query (cadr qsplit)) + (split (split-plist-url (car qsplit))) + (page-name + (when (and (plusp (length (car split))) + (not (string= +full-asp-header+ (car split))) + (not (string-starts-with +full-asp-header+ (car split)))) + (car split)))) + (dolist (elem (cdr split)) + (push (url-string-to-plist elem) plists)) + (values page-name (nreverse plists) query))) + + + +(defun make-html-url (page ent &optional query-args) + (make-url (concatenate 'string page ".html") + :base-dir (project-prefix + (entity-project ent)) + :vars query-args :format :xhtml)) + +(defvar *unspecified* (cons :unspecified nil)) + +(defun make-wol-url (page ent + &key (session-id *unspecified*) + (object-id *unspecified*) + (func *unspecified*) (key *unspecified*) + (subobjects *unspecified*) (labels *unspecified*) + (english-only *unspecified*) + (format *unspecified*) + (lang *unspecified*) (logged *unspecified*) + (next-page *unspecified*) (caller *unspecified*) + asp html) + (let ((plist (list :page page)) + (prefix (project-prefix (entity-project ent)))) + (unless (eq session-id *unspecified*) + (setq plist (append plist (list :session-id session-id)))) + (unless (eq object-id *unspecified*) + (setq plist (append plist (list :object-id object-id)))) + (unless (eq lang *unspecified*) + (setq plist (append plist (list :lang lang)))) + (unless (eq logged *unspecified*) + (setq plist (append plist (list :logged logged)))) + (unless (eq func *unspecified*) + (setq plist (append plist (list :func func)))) + (unless (eq subobjects *unspecified*) + (setq plist (append plist (list :subobjects subobjects)))) + (unless (eq key *unspecified*) + (setq plist (append plist (list :key key)))) + (unless (eq labels *unspecified*) + (setq plist (append plist (list :labels labels)))) + (unless (eq english-only *unspecified*) + (setq plist (append plist (list :english-only english-only)))) + (unless (eq next-page *unspecified*) + (setq plist (append plist (list :next-page next-page)))) + (unless (eq format *unspecified*) + (setq plist (append plist (list :format format)))) + (unless (eq caller *unspecified*) + (setq plist (append plist (list :caller caller)))) + (if (and (null asp) + (parameters-null session-id object-id lang logged func subobjects + key labels english-only next-page format caller)) + (concatenate 'string prefix page ".html") + (concatenate 'string + prefix + (if html + (concatenate 'string page ".lsp") + (concatenate 'string + +asp-header+ +plist-header+ (plist-to-url-string plist))))))) + +(defun parameters-null (&rest params) + (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params)) + + +;; Property lists + +(defun plist-to-url-string (plist &key (base64 t)) + (let ((str (plist-to-compressed-string plist))) + (if base64 + (string-to-base64-string str :uri t) + (escape-uri-field str)))) + +(defun url-string-to-plist (str &key (base64 t)) + (let ((decode (if base64 + (base64-string-to-string str :uri t) + (unescape-uri-field str)))) + (when decode + (ignore-errors (compressed-string-to-plist decode))))) + +(defun plist-to-compressed-string (plist) + "Decode an encoded plist" + (assert (evenp (length plist))) + (do* ((output '()) + (list plist (cddr list))) + ((null list) + (prin1-to-string (nreverse output))) + (push (compress-elem (car list)) output) + (push (cadr list) output))) + +(defun compress-elem (elem) + "Encode a plist elem" + (case elem + (:page :p) + (:posted :t) + (:object-id :o) + (:session-id :s) + (:lang :l) + (:logged :g) + (:caller :c) + + ;; For lookup-func1 + (:func :f) + (:format :r) + (:key :k) + (:labels :a) + (:subobjects :b) + (:english-only :e) + + (:xml :x) + (:next-page :n) + + (otherwise elem))) + +(defun compressed-string-to-plist (encoded-str) + (let ((encoded (ignore-errors (read-from-string encoded-str))) + (output '())) + (unless encoded + (cmsg "invalid encoded string") + #+ignore + (gen-invalid-encoded-str encoded-str) + nil) + (assert (evenp (length encoded))) + (do* ((elist encoded (cddr elist))) + ((null elist) (nreverse output)) + (push (decompress-elem (car elist)) output) + (push (cadr elist) output)))) + +(defun decompress-elem (elem) + (case elem + (:N :next-page) + (:T :posted) + (:O :object-id) + (:S :session-id) + (:L :lang) + (:G :logged) + (:C :caller) + + ;; For posting to lookup-func1 + (:F :func) + (:K :key) + (:B :subobjects) + (:A :labels) + (:E :english-only) + (:R :format) + + (:X :xml) + (:P :page) + + (otherwise elem))) + + diff --git a/wol.asd b/wol.asd new file mode 100644 index 0000000..15ed38f --- /dev/null +++ b/wol.asd @@ -0,0 +1,36 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: wol.asd +;;;; Purpose: ASDF system definition file for Wol package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: July 2003 +;;;; +;;;; $Id: wol.asd,v 1.1 2003/07/16 16:02:21 kevin Exp $ +;;;; +;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+(or cmu lispworks (and allegro (not common-lisp-controller))) (require :aserve) +#+allegro (require :smtp) +#+allegro (require :phtml) +#+allegro (require :pxml) +#+allegro (require :sock) +#+(and allegro unix) (require :ipc) + +(defpackage #:wol-system (:use #:cl #:asdf)) +(in-package #:wol-system) + +(defsystem wol + :depends-on (:kmrcl :modlisp :lml2 :hyperobject :base64 + #-allegro :acl-compat) + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "project" :depends-on ("classes")) + (:file "sessions" :depends-on ("classes")) + (:file "uri" :depends-on ("classes")) + )) -- 2.34.1