File: demo.lisp

package info (click to toggle)
cl-modlisp 0.6-7
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd, squeeze, stretch, wheezy
  • size: 92 kB
  • ctags: 38
  • sloc: lisp: 257; makefile: 40
file content (102 lines) | stat: -rw-r--r-- 3,604 bytes parent folder | download | duplicates (5)
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
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          demo.lisp
;;;; Purpose:       Demonstration command processor
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Dec 2002
;;;;
;;;; $Id: demo.lisp 7061 2003-09-07 06:34:45Z kevin $
;;;; *************************************************************************

(in-package #:modlisp)


(defun demo-modlisp-command-processor (command)
  "Sample function to process an modlisp command"
  (let ((url (header-value command :url)))
    (cond
      ((equal url "/fixed.lsp")
       (output-html-page (fixed-html-string)))
      ((equal url "/precompute.lsp")
       (with-ml-page (:precompute t)
	 (write-precomputed-page)))
      (t
       (with-ml-page (:precompute nil)
	 (write-debug-table command))))))

(defun write-debug-table (command)
  (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<html><head></head>
<body>
<h1>mod_lisp debug page</h1>" *modlisp-socket*)
  (write-request-counts *modlisp-socket*)
  (write-string "<table>
<thead><tr><th>Key</th><th>Value</th></tr></thead>
<tbody>" *modlisp-socket*)
  (loop for (key . value) in command do
	(format *modlisp-socket* "<tr><td>~a</td><td>~a</td></tr>" key value))
  (write-string "</tbody></table></body></html>" *modlisp-socket*))


(defun fixed-html-string ()
  (with-output-to-string (s)
    (write-string
     "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<html><head></head><body><h1>mod_lisp fixed page</h1>
<p>This is a fixed string sent by mod_lisp</p>" s)
    (write-request-counts s)
    (write-string "</body></html>" s)))

(defun write-precomputed-page ()
  (write-string
   "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
<html><head></head><body><h1>mod_lisp precomputed page</h1>
<p>This is a precomputed string sent by mod_lisp</p>" *modlisp-socket*)
  (write-request-counts *modlisp-socket*)
  (write-string "</body></html>" *modlisp-socket*))

(defun write-request-counts (s)
  (format s "<p>Number of server requests: ~D</p>"
	  *number-server-requests*)
  (format s "<p>Number of worker requests for this socket: ~D</p>"
	  *number-worker-requests*))


    
;;; A small test bench used to test and time the client/server protocol 
;;; From Marc Battyani

(defun fetch-mod-lisp-url (server url &key (num-fetch 1) (port 20123)
			   close-socket)
  (loop with server-socket and reply
	repeat num-fetch
	do (unless server-socket
	     (setf server-socket (make-active-socket server port)))
   	   (write-string "url" server-socket)
           (write-char #\NewLine server-socket)
	   (write-string url server-socket)
	   (write-char #\NewLine server-socket)
	   (write-string "end" server-socket)
	   (write-char #\NewLine server-socket)
	   (force-output server-socket)
	   (setf reply (read-reply server-socket))
	   (when close-socket
	     (close server-socket)
	     (setf server-socket nil))
	   finally
	   (unless close-socket (close server-socket))
	   (return reply)))

(defun read-reply (socket)
  (let* ((header (loop for key = (read-line socket nil nil)
		       while (and key (string-not-equal key "end"))
		       for value = (read-line socket nil nil)
		       collect (cons key value)))
	 (content-length (cdr (assoc "Content-Length" header :test #'string=)))
	 (content (when content-length (make-string (parse-integer content-length :junk-allowed t)))))
    (when content
      (read-sequence content socket)
      (push (cons "reply-content" content) header))
    header))