From 118ee93d69e2b09d12eb317f6db3fbda113be82f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 4 Jul 2003 19:52:32 +0000 Subject: [PATCH] r5230: First upload --- LICENSE | 43 ++++++++++++++ README | 4 ++ base.lisp | 138 +++++++++++++++++++++++++++++++++++++++++++ data-structures.lisp | 39 ++++++++++++ debian/changelog | 5 ++ debian/compat | 1 + debian/control | 13 ++++ debian/copyright | 54 +++++++++++++++++ debian/postinst | 47 +++++++++++++++ debian/prerm | 38 ++++++++++++ debian/rules | 80 +++++++++++++++++++++++++ impl-acl.lisp | 62 +++++++++++++++++++ impl-clisp.lisp | 18 ++++++ impl-cmucl.lisp | 22 +++++++ impl-lispworks.lisp | 16 +++++ impl-sbcl.lisp | 44 ++++++++++++++ modlisp.asd | 37 ++++++++++++ package.lisp | 38 ++++++++++++ utils.lisp | 89 ++++++++++++++++++++++++++++ 19 files changed, 788 insertions(+) create mode 100644 LICENSE create mode 100644 README create mode 100644 base.lisp create mode 100644 data-structures.lisp create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 impl-acl.lisp create mode 100644 impl-clisp.lisp create mode 100644 impl-cmucl.lisp create mode 100644 impl-lispworks.lisp create mode 100644 impl-sbcl.lisp create mode 100644 modlisp.asd create mode 100644 package.lisp create mode 100644 utils.lisp diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..df7cb08 --- /dev/null +++ b/LICENSE @@ -0,0 +1,43 @@ +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. +This code is placed into the public domain. + +THIS SOFTWARE IS PROVIDED "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/README b/README new file mode 100644 index 0000000..724d175 --- /dev/null +++ b/README @@ -0,0 +1,4 @@ +This is a a thin-layer providing the Lisp side of the +interface to Marc Battyani's mod_lisp apache module +(http://www.fractalconcept.com). + diff --git a/base.lisp b/base.lisp new file mode 100644 index 0000000..07cc986 --- /dev/null +++ b/base.lisp @@ -0,0 +1,138 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base.lisp +;;;; Purpose: Utility functions for modlisp package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: base.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; ************************************************************************* + +(in-package #:modlisp) + + +(let ((*listener-socket* nil) + (*listener-process* nil)) + + (defun modlisp-start (&key (port +default-apache-port+) + (function 'sample-process-apache-command)) + (handler-case + (make-socket-server (next-server-name) function port :format :text + :wait nil) + (error (e) + (format t "Error ~A" e) + (decf *listener-count*) + nil) + (:no-error (proc socket) + (setq *listener-socket* socket) + (setq *listener-proc* proc) + proc))) + + (defun modlisp-stop () + (when *listener-proc* + (format t "~&; killing ~d~%" *listener-proc*) + #+sbcl (sb-unix:unix-kill *listener-proc* :sigalrm) + #+allegro (mp:process-kill *listener-proc*) + #+allegro (mp:process-allow-schedule) + ) + (setq *listener-proc* nil) + (when *listener-socket* + (ignore-errors (close *listener-socket*)) + (setq *listener-socket* nil))) + + ) + +(defun next-server-name () + (format nil "modlisp-socket-server-~d" (incf *listener-count*))) + +(defun next-worker-name () + (format nil "modlisp-worker-~d" (incf *worker-count*))) + + +(defun apache-command-issuer (*apache-socket* + &optional + (processor-fun 'demo-apache-command-processor)) + "generates commands from apache, issues commands to processor-fun" + (let ((*close-apache-socket* t)) + (unwind-protect + (loop for *apache-nb-use-socket* from 0 + for command = (get-apache-command) + while command + do (funcall processor-fun command) + (force-output *apache-socket*) + until *close-apache-socket*) + (close *apache-socket*)))) + +(defun get-apache-command () + (ignore-errors + (let* ((header (loop for key = (read-line *apache-socket* nil nil) + while (and key + (string-not-equal key "end") + (> (length key) 1)) + for value = (read-line *apache-socket* nil nil) + collect (cons key value))) + (content-length (cdr (assoc "content-length" header :test #'equal))) + (content (when content-length + (make-string + (parse-integer content-length :junk-allowed t))))) + (when content + (read-sequence content *apache-socket*) + (push (cons "posted-content" content) header)) + header))) + +(defun write-header-line (key value) + (write-string key *apache-socket*) + (write-char #\NewLine *apache-socket*) + (write-string value *apache-socket*) + (write-char #\NewLine *apache-socket*)) + +(defun header-value (command key) + (cdr (assoc key command :test #'string=))) + + +;;; Default (demo) processor + +(defun demo-apache-command-processor (command) + "Sample function to process an apache command" + (if (equal (header-value command "url") "/asp/fixed") + (fixed-request) + (debug-request command))) + +(defun fixed-request () + (let ((html (fixed-html))) + (write-header-line "Status" "200 OK") + (write-header-line "Content-Type" "text/html") + (write-header-line "Content-Length" (format nil "~d" (length html))) + (write-header-line "Keep-Socket" "1") + (write-string "end" *apache-socket*) + (write-char #\NewLine *apache-socket*) + (write-string html *apache-socket*) + (setq *close-apache-socket* nil)) ) + +(defun debug-request (command) + (let ((html (debug-table command))) + (write-header-line "Status" "200 OK") + (write-header-line "Content-Type" "text/html") + (write-header-line "Keep-Socket" "0") + (write-string "end" *apache-socket*) + (write-char #\NewLine *apache-socket*) + (write-string html *apache-socket*) + (setq *close-apache-socket* t)) ) + +(defun debug-table (command) + (with-output-to-string (s) + (write-string " + + +" s) + (format s "" *apache-nb-use-socket*) + (loop for (key . value) in command do + (format s "" key value)) + (write-string "
ACL 6.2 + mod_lisp 2.0 + apache + Linux
KeyValue
apache-nb-use-socket~a
~a~a
" s))) + +(defun fixed-html () + " +

