genpage.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          genpage.lisp
   6 ;;;; Purpose:       HTML Pages creation functions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Jun 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package wol)
  16
  17 (defvar *header-table* (make-hash-table :size 100 :test 'eq)
  18   "Table of header functions indexed by site")
  19 (defvar *banner-table* (make-hash-table :size 100 :test 'eq)
  20   "Table of banner functions indexed by site")
  21 (defvar *contents-table* (make-hash-table :size 100 :test 'eq)
  22   "Table of table of content functions indexed by site")
  23 (defvar *page-table* (make-hash-table :size 100 :test 'equal)
  24   "Table of page functions indexed by site-pagename")
  25 (defvar *footer-table* (make-hash-table :size 100 :test 'eq)
  26   "Table of footer functions indexed by site")
  27
  28 (defun maybe-gen-header (site plist command)
  29   (awhen (gethash site *header-table*) (funcall it plist command)))
  30
  31 (defun maybe-gen-footer (site plist command)
  32   (awhen (gethash site *footer-table*) (funcall it plist command)))
  33
  34 (defun maybe-gen-banner (site plist command)
  35   (awhen (gethash site *banner-table*) (funcall it plist command)))
  36
  37 (defun maybe-gen-contents (site plist command)
  38   (awhen (gethash site *contents-table*) (funcall it plist command)))
  39
  40 (defmacro def-stdsite-header (site &body body)
  41   `(setf (gethash ',site *header-table*)
  42          #'(lambda (plist command)
  43              (declare (ignorable plist command))
  44              ,@body)))
  45
  46 (defmacro def-stdsite-footer (site &body body)
  47   `(setf (gethash ',site *footer-table*)
  48          #'(lambda (plist command)
  49              (declare (ignorable plist command))
  50              ,@body)))
  51
  52 (defmacro def-stdsite-banner (site &body body)
  53   `(setf (gethash ',site *banner-table*)
  54          #'(lambda (plist command)
  55              (declare (ignorable plist command))
  56              ,@body)))
  57
  58 (defmacro def-stdsite-contents (site &body body)
  59   `(setf (gethash ',site *contents-table*)
  60          #'(lambda (plist command)
  61              (declare (ignorable plist command))
  62              ,@body)))
  63
  64
  65 (defmacro gen-std-head (title site plist command &body body)
  66   `(html
  67     (:head
  68      (when ,title
  69        (html (:title ,title)))
  70      (maybe-gen-header ',site ,plist ,command)
  71      ,@body)))
  72
  73 (defmacro gen-std-footer (site plist command)
  74   `(html
  75     ((:div class "disclaimsec")
  76      (maybe-gen-footer ',site ,plist ,command))))
  77
  78
  79 (defmacro gen-std-body (site plist command &body body)
  80   `(progn
  81     ;;(maybe-gen-banner ',site ,plist ,command)
  82     (html
  83      ((:div class "stdbodytable")
  84       ((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
  85        ((:img :src "/images/umlisp-logo.png" :alt "logo"
  86               :style "border:0;width:160;height:55"))
  87        (maybe-gen-contents ',site ,plist ,command))
  88       ((:div :style "position:absolute;left:170px;top:0")
  89        ((:div :style
  90               "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
  91         "High Performance Common Lisp Interface to the Unified Medical Langauge System")
  92        ,@body
  93         (gen-std-footer ,site ,plist ,command))))))
  94
  95
  96 (defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
  97   (html
  98    (:head
  99     ((:link :rel "stylesheet" :href css :type "text/css"))
 100     (when altcss
 101       (html
 102        ((:link :rel "stylesheet" :type "text/css"
 103                :href (if (eq altcss t)
 104                          "http://b9.com/umls.css" altcss)))))
 105     (when title-str
 106       (html (:title (lml-write-string title-str)))))))
 107
 108 (defvar +std-entities+ "<!ENTITY nbsp \"&#160;\">
 109 <!ENTITY reg \"&#174;\">
 110 <!ENTITY copy \"&#169;\">")
 111
 112 (defun page-prologue (title format css altcss)
 113   (ecase format
 114     (:xml
 115      (dtd-prologue format :entities +std-entities+)
 116      (lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
 117                  (aif css it "http://b9.com/umlsxml.css"))
 118      (lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
 119      (lml-write-char #\Newline)
 120      (when title
 121        (lml-format "<pagetitle>~A</pagetitle>" title))
 122      (lml-write-char #\Newline))
 123     (:html
 124      (dtd-prologue format)
 125      (lml-write-string "<html>")
 126      (ml-head title (aif css it "http://b9.com/main.css") altcss)
 127      (lml-write-string "<body>"))
 128     ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
 129       :xhtml10-frameset)
 130      (dtd-prologue format :entities +std-entities+)
 131      (lml-write-string
 132       "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
 133      (ml-head title (aif css it "http://b9.com/main.css") altcss)
 134      (lml-write-string "<body>"))
 135     (:text
 136      ;; nothing to do
 137      )))
 138
 139 (defun page-epilogue (format)
 140   (ecase format
 141     ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
 142       :xhtml10-frameset)
 143      (lml-write-string "</body></html>"))
 144     (:xml
 145      (lml-print "</pagedata>"))
 146     (:text
 147      ;; nothing to do
 148      )))
 149
 150
 151
 152 (defun page-keyword-format (format)
 153   (ecase format
 154     ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
 155             :xhtml10-frameset)
 156      :html)
 157     (:xml
 158      :xml)
 159     (:text
 160      :text)))
 161
 162 (defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
 163                          &rest body)
 164   (let ((fmt (gensym "FMT-")))
 165     `(let ((,fmt ,format))
 166       (with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
 167         (let ((*html-stream* *modlisp-socket*))
 168           (prog1
 169               (progn
 170                 (page-prologue ,title ,format ,css ,altcss)
 171                 ,@body)
 172             (page-epilogue ,format)))))))
 173
 174
 175 (defmacro gen-std-page ((site plist command title &key css altcss
 176                               (precompute t) (format :xhtml))
 177                         &body body)
 178   `(let ((*print-circle* nil))
 179     (with-lml-page (,title :css ,css :altcss ,altcss :format ,format
 180                     :precompute ,precompute)
 181       (gen-std-body ,site ,plist ,command ,@body))))
 182
 183
 184
 185
 186 (defmacro with-ml-link ((href &key (format :html)) &rest body)
 187   `(case ,format
 188      (:xml
 189       (lml-princ "<xmllink xlink:type=\"simple\" xlink:href=\"")
 190       (lml-princ ,href)
 191       (lml-princ "\">")
 192       ,@body
 193       (lml-princ "</xmllink>"))
 194     (:ie-xml
 195       (lml-princ "<html:a href=\"")
 196       (lml-princ ,href)
 197       (lml-princ "\">")
 198      ,@body
 199      (lml-princ "</html:a>"))
 200     ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
 201             :xhtml10-frameset)
 202       (lml-princ "<a href=\"")
 203      (lml-princ ,href)
 204      (lml-princ "\">")
 205      ,@body
 206      (lml-princ "</a>"))))
 207
 208 (defun ml-link (page name session-id &key (format :html))
 209   (case format
 210     ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
 211             :xhtml10-frameset)
 212      (html
 213       ((:div class "homelink")
 214        "Return to "
 215        (with-ml-link ((make-ml-url page :session-id session-id :html t))
 216          (lml-write-string name))
 217        " page.")))
 218     ((:xml :ie-xml)
 219      (lml-princ "<homelink>Return to ")
 220      (with-ml-link ((make-ml-url page :session-id session-id :html t)
 221                     :format format)
 222        (lml-write-string name))
 223      (lml-write-string " page.</homelink>"))))
 224
 225 (defun ml-home-link (session-id &key (format :html))
 226   (ml-link "index" "home" session-id :format format))
 227
 228 (defun ml-search-link (session-id &key (format :html))
 229   (ml-link "search" "search" session-id :format format))
 230
 231
 232
 233