1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
;;; -*- Mode:Lisp; Syntax:Common-lisp; Package:MODLISP; Base:10 -*-
;; modlisp-clisp.lisp
;; adapted from modlisp-acl.lisp
;; Original CLISP adaption by Rachel Richard <rr@u.washington.edu>
;; Changes by Nils Kassube <nika@kassube.de> on 2001-11-24:
;;
;; - replaced :lisp by :ext for CLISP's new naming convention,
;; works now with recent CLISP distributions
;; - added modlisp-server to the :export line
(in-package :user)
(provide :modlisp)
(eval-when (compile load eval)
(defpackage :modlisp
(:nicknames :lph)
(:use :cl)
(:export modlisp-server)
))
(in-package :modlisp)
;;;;;
;;;
;;; First part adapted from server.cl
;;;
;;;;;
(defvar *server-count* 0) ; used to name servers
(defun make-socket-server (&key (name (format nil "socket server ~d "
(incf *server-count*)))
port
function
wait
(format :text))
;;
;; create a server process with the given name, listening on the
;; given port, running the given function on each connection that
;; comes in, and possibly waiting for that function's completion before
;; accepting a new connection.
;;
;; name - a string naming the server process -- if nil, then this
;; function will create a name.
;; port - if nil then an internet domain port number will be chosen
;; by the operating system. If a number is given then that
;; port will be used (or an error will be signalled if it
;; is already in use). If port is a string then a unix
;; domain port will be used. (this will not work on Windows).
;; function - the function to run when a connection is made. This
;; function must take one argument which is the stream used
;; used for reading from and writing to the process that connected
;; to this socket.
;; wait - if true, then the function will be run in the server process
;; and thus the server won't accept a new connection until
;; the function finishes.
;; format - :text (the default) or :binary. This determes what kind
;; of data can sent to and read from the socket stream.
;;
;;
;;
;; The return value is the port number on which the server is
;; listening.
;;
(let ((passive-socket (ext:socket-server port) ;
))
(start-socket-server passive-socket
:function function
:wait wait)
(ext:socket-server-port passive-socket)))
(defun start-socket-server (passive-socket &key function 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 (ext:socket-accept passive-socket)))
(if wait
(progn
(unwind-protect
(funcall function connection)
(handler-case (values-list (cons t
(multiple-value-list
(close connection))))
(error (condition) (declare (ignore-if-unused condition))
nil))))
(unwind-protect
(funcall function connection)
(handler-case (values-list (cons t
(multiple-value-list
(close connection))))
(error (condition) (declare (ignore-if-unused condition))
nil)))
)))
(handler-case (values-list (cons t
(multiple-value-list
(close passive-socket))))
(error (condition) (declare (ignore-if-unused condition))
nil))))
;;;;;
;;;
;;; Second part adapted from mod-lisp.lisp
;;;
;;;;;
(defconstant +apache-port+ 3000)
(defvar *apache-socket* nil) ;the socket to apache
(defvar *close-apache-socket* nil) ;set to t if you want to close the socket to apache
(defvar *apache-nb-use-socket* 0) ;the number of requests sent in this socket
(defun modlisp-server (&optional (port +apache-port+))
(make-socket-server :name "test"
:port port
:function 'apache-listen))
(defun apache-listen (*apache-socket*)
(let ((*close-apache-socket* t))
(unwind-protect
(loop for *apache-nb-use-socket* from 0
for command = (get-apache-command)
while command
do (process-apache-command 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"))
collect (cons key (read-line *apache-socket* nil nil)) )))
(let* ((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 process-apache-command (command)
(let ((html (if (equal (cdr (assoc "url" command :test #'string=))
"/modlisp/fixed")
(debug-table command)
(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*)
(setf *close-apache-socket* nil)))
(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>CLISP + 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 2.0 + CLISP + apache + Linux</P>
</BODY></HTML>")
(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*))
|
