--- /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.
+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.
--- /dev/null
+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).
+
--- /dev/null
+;;;; -*- 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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
+<HTML><HEAD></HEAD><BODY><TABLE bgcolor=\"#c0c0c0\">
+<TR bgcolor=\"yellow\"><TH COLSPAN=2>ACL 6.2 + mod_lisp 2.0 + apache + Linux</TH></TR>
+<TR bgcolor=\"yellow\"><TH>Key</TH><TH>Value</TH></TR>" s)
+ (format s "<TR bgcolor=\"#F0F0c0\"><TD>apache-nb-use-socket</TD><TD>~a</TD></TR>" *apache-nb-use-socket*)
+ (loop for (key . value) in command do
+ (format s "<TR bgcolor=\"#F0F0c0\"><TD>~a</TD><TD>~a</TD></TR>" key value))
+ (write-string "</TABLE></BODY></HTML>" s)))
+
+(defun fixed-html ()
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
+<HTML><HEAD></HEAD><BODY><H1>mod_lisp 2.0</H1><P>This is a constant
+ html string sent by mod_lisp</P></BODY></HTML>")
--- /dev/null
+;;;; -*- 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")
+
--- /dev/null
+cl-modlisp (0.1-1) unstable; urgency=low
+
+ * First upload
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Fri, 4 Jul 2003 13:47:20 -0600
--- /dev/null
+Source: cl-modlisp
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+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.
--- /dev/null
+Debian Copyright Section
+========================
+
+Upstream Source URL: http://files.b9.com/cl-modlisp/
+Upstream Author: Kevin Rosenberg <kevin@rosenberg.net>
+Debian Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+
+
+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.
--- /dev/null
+#! /bin/sh
+set -e
+
+LISP_PKG=modlisp
+
+# 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 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
+
+
--- /dev/null
+#! /bin/sh
+set -e
+
+# package name according to lisp
+LISP_PKG=modlisp
+
+# 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 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
+
+
--- /dev/null
+#!/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
+
--- /dev/null
+;;; -*- 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))))
--- /dev/null
+;;; -*- 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))))
--- /dev/null
+;;; -*- 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))))
--- /dev/null
+;;; -*- 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))
--- /dev/null
+;;; -*- 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))
+
--- /dev/null
+;;;; -*- 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"))))
--- /dev/null
+;;;; -*- 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
+ ))
+
--- /dev/null
+;;;; -*- 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))))))))
+
projects / cl-modlisp.git / commitdiff