--- /dev/null
+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.
--- /dev/null
+;;;; -*- 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")
--- /dev/null
+cl-wol (0.1.0-1) unstable; urgency=low
+
+ * Initial release
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Tue, 15 Jul 2003 15:55:39 -0600
--- /dev/null
+Source: cl-wol
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+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.
+
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org>
+in July 2003.
+
+It was downloaded from http://wol.b9.com/
+
+Upstream Author: Kevin Rosenberg <kevin@rosenberg.net>
+Debian Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+
+
+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.
--- /dev/null
+#! /bin/sh
+set -e
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# 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
+
+
--- /dev/null
+#! /bin/sh
+
+set -e
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# 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
+
+
--- /dev/null
+#!/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
+
--- /dev/null
+;;;; -*- 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 "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
+ (aif css it "http://b9.com/umlsxml.css"))
+ (lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
+ (lml-write-char #\Newline)
+ (when title
+ (lml-format "<pagetitle>~A</pagetitle>" title))
+ (lml-write-char #\Newline))
+ (:html
+ (dtd-prologue format)
+ (lml-write-string "<html>")
+ (ml-head title (aif css it "http://b9.com/main.css") altcss)
+ (lml-write-string "<body>"))
+ ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
+ :xhtml10-frameset)
+ (dtd-prologue format)
+ (lml-write-string
+ "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
+ (ml-head title (aif css it "http://b9.com/main.css") altcss)
+ (lml-write-string "<body>"))
+ (:text
+ ;; nothing to do
+ )))
+
+(defun page-epilogue (format)
+ (ecase format
+ ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
+ :xhtml10-frameset)
+ (lml-write-string "</body></html>"))
+ (:xml
+ (lml-print "</pagedata>"))
+ (: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 "<xmllink xlink:type=\"simple\" xlink:href=\"")
+ (lml-princ ,href)
+ (lml-princ "\">")
+ ,@body
+ (lml-princ "</xmllink>"))
+ (:ie-xml
+ (lml-princ "<html:a href=\"")
+ (lml-princ ,href)
+ (lml-princ "\">")
+ ,@body
+ (lml-princ "</html:a>"))
+ ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
+ :xhtml10-frameset)
+ (lml-princ "<a href=\"")
+ (lml-princ ,href)
+ (lml-princ "\">")
+ ,@body
+ (lml-princ "</a>"))))
+
+(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 "<homelink>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.</homelink>"))))
+
+(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))
+
+
+
+
--- /dev/null
+;;;; -*- 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
+ )
+ )
+
--- /dev/null
+;;;; -*- 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)))
--- /dev/null
+;;;; -*- 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))))
--- /dev/null
+;;; -*- 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 `<pagename>.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)))
+
+
--- /dev/null
+;;;; -*- 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"))
+ ))
projects / wol.git / commitdiff