utils.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          utils.lisp
   6 ;;;; Purpose:       Utility functions for modlisp package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Dec 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;; *************************************************************************
  12
  13 (in-package #:modlisp)
  14
  15 (defun format-string (fmt headers)
  16  `(("Content-Type" .
  17     ,(case fmt
  18       (:html "text/html")
  19       (:xml "text/xml")
  20       (:text "text/plain")
  21       (otherwise fmt)))
  22    . ,headers))
  23
  24 (defmacro write-response ((&key headers len (status "200 OK")) &body body)
  25   (let ((result (gensym "RES-")))
  26    `(progn
  27       (write-header-line "Status" ,status)
  28       (dolist (hdr ,headers)
  29         (write-header-line (car hdr) (cdr hdr)))
  30     ,@(and len
  31         `((write-header-line "Content-Length" ,len)
  32           (write-header-line "Keep-Socket" "1")
  33           (write-header-line "Connection" "Keep-Alive")))
  34       (write-string "end" *modlisp-socket*)
  35       (write-char #\NewLine *modlisp-socket*)
  36       (let ((,result (progn ,@body)))
  37         (,(if len 'force-output 'finish-output)  *modlisp-socket*)
  38         (setq *close-modlisp-socket* ,(not len))
  39         ,result))))
  40
  41 (defmacro with-ml-page ((&key (format :html) (precompute t) headers)
  42                         &body body)
  43   (if precompute
  44     `(output-ml-page ,format (with-output-to-string (*modlisp-socket*) ,@body) :headers ,headers)
  45     `(write-response (:headers (format-string ,format ,headers)) ,@body)))
  46
  47 (defun redirect-to-location (url)
  48   (write-response (:status "307 Temporary Redirect" :headers `(("Location" . ,url)))))
  49
  50 (defmacro output-ml-page (format html &key headers)
  51   (let ((str (gensym "STR-")))
  52    `(let ((,str ,html))
  53       (write-response (:len (format nil "~d" (length ,str))
  54                        :headers (format-string ,format ,headers))
  55         (write-string ,str *modlisp-socket*)))))
  56
  57 (defun output-html-page (str &key headers)
  58   (output-ml-page :html str :headers headers))
  59
  60 (defun output-xml-page (str &key headers)
  61   (output-ml-page :xml str :headers headers))
  62
  63 ;; Utility functions for library users
  64
  65 (defun query-to-alist (posted-string &key (keyword t))
  66   "Converts a posted string to an assoc list of keyword names and values,
  67 \"a=1&bc=demo\" => ((:a . \"1\") (:bc . \"demo\"))"
  68   (when posted-string
  69     (let ((alist '()))
  70       (dolist (name=val (kmrcl:delimited-string-to-list posted-string #\&)
  71                (nreverse alist))
  72         (let ((name-val-list (kmrcl:delimited-string-to-list name=val #\=)))
  73           (if (= 2 (length name-val-list))
  74             (destructuring-bind (name val) name-val-list
  75               (push (cons (if keyword
  76                               (kmrcl:ensure-keyword name)
  77                             name)
  78                           (kmrcl:decode-uri-query-string val))
  79                     alist))
  80             (cmsg-c :debug "Invalid number of #\= in ~S" name-val-list)))))))