1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Demonstration command processor
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Dec 2002
10 ;;;; $Id: demo.lisp,v 1.4 2003/07/16 20:40:43 kevin Exp $
11 ;;;; *************************************************************************
13 (in-package #:modlisp)
16 (defun demo-modlisp-command-processor (command)
17 "Sample function to process an modlisp command"
18 (let ((url (header-value command :url)))
20 ((equal url "/fixed.lsp")
21 (output-html-page (fixed-html-string)))
22 ((equal url "/precompute.lsp")
23 (with-ml-page (:precompute t)
24 (write-precomputed-page)))
26 (with-ml-page (:precompute nil)
27 (write-debug-table command))))))
29 (defun write-debug-table (command)
30 (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
33 <h1>mod_lisp debug page</h1>" *modlisp-socket*)
34 (write-request-counts *modlisp-socket*)
35 (write-string "<table>
36 <thead><tr><th>Key</th><th>Value</th></tr></thead>
37 <tbody>" *modlisp-socket*)
38 (loop for (key . value) in command do
39 (format *modlisp-socket* "<tr><td>~a</td><td>~a</td></tr>" key value))
40 (write-string "</tbody></table></body></html>" *modlisp-socket*))
43 (defun fixed-html-string ()
44 (with-output-to-string (s)
46 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
47 <html><head></head><body><h1>mod_lisp fixed page</h1>
48 <p>This is a fixed string sent by mod_lisp</p>" s)
49 (write-request-counts s)
50 (write-string "</body></html>" s)))
52 (defun write-precomputed-page ()
54 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
55 <html><head></head><body><h1>mod_lisp precomputed page</h1>
56 <p>This is a precomputed string sent by mod_lisp</p>" *modlisp-socket*)
57 (write-request-counts *modlisp-socket*)
58 (write-string "</body></html>" *modlisp-socket*))
60 (defun write-request-counts (s)
61 (format s "<p>Number of server requests: ~D</p>"
62 *number-server-requests*)
63 (format s "<p>Number of worker requests for this socket: ~D</p>"
64 *number-worker-requests*))
68 ;;; A small test bench used to test and time the client/server protocol
69 ;;; From Marc Battyani
71 (defun fetch-mod-lisp-url (server url &key (num-fetch 1) (port 20123)
73 (loop with server-socket and reply
75 do (unless server-socket
76 (setf server-socket (make-active-socket server port)))
77 (write-string "url" server-socket)
78 (write-char #\NewLine server-socket)
79 (write-string url server-socket)
80 (write-char #\NewLine server-socket)
81 (write-string "end" server-socket)
82 (write-char #\NewLine server-socket)
83 (force-output server-socket)
84 (setf reply (read-reply server-socket))
87 (setf server-socket nil))
89 (unless close-socket (close server-socket))
92 (defun read-reply (socket)
93 (let* ((header (loop for key = (read-line socket nil nil)
94 while (and key (string-not-equal key "end"))
95 for value = (read-line socket nil nil)
96 collect (cons key value)))
97 (content-length (cdr (assoc "Content-Length" header :test #'string=)))
98 (content (when content-length (make-string (parse-integer content-length :junk-allowed t)))))
100 (read-sequence content socket)
101 (push (cons "reply-content" content) header))