mod_lisp 2.0

This is a constant + html string sent by mod_lisp

") diff --git a/data-structures.lisp b/data-structures.lisp new file mode 100644 index 0000000..4bab962 --- /dev/null +++ b/data-structures.lisp @@ -0,0 +1,39 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base.lisp +;;;; Purpose: Base data and functions for modlisp package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: data-structures.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; ************************************************************************* + +(in-package #:modlisp) + +(defvar *listener-count* 0 + "used to name listeners") + +(defvar *worker-count* 0 + "used to name workers") + +(defvar *listener-socket* + "Socket for the listener") + +(defvar *listener-proc* nil + "Process for the listener") + +(defconstant +default-apache-port+ 13244 + "Default port for listen") + +(defvar *apache-socket* nil + "the socket stream to apache") + +(defvar *close-apache-socket* nil + "set to T if you want to close the socket to apache after +the current command") + +(defvar *apache-nb-use-socket* 0 + "the number of requests sent in this socket") + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..bf0fef4 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +cl-modlisp (0.1-1) unstable; urgency=low + + * First upload + + -- Kevin M. Rosenberg Fri, 4 Jul 2003 13:47:20 -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..320b62d --- /dev/null +++ b/debian/control @@ -0,0 +1,13 @@ +Source: cl-modlisp +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>> 4.0.0) +Standards-Version: 3.5.10.0 + +Package: cl-modlisp +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller (>= 3.37),libapache-mod-lisp +Description: Common Lisp interface to the Apache mod-lisp module + cl-modlisp provides a Common Lisp interface to the mod-lisp Apache module. + The package has support for CMUCL, SBCL, CLISP, AllegroCL, and Lispworks. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..dcc889f --- /dev/null +++ b/debian/copyright @@ -0,0 +1,54 @@ +Debian Copyright Section +======================== + +Upstream Source URL: http://files.b9.com/cl-modlisp/ +Upstream Author: Kevin Rosenberg +Debian Maintainer: Kevin M. Rosenberg + + +Upstream Copyright Statement +============================ + +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. +This code is placed into the public domain. + +THIS SOFTWARE IS PROVIDED "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 100644 index 0000000..ac7a528 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,47 @@ +#! /bin/sh +set -e + +LISP_PKG=modlisp + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# 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) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +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 100644 index 0000000..b23cb37 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,38 @@ +#! /bin/sh +set -e + +# package name according to lisp +LISP_PKG=modlisp + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +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..bd42b37 --- /dev/null +++ b/debian/rules @@ -0,0 +1,80 @@ +#!/usr/bin/make -f + +pkg := modlisp +debpkg := cl-modlisp + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-modlisp := $(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-modlisp.postinst.* debian/cl-modlisp.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/modlisp. + dh_installdirs $(clc-systems) $(clc-modlisp) + dh_install modlisp.asd $(shell echo *.lisp) $(clc-modlisp) + dh_link $(clc-modlisp)/modlisp.asd $(clc-systems)/modlisp.asd + +# 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 README + dh_installexamples +# 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/impl-acl.lisp b/impl-acl.lisp new file mode 100644 index 0000000..47f5c14 --- /dev/null +++ b/impl-acl.lisp @@ -0,0 +1,62 @@ +;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*- + +(in-package #:modlisp) + +(eval-when (compile load eval) + (require :socket)) + +(defun make-socket-server (name function port &key wait (format :text)) + (let* ((listener (socket:make-socket + :connect :passive + :local-port port + :address-family + (if (stringp port) + :file + (if (or (null port) (integerp port)) + :internet + (error "illegal value for port: ~s" port))) + :format format)) + (proc (mp::process-run-function name + #'(lambda () + (start-socket-server listener function + :wait wait))))) + (values proc listener))) + +(defun worker-process (stream function conn count) + (unwind-protect + #+ignore + (funcall function conn) + + (excl:errorset (close conn) nil))) + +(defun start-socket-server (passive-socket function &key wait) + ;; internal function run in the server lightweight process + ;; that continually processes the connection. + ;; This code is careful to ensure that the sockets are + ;; properly closed something abnormal happens. + (unwind-protect + (loop (let ((connection (socket:accept-connection passive-socket))) + (if wait + (unwind-protect + (funcall connection function) + (excl:errorset (close connection) nil)) + (let ((f function) + (c connection) + (name (next-worker-name)) + (mp:process-run-function + name + #'(lambda () + (unwind-protect + (apache-command-issuer connection function) + #+ignore + (handler-case + (apache-command-issuer function connection) + (error (e) + #+ignore + (format t "~&Error ~A [~A]~%" e name)) + (:no-error () + #+ignore + (format t "~&~A ended" name))) + (excl:errorset (close connection) nil))) + ))))) + (ignore-errors (close passive-socket)))) diff --git a/impl-clisp.lisp b/impl-clisp.lisp new file mode 100644 index 0000000..d6ba39c --- /dev/null +++ b/impl-clisp.lisp @@ -0,0 +1,18 @@ +;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*- + +(in-package #:modlisp) + +(defun make-socket-server (name port function &key wait (format :text)) + (declare (ignore name)) + (let ((passive-socket (ext:socket-server port))) + (values (start-socket-server passive-socket function :wait wait) + passive-socket))) + +(defun start-socket-server (passive-socket function &key wait) + (unwind-protect + (loop + (let ((connection (ext:socket-accept passive-socket))) + (unwind-protect + (apache-command-issuer connection function) + (ignore-errors (close connection))))) + (ignore-errors (close passive-socket)))) diff --git a/impl-cmucl.lisp b/impl-cmucl.lisp new file mode 100644 index 0000000..fc45602 --- /dev/null +++ b/impl-cmucl.lisp @@ -0,0 +1,22 @@ +;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*- + +(in-package #:modlisp) + + +(defun make-socket-server (name function port &key wait (format :text)) + (mp:make-process + (lambda () (make-apache-listener port function)) + :name name)) + +(defun make-apache-listener (port function) + (let ((socket (ext:create-inet-listener port))) + (unwind-protect + (loop + (mp:process-wait-until-fd-usable socket :input) + (multiple-value-bind (new-fd remote-host) + (ext:accept-tcp-connection socket) + (let ((stream (sys:make-fd-stream new-fd :input t :output t))) + (mp:make-process + (lambda () (apache-command-issuer stream function)) + :name (next-worker-name))))) + (unix:unix-close socket)))) diff --git a/impl-lispworks.lisp b/impl-lispworks.lisp new file mode 100644 index 0000000..351b35f --- /dev/null +++ b/impl-lispworks.lisp @@ -0,0 +1,16 @@ +;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*- + +(in-package #:modlisp) + +(require "comm") + +(defun make-socket-server (name port function &key wait (format :text)) + (comm:start-up-server + :function (lambda (handle) + (let ((stream (make-instance 'comm:socket-stream :socket handle + :direction :io + :element-type 'base-char))) + (mp:process-run-function + (next-worker-name) '() + 'apache-command-issuer stream function))) + :service port :process-name name)) diff --git a/impl-sbcl.lisp b/impl-sbcl.lisp new file mode 100644 index 0000000..2b43d8e --- /dev/null +++ b/impl-sbcl.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode:Lisp; Syntax:Common-lisp; Package: modlisp; Base:10 -*- + +(in-package #:modlisp) + +(defun make-socket-server (name function port &key wait format) + (declare (ignore name)) + (let ((listener (listen-to-inet-port :port port :reuse 1))) + (values + (sb-thread:make-thread + (lambda () (start-socket-server listener function))) + listener))) + + +(defun start-socket-server (listener function) + (handler-case + (when (sb-sys:wait-until-fd-usable + (sb-bsd-sockets:socket-file-descriptor listener) :input) + (unwind-protect + (loop + (let* ((socket (sb-bsd-sockets:socket-accept listener)) + (stream (sb-bsd-sockets:socket-make-stream + socket + :element-type 'base-char + :input t :output t))) + (sb-thread:make-thread + #'(lambda () (apache-command-issuer stream function))))) + (sb-unix:unix-close + (sb-bsd-sockets:socket-file-descriptor listener)))) + (sb-kernel::timeout (c) + (format t "interrupted, time to die~%")))) + +(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil)) + "Create, bind and listen to an inet socket on *:PORT. +setsockopt SO_REUSEADDR if :reuse is not nil" + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (if reuse + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) + (sb-bsd-sockets:socket-bind + socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port) + (sb-bsd-sockets:socket-listen socket 15) + socket)) + diff --git a/modlisp.asd b/modlisp.asd new file mode 100644 index 0000000..7876e3c --- /dev/null +++ b/modlisp.asd @@ -0,0 +1,37 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umweb -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: modlisp.asd +;;;; Purpose: ASDF system definition file for modlisp package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: modlisp.asd,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; ************************************************************************* + +(defpackage #:modlisp-system (:use #:cl #:asdf)) +(in-package #:modlisp-system) + +#+(or allegro clisp cmu lispworks sbcl) +(defsystem modlisp + :default-component-class kboot:kmr-cl-source-file + :depends-on (:kmrcl + :base64 + #+sbcl :sb-bsd-sockets) + :components + ((:file "package") + (:file "data-structures" :depends-on ("package")) + (:file #+allegro "impl-acl" + #+clisp "impl-clisp" + #+cmu "impl-cmucl" + #+sbcl "impl-sbcl" + #+lispworks "impl-lispworks" + :depends-on ("data-structures")) + (:file "base" + :depends-on (#+allegro "impl-acl" + #+clisp "impl-clisp" + #+cmu "impl-cmucl" + #+lispworks "impl-lispworks" + #+sbcl "impl-sbcl")) + (:file "utils" :depends-on ("base")))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..931262d --- /dev/null +++ b/package.lisp @@ -0,0 +1,38 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp; -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for modlisp package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: package.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:modlisp + (:nicknames #:ml) + (:use #:cl #:kmrcl) + (:export + + ;; data-structures.lisp + #:*apache-socket* + #:*close-apache-socket* + #:*apache-nb-use-socket* + + ;; base.lisp + #:modlisp-start + #:modlisp-stop + #:header-value + #:write-header-line + + ;; utils.lisp + #:output-html-page + #:output-xml-page + #:with-ml-page + #:posted-to-alist + #:redirect-to-location + )) + diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..04376fd --- /dev/null +++ b/utils.lisp @@ -0,0 +1,89 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: utils.lisp +;;;; Purpose: Utility functions for modlisp package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id: utils.lisp,v 1.1 2003/07/04 19:52:32 kevin Exp $ +;;;; ************************************************************************* + +(in-package #:modlisp) + +(defun format-string (fmt) + (case fmt + (:html "text/html") + (:xml "text/xml") + (:text "text/plain") + (otherwise fmt))) + +(defmacro with-ml-page ((&key (format :html) (precompute t)) &body body) + (let ((fmt (gensym)) + (precomp (gensym)) + (result (gensym)) + (outstr (gensym)) + (stream (gensym))) + `(let ((,fmt ,format) + (,precomp ,precompute) + ,result ,outstr) + (write-header-line "Status" "200 OK") + (write-header-line "Content-Type" (format-string ,fmt)) + (unless ,precomp + (write-string "end" *apache-socket*) + (write-char #\NewLine *apache-socket*)) + (setq ,outstr + (with-output-to-string (,stream) + (let ((*apache-socket* (if ,precomp + ,stream + *apache-socket*))) + (setq ,result (progn ,@body))))) + (cond + (,precomp + (write-header-line "Content-Length" (write-to-string (length ,outstr))) + (write-header-line "Keep-Socket" "1") + (write-string "end" *apache-socket*) + (write-char #\NewLine *apache-socket*) + (write-string ,outstr *apache-socket*) + (setq *close-apache-socket* nil)) + (t + (finish-output *apache-socket*) + (setq *close-apache-socket* t))) + ,result))) + +(defun redirect-to-location (url) + (write-header-line "Status" "302 Redirect") + (write-header-line "Location" url) + (write-char #\NewLine *apache-socket*) + (setq *close-apache-socket* t)) + +(defun output-ml-page (format html) + (write-header-line "Status" "200 OK") + (write-header-line "Content-Type" (format-string format)) + (write-header-line "Content-Length" (format nil "~d" (length html))) + (write-header-line "Keep-Socket" "1") + (write-string "end" *apache-socket*) + (write-char #\NewLine *apache-socket*) + (write-string html *apache-socket*) + (setq *close-apache-socket* nil)) + +(defun output-html-page (str) + (output-ml-page :html str)) + +(defun output-xml-page (str) + (output-ml-page :xml str)) + +(defun posted-to-alist (posted-string) + "Converts a posted string to an assoc list of variable names and values" + (when posted-string + (let ((alist '())) + (dolist (name=val (kmrcl:delimited-string-to-list posted-string #\&) + (nreverse alist)) + (let ((name-val-list (kmrcl:delimited-string-to-list name=val #\=))) + (when (= 2 (length name-val-list)) + (destructuring-bind (name val) name-val-list + (push (cons (kmrcl:ensure-keyword name) + (decode-uri-query-string val)) + alist)))))))) + -- 2.34.1