;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: genpage.lisp
;;;; Purpose: HTML Pages creation functions
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2003
;;;;
;;;; $Id: genpage.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
;;;;
;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(in-package #:wol)
(defvar *header-table* (make-hash-table :size 100 :test 'eq)
"Table of header functions indexed by site")
(defvar *banner-table* (make-hash-table :size 100 :test 'eq)
"Table of banner functions indexed by site")
(defvar *contents-table* (make-hash-table :size 100 :test 'eq)
"Table of table of content functions indexed by site")
(defvar *page-table* (make-hash-table :size 100 :test 'equal)
"Table of page functions indexed by site-pagename")
(defvar *footer-table* (make-hash-table :size 100 :test 'eq)
"Table of footer functions indexed by site")
(defun maybe-gen-header (site plist command)
(awhen (gethash site *header-table*) (funcall it plist command)))
(defun maybe-gen-footer (site plist command)
(awhen (gethash site *footer-table*) (funcall it plist command)))
(defun maybe-gen-banner (site plist command)
(awhen (gethash site *banner-table*) (funcall it plist command)))
(defun maybe-gen-contents (site plist command)
(awhen (gethash site *contents-table*) (funcall it plist command)))
(defmacro def-stdsite-header (site &body body)
`(setf (gethash ',site *header-table*)
#'(lambda (plist command)
(declare (ignorable plist command))
,@body)))
(defmacro def-stdsite-footer (site &body body)
`(setf (gethash ',site *footer-table*)
#'(lambda (plist command)
(declare (ignorable plist command))
,@body)))
(defmacro def-stdsite-banner (site &body body)
`(setf (gethash ',site *banner-table*)
#'(lambda (plist command)
(declare (ignorable plist command))
,@body)))
(defmacro def-stdsite-contents (site &body body)
`(setf (gethash ',site *contents-table*)
#'(lambda (plist command)
(declare (ignorable plist command))
,@body)))
(defmacro gen-std-head (title site plist command &body body)
`(html
(:head
(when ,title
(html (:title ,title)))
(maybe-gen-header ',site ,plist ,command)
,@body)))
(defmacro gen-std-footer (site plist command)
`(html
((:div class "disclaimsec")
(maybe-gen-footer ',site ,plist ,command))))
(defmacro gen-std-body (site plist command &body body)
`(progn
;;(maybe-gen-banner ',site ,plist ,command)
(html
((:div class "stdbodytable")
((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
((:img :src "/images/umlisp-logo.png" :alt "logo"
:style "border:0;width:160;height:55"))
(maybe-gen-contents ',site ,plist ,command))
((:div :style "position:absolute;left:170px;top:0")
((:div :style
"font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
"High Performance Common Lisp Interface to the Unified Medical Langauge System")
,@body
(gen-std-footer ,site ,plist ,command))))))
(defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
(html
(:head
((:link :rel "stylesheet" :href css :type "text/css"))
(when altcss
(html
((:link :rel "stylesheet" :type "text/css"
:href (if (eq altcss t)
"http://b9.com/umls.css" altcss)))))
(when title-str
(html (:title (lml-write-string title-str)))))))
(defun page-prologue (title format css altcss)
(ecase format
(:xml
(dtd-prologue format)
(lml-format "~%"
(aif css it "http://b9.com/umlsxml.css"))
(lml-write-string "")
(lml-write-char #\Newline)
(when title
(lml-format "~A" title))
(lml-write-char #\Newline))
(:html
(dtd-prologue format)
(lml-write-string "")
(ml-head title (aif css it "http://b9.com/main.css") altcss)
(lml-write-string ""))
((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
(dtd-prologue format)
(lml-write-string
"")
(ml-head title (aif css it "http://b9.com/main.css") altcss)
(lml-write-string ""))
(:text
;; nothing to do
)))
(defun page-epilogue (format)
(ecase format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
(lml-write-string ""))
(:xml
(lml-print ""))
(:text
;; nothing to do
)))
(defun page-keyword-format (format)
(ecase format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
:html)
(:xml
:xml)
(:text
:text)))
(defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
&rest body)
(let ((fmt (gensym "FMT-")))
`(let ((,fmt ,format))
(with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
(let ((*html-stream* *modlisp-socket*))
(prog1
(progn
(page-prologue ,title ,format ,css ,altcss)
,@body)
(page-epilogue ,format)))))))
(defmacro gen-std-page ((site plist command title &key css altcss
(precompute t) (format :xhtml))
&body body)
`(let ((*print-circle* nil))
(with-lml-page (,title :css ,css :altcss ,altcss :format ,format
:precompute ,precompute)
(gen-std-body ,site ,plist ,command ,@body))))
(defmacro with-ml-link ((href &key (format :html)) &rest body)
`(case ,format
(:xml
(lml-princ "")
,@body
(lml-princ ""))
(:ie-xml
(lml-princ "")
,@body
(lml-princ ""))
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
(lml-princ "")
,@body
(lml-princ ""))))
(defun ml-link (page name session-id &key (format :html))
(case format
((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
:xhtml10-frameset)
(html
((:div class "homelink")
"Return to "
(with-ml-link ((make-ml-url page :session-id session-id :html t))
(lml-write-string name))
" page.")))
((:xml :ie-xml)
(lml-princ "Return to ")
(with-ml-link ((make-ml-url page :session-id session-id :html t)
:format format)
(lml-write-string name))
(lml-write-string " page."))))
(defun ml-home-link (session-id &key (format :html))
(ml-link "index" "home" session-id :format format))
(defun ml-search-link (session-id &key (format :html))
(ml-link "search" "search" session-id :format format))