web-utils-aserve.lisp

   1
   2 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   3 ;;;; *************************************************************************
   4 ;;;; FILE IDENTIFICATION
   5 ;;;;
   6 ;;;; Name:          web-utils-aserve.lisp
   7 ;;;; Purpose:       Web utilities based on aserve functions
   8 ;;;; Programmer:    Kevin M. Rosenberg
   9 ;;;; Date Started:  Apr 2000
  10 ;;;;
  11 ;;;; $Id: web-utils-aserve.lisp,v 1.7 2002/10/16 22:56:07 kevin Exp $
  12 ;;;;
  13 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;;
  15 ;;;; KMRCL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20
  21 (in-package :kmrcl)
  22 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  23
  24
  25 ;;; AllegroServe interaction functions
  26
  27 (defun cgi-var (var req)
  28   "Look CGI variable in AllegroServe association list"
  29   (cdr (assoc var (net.aserve:request-query req) :test #'equal)))
  30
  31 (defun princ-http (s)
  32   (princ s *html-stream*))
  33
  34 (defun print-http (s)
  35   (format *html-stream* "~a~%" s))
  36
  37
  38 ;;; Tag functions
  39
  40 (defmacro with-tag (tag &rest body)
  41   "Outputs to http tag and executes body"
  42   `(prog1
  43        (progn
  44          (princ-http (format nil "<~a>" ,tag))
  45          ,@body)
  46      (princ-http (format nil "</~a>" ,tag))))
  47
  48 (defmacro with-tag-attribute (tag attribute &rest body)
  49   "Outputs to http tag + attribute and executes body"
  50   `(prog1
  51        (progn
  52          (princ-http (format nil "<~a ~a>" ,tag ,attribute))
  53          ,@body)
  54      (princ-http (format nil "</~a>" ,tag))))
  55
  56 (defun princ-http-with-color (text color)
  57   (with-tag-attribute "font" (format nil "color=\"~a\"" color)
  58                       (princ-http text)))
  59
  60 (defun princ-http-with-size (text size)
  61   (with-tag-attribute "font" (format nil "size=\"~a\"" size)
  62                       (princ-http text)))
  63
  64 (defmacro with-link ((href xml linktype) &rest body)
  65   (declare (ignore linktype))
  66 ;   (format *html-stream* "Return to <cui2 xml:href=\"qstr\">Home</cui2>")
  67 ;   (format *html-stream* "Return to <go xml:link=\"simple\" show=\"replace\" href=\"qstr/\">Home</go>")
  68   `(if ,xml
  69        (progn
  70          (princ-http "<elem xlink:type=\"simple\" xlink:href=\"")
  71          (princ-http ,href)
  72          (princ-http "\">")
  73          ,@body
  74          (princ-http "</elem>"))
  75      (progn
  76        (princ-http "<a href=\"")
  77        (princ-http ,href)
  78        (princ-http "\">")
  79        ,@body
  80        (princ-http "</a>"))))
  81
  82 (defun home-link (&key (xml nil) (vars nil))
  83   (princ-http "<font size=\"-1\">Return to ")
  84   (with-link ((make-url "index.html" :vars vars) xml "homelink")
  85     (princ-http "Browser Home"))
  86   (princ-http "</font><p></p>"))
  87
  88 (defun head (title-str &key css)
  89   (unless css
  90     (setq css "http://b9.com/main.css"))
  91   (net.html.generator:html
  92    (:head
  93     (princ-http (format nil "<link rel=\"stylesheet\" href=\"~A\" type=\"text/css\"></link>" css))
  94     (:title (:princ-safe title-str)))))
  95
  96
  97
  98 ;;; Page wrappers
  99
 100 (defmacro with-page ((title &key css (format :xhtml)) &rest body)
 101   (case format
 102     (:xhtml
 103      `(prog1
 104           (progn
 105             (net.html.generator:html
 106              (print-http *standard-xhtml-header*)
 107              (print-http "<html xmlns=\"http://www.w3.org/1999/xhtml\">")
 108              (head ,title :css ,css)
 109              (print-http "<body>")
 110              (prog1
 111                  ,@body
 112                (print-http "</body></html>"))))))
 113     (:html
 114      `(prog1
 115           (progn
 116             (net.html.generator:html
 117              (print-http *standard-html-header*)
 118              (head ,title :css ,css)
 119              (print-http "<body>")
 120              (prog1
 121                  ,@body
 122                (print-http "</body></html>"))))))
 123     (:xml
 124      `(prog1
 125           (progn
 126             (net.html.generator:html
 127              (princ-http *standard-xml-header*
 128              (princ-http "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">"))
 129             (with-tag "pagetitle" (princ-http ,title))
 130             ,@body)
 131         (princ-http "</pagedata>")))))
 132
 133
 134 ;;; URL Encoding
 135
 136 (defun encode-query (query)
 137   "Escape [] from net.aserve's query-to-form-urlencoded"
 138   (substitute-string-for-char
 139    (substitute-string-for-char
 140     (substitute-string-for-char
 141      (substitute #\+ #\space query)
 142      #\[ "%5B")
 143     #\] "%5D")
 144    #\" "%22"))
 145
 146