(in-package :cs325-user) (use-package :net.aserve) (use-package :net.html.generator) ;;; Update history: ;;; ;;; 09-23-09 Fixed APROPOS-RESULTS to treat empty package as "COMMON-LISP" [CKR] ;;; 01-15-07 Added PATHNAME-HOST and PATHNAME-DEVICE to *BASE-DIR* [CKR] ;;; 01-26-05 Added :PRESERVE to FIX-NAME [CKR] ;;; 01-25-05 Added a lot of comments [CKR] ;;; 01-23-05 Added PUBLISH-DIRECTORY, made more use of static HTML and CSS [CKR] ;;; 01-22-05 Fixed Critic page to not run #. and show error messages [CKR] ;;; 01-22-05 Fixed Apropos page to handle missing package [CKR] ;;; 02-16-04 Replaced *cs325-root* with *load-pathname* [CKR] ;;; Some AllegroServe (AServe hereafter) examples, with extended ;;; comments. These comments are not a replacement for the AServe ;;; documentation. The code is intended to exemplify recommended ;;; practice for maintainable code. Server code can be quite ;;; tricky to debug because each request is handled in a separate ;;; thread, not in the listener. You want as much of your code as ;;; possible to be testable in a listener window. ;;; Publishing URL's ;;; ---------------- ;;; In Java servlets, you map URL's to programs in a web.xml file. ;;; In AServe, you link URL's to Lisp functions in a Lisp file, ;;; like this, using calls to "publish" functions. I recommend ;;; putting all the mappings up front, to make it easy to see ;;; what URL's are defined, ;;; First, we define what AServe calls "exact" paths. If ;;; a browser asks for a URL exactly matching one of the ;;; paths below, the associated code will be called. ;;; ;;; The simplest path, "/", will match a request for ;;; http://localhost:8000/ (if 8000 is the port used). ;;; Hence, this is a good path for a page describing ;;; the server itself. (publish :path "/" :content-type "text/html" :function 'show-root-page) ;;; The remaining URL's are for specific web applications ;;; that are described later in this file. These mappings ;;; say that, for example, the URL http://localhost:8000/apropos ;;; will cause the function SHOW-APROPOS to be called. (publish :path "/apropos" :content-type "text/html" :function 'show-apropos) (publish :path "/critic" :function 'critique-code) (publish :path "/display" :function 'show-fields) ;;; We also want to make available static content, ;;; such as HTML files, images, and stylesheets. In general, ;;; the more you can put in static content, the better, because ;;; such content can be edited and tested by non-Lisp programmers ;;; using HTML editors. ;;; ;;; Although you can publish files one by one, using PUBLISH-FILE, ;;; it's simpler to make a directory with the content, and publish ;;; the entire directory. ;;; ;;; Accompanying this file should be a subdirectory called contents/. ;;; To publish that directory, we don't want to hardwire the full ;;; path, because then every one using this file would need to modify ;;; it for their installation. ;;; Instead, we construct the pathname by adding "contents/" to the ;;; name of the directory containing this file. We store the result ;;; in the global *BASE-DIR* in case you want to see what it looks ;;; like in a listener window. (defparameter *base-dir* (namestring (merge-pathnames "content/" (make-pathname :device (pathname-device *load-truename*) :host (pathname-host *load-truename*) :directory (pathname-directory *load-truename*))))) ;;; Now we tell AServe that any URL starting with ;;; http://localhost:8000/base/... should retrieve files from ;;; the directory contents/. ;;; ;;; In AServe /base/ is called a "prefix" path. If, and only if, ;;; no "exact" path matches the incoming URL, then AServe checks ;;; the prefix paths. If more than one matches, it picks the longest. ;;; ;;; I deliberately used a prefix different from the directory ;;; name to demonstrate that the two are independent. ;;; Normally, however, you'd probably use the same names. ;;; ;;; CAUTIONS: Be sure that ;;; - the prefix begins and ends with / ;;; - the destination is a directory ending with /, e.g., "webapps/" ;;; - the destination is a string, not a pathname structure (publish-directory :prefix "/base/" :destination *base-dir* :indexes '("index.html")) ;;; The :indexes keyword tells AServe to send back ;;; index.html from the destination directory if the URL ;;; doesn't specify a file, e.g., the URL is just ;;; http://localhost:8000/base/. The default value for ;;; this keyword is the list '("index.html" "index.htm). ;;; ;;; Typically, index pages are used as home pages for a web ;;; site. In our case, index.html has links to the ;;; demo applications. ;;; ;;; NOTE: portableaserve with LispWorks 4.2 Personal Edition ;;; for Windows does not send index.html on my machine. ;;; However the URL http://localhost:8000/base/index.html ;;; works fine. ;;; Defining Lisp URL handlers ;;; --------------------------- ;;; Generating a Server Root Page in Lisp ;;; ------------------------------------- ;;; ;;; As noted above, the URL http://localhost:8000/ ;;; will call the Lisp function SHOW-ROOT-PAGE. ;;; ;;; It's often useful to have a page for the server itself. ;;; Tomcat for example has a page about the Tomcat server and ;;; links to documentation that displays at the server root. ;;; ;;; Type http://localhost:8000/ into your browser. Then use ;;; your browser's "show page source" menu option to see ;;; what the browser sees. Note that there's no Lisp there, ;;; just regular HTML. ;;; All functions that handle HTTP requests take two parameters: ;;; - a request (as in Java), containing the form data and ;;; other input information, ;;; - a entity (similar to Java's response object), containing ;;; the stream to write HTML output to ;;; ;;; Such functions should start with with-http-response and ;;; with-http-body, as shown below. These macros do some basic ;;; HTTP processing, and set things up so that output from ;;; the HTML macro will be sent back to the client that requested ;;; the URL. (defvar *hit-counter* 0) (defun show-root-page (req ent) (with-http-response (req ent) (with-http-body (req ent) (make-root-page (header-slot-value req :host))))) ;;; I recommend that you put all the page-generating code in a ;;; separate function. Pass that function any form data it needs, ;;; not the request or entity. That way, you'll be able to test it in a ;;; listener window, like this: ;;; ;;; (html-stream *standard-output* (make-root-page "my-host")) ;;; ;;; This function uses the HTML macro to construct HTML text ;;; with a little bit about the server. Anything can be used ;;; to print, as long as the output goes to *HTML-STREAM*. But ;;; the HTML macro is easier to maintain in the long haul. (defun make-root-page (host) (html (:html (:head (:title "Welcome to Portable AllegroServe on " (:princ (lisp-implementation-type))) ((:link :rel "stylesheet" :type "text/css" :href "base/style.css")) ) (:body (:center ((:img :src "base/images/aservelogo.gif"))) ;;; Note the links to static content via base/ URL's. (:h1 "Welcome to Portable AllegroServe on " (:princ (lisp-implementation-type))) (:i "This server's host name is " (:princ-safe host)) #+unix (:i ", running on process " (:princ (net.aserve::getpid))) :br (:princ (incf *hit-counter*)) " hits so far in this run" ;;; Hit counters used to be popular, when being popular ;;; was popular on the web. A hit counter is a ;;; simple example of something that can only be done using ;;; some kind of dynamically generated HTML. )))) ;;; Static Form Example ;;; ------------------- ;;; ;;; Forms are the heart of web applications. We have a ;;; simple, and silly, static form in contents/fields.html, ;;; which can be viewed with the URL ;;; ;;; http://locahost:8000/base/fields.html ;;; ;;; It's meant to show some common form elements and how ;;; the data a user enters into a form can be sent to and ;;; processed by a Lisp function. ;;; ;;; The form has ;;; ;;; - a hidden input field called "email" ;;; - a text field called "name" ;;; - a pair of radio buttons name "agrees" ;;; - a checkbox named "spam" and a checkbox named "calls" ;;; - three input fields called "favorites" ;;; ;;; Radio buttons that go together always have the same name. ;;; Clicking one such button will uncheck all the others with ;;; the same name. But any input element can have the same name ;;; as another, and we do it here for demonstration purposes. ;;; ;;; Forms specify a URL to send to the server when the form is ;;; is submitted. In fields.html, the form is defined thus: ;;; ;;;
;;; ;;; so submitting the form sends the URL /display to the server, ;;; along with whatever data has been entered into the form fields. ;;; That URL has been defined above to call SHOW-FIELDS. (defun show-fields (req ent) (with-http-response (req ent) (with-http-body (req ent) (make-fields-page (request-query req))))) ;;; REQUEST-QUERY returns an alist of all form data: ;;; ;;; ((name . value) (name . value) ...). ;;; ;;; so we use a simple DOLIST to create a table row ;;; for each pair. (defun make-fields-page (alist) (html (:html (:head (:title "Form Data")) (:body ((:table :border 1) (:tr (:th "Field") (:th "Value")) (dolist (entry alist) (html (:tr (:td (:princ (car entry))) (:td (:prin1 (cdr entry))))))))))) ;;; Lisp Critic Example ;;; ---------------------- ;;; ;;; The URL http://localhost:8000/critic calls ;;; the Lisp function CRITIQUE-CODE. It reads Lisp code ;;; from a form, applies the Lisp Critiquer to that code, ;;; and creates an HTML page with the results. ;;; ;;; CRITIQUE-CODE implements a fairly common pattern in ;;; web pages that act like program interfaces: it's a form ;;; that submits to itself. That is, when the user submits ;;; the form, they get the form back, plus additional information. ;;; This makes it easy to modify what's in the form and resubmit. ;;; ;;; Programming such forms is a little tricky, because you ;;; have to handle both the first time the page is shown, ;;; when there is no form data, and subsequent times when ;;; form data has been sent, and needs to be placed in the ;;; form. ;;; ;;; This code also shows two instances of the "wrapper" design ;;; pattern. A wrapper is a small function that makes another ;;; function usable in some context by translating input and output ;;; from one format to another. Wrappers are important for ;;; keep coding small and modular. In this case, ;;; ;;; - CRITIQUE-CODE-STRING wraps around CRITIQUE-DEFINITION, ;;; converting a function that takes Lisp lists and prints, ;;; into one that takes and returns strings. ;;; ;;; - CRITIQUE-CODE wraps around CRITIQUE-CODE-STRING, adding ;;; HTML formatting to the string returned by the inner ;;; function. (defun critique-code (req ent) (with-http-response (req ent) (with-http-body (req ent) (make-critique-page (request-query-value "code" req))))) (defun make-critique-page (text) (html (:html (:head (:title "Lisp Critiquer")) (:body (:h1 "Lisp Critiquer") ((:form :action "/critic" :method "POST") ((:table :border 1) (:tr (:th "Enter Code in Text Area")) (:tr (:td ((:textarea :name "code" :rows 5 :cols 60) (unless (null text) (html (:princ text)))))) ;; We put the code text into the form's textarea ;; named "code," unless this is the first entry ;; to the form and text is NIL. This way, the user ;; sees both the code and the critique, and can ;; modify the code and re-critique it. (:tr (:th ((:input :type "submit" :value "Click to See Critiques")))) (:tr (:th "Critiques")) (:tr (:td (unless (null text) (html (:pre (:princ-safe (critique-code-string text))))))) ;; Here we call CRITIQUE-CODE-STRING to do the real work. It ;; doesn't know about HTML. It just takes a string with code and ;; returns a string with critiques. )))))) ;;; (CRITIQUE-CODE-STRING string) => value as string ;;; Reads and critiques the first expression in string, returns ;;; the output in a string. ;;; ;;; It calls CRITIQUE-DEFINITION from the lisp-critic package ;;; to do the real work. There are three important techniques ;;; used here; ;;; ;;; - capturing the output from CRITIQUE-DEFINITION into a string ;;; ;;; - catching any errors from CRITIQUE-DEFINITION into a string ;;; ;;; - preventing end-users from running malicious Lisp code ;;; on the server ;;; ;;; Capturing output: Since CRITIQUE-DEFINITION prints ;;; its results, rather than returning them, CRITIQUE-CODE-STRING ;;; uses WITH-OUTPUT-TO-STRING to redirect all output to an internal ;;; string stream. By naming this stream *STANDARD-OUTPUT* we ;;; temporarily make normal output go to that string stream. ;;; WITH-OUTPUT-TO-STRING returns the string constructed when ;;; it finishes. ;;; ;;; Catching errors: The Lisp special form HANDLER-CASE makes ;;; it very easy to catch any errors that occur while running ;;; code. All we do here is catch the error and return it as ;;; as a string to be displayed. ;;; ;;; Preventing malicious code: Since this code does not EVAL ;;; the user's code, you might think you're safe from malicious ;;; inputs. But you're not. By default, the Lisp reader will ;;; evaluate any expression preceded by #. -- i.e., ;;; (READ-FROM-STRING "#.(+ 2 3)" returns 5, not (+ 2 3). ;;; Imagine reading "#.(delete-file ...)" !! ;;; ;;; Fortunately, you can turn this off by setting *READ-EVAL* ;;; to NIL. ALWAYS do this if you do any kind of Lisp READ on user ;;; input. It's safe to call READ-CHAR, however. (defun critique-code-string (s) (let ((*read-eval* nil)) (handler-case (with-output-to-string (*standard-output*) (critique-definition (read-from-string s))) (error (condition) (format nil "~A" condition))))) ;;; Lisp Apropos Example ;;; -------------------- ;;; ;;; The URL http://localhost:8000/apropos calls ;;; the Lisp function SHOW-APROPOS. It reads two fields: ;;; symbol and package, and returns the results of ;;; doing a Lisp APROPOS-LIST call with that data. ;;; It is another example of a form that submits ;;; to itself, and has another example of a wrapper ;;; function. ;;; ;;; I adapted this code from portableaserve/aserve/example.cl, ;;; ;;; - adding a field for package ;;; - adding output to display the value of variable if bound ;;; - breaking the large code up into more manageable pieces ;;; - getting rid of non-standard IF* ;;; - dropping the my-td macro ;;; - replacing deprecated HTML with CSS styles (defun show-apropos (req ent) (with-http-response (req ent) (with-http-body (req ent) (make-apropos-page (request-query-value "symbol" req) (request-query-value "package" req))))) ;;; Note the use of strings to split the CSS style information ;;; over separate lines, and the use of subfunctions to handle ;;; generating the small form and the results table. (defun make-apropos-page (symbol-name package-name) (html (:head (:title "Allegro Apropos") :newline ((:style :type "text/css") :newline "body { background-image: url('/base/images/fresh.jpg'); }" :newline "table { cell-padding: 3px; }" :newline "td { background-color: silver; color: black; }" :newline "th { background-color: blue; color: white; }" )) (:body (apropos-form symbol-name package-name) :newline :hr (unless (null symbol-name) (apropos-results (or symbol-name "example") package-name))))) (defun apropos-form (symbol-name package-name) (html ((:form :action "/apropos" :method "get") (:p (:b "Symbol: ") ((:input :type "text" :size 20 :name "symbol" :if* symbol-name :value symbol-name)) (:b "Package (optional): ") ((:input :type "text" :size 20 :name "package" :if* package-name :value package-name)) ((:input :type "submit" :value "Search")) )))) ;;; If the package name is empty, use COMMON-LISP. ;;; ;;; Exercise for the reader: replace the package name field in the HTML with ;;; a dynamically generated drop-down menu of all available packages. (defun apropos-results (symbol-name package-name) (format t "~S ~S~%" symbol-name package-name) (let ((package (find-package (if (string= package-name "") "COMMON-LISP" package-name)))) (if (null package) (html (:b "There is no package called " (:princ-safe package-name))) (let ((symbols (apropos-list (fix-name symbol-name) package))) (html "Number of symbols found: " (:princ (length symbols)) :br :newline (unless (null symbols) (apropos-table symbols (or package (find-package :common-lisp))))))))) ;;; This would be simpler if we didn't have to worry about ;;; Allegro "modern" mode. (defun fix-name (text) (ecase (readtable-case *readtable*) (:upcase (string-upcase text)) (:downcase (string-downcase text)) (:preserve text))) (defun apropos-table (symbols *package*) (html ((:table :border 3) (:tr (:th "Symbol") (:th "Function?") (:th "Value")) (dolist (symbol symbols) (html (:tr (:td (:prin1-safe symbol)) (:td (:princ (if (fboundp symbol) "Yes" "No"))) (:td (if (boundp symbol) (html (:prin1-safe (symbol-value symbol))) (html (:em "unbound")))) ) :newline))) :newline))