demo.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          demo.lisp
   6 ;;;; Purpose:       Demonstration command processor
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Dec 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;; *************************************************************************
  12
  13 (in-package #:modlisp)
  14
  15
  16 (defun demo-modlisp-command-processor (command)
  17   "Sample function to process an modlisp command"
  18   (let ((url (header-value command :url)))
  19     (cond
  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)))
  25       (t
  26        (with-ml-page (:precompute nil)
  27          (write-debug-table command))))))
  28
  29 (defun write-debug-table (command)
  30   (write-string "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">
  31 <html><head></head>
  32 <body>
  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*))
  41
  42
  43 (defun fixed-html-string ()
  44   (with-output-to-string (s)
  45     (write-string
  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)))
  51
  52 (defun write-precomputed-page ()
  53   (write-string
  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*))
  59
  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*))
  65
  66
  67
  68 ;;; A small test bench used to test and time the client/server protocol
  69 ;;; From Marc Battyani
  70
  71 (defun fetch-mod-lisp-url (server url &key (num-fetch 1) (port 20123)
  72                            close-socket)
  73   (loop with server-socket and reply
  74         repeat num-fetch
  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))
  85            (when close-socket
  86              (close server-socket)
  87              (setf server-socket nil))
  88            finally
  89            (unless close-socket (close server-socket))
  90            (return reply)))
  91
  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)))))
  99     (when content
 100       (read-sequence content socket)
 101       (push (cons "reply-content" content) header))
 102     header))