;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: July 2003
;;;;
-;;;; $Id: project.lisp,v 1.6 2003/08/05 23:00:28 kevin Exp $
+;;;; $Id: project.lisp,v 1.7 2003/08/08 09:03:45 kevin Exp $
;;;;
;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(string= (puri:uri-path (request-raw-uri req))
(project-prefix (entity-project ent))))
-(defun redirect-entity (page ent &optional plist)
- (redirect-to-location (apply #'make-wol-url page ent plist)))
+(defun redirect-entity (page req ent &optional plist)
+ (let ((proj (entity-project ent))
+ (url (make-wol-url page ent plist)))
+ (ecase (project-connector proj)
+ (:aserve
+ (net.aserve:with-http-response
+ ((aserve-request req)
+ (entity-aserve-entity ent)
+ :response net.aserve:*response-moved-permanently*)
+ (net.aserve:with-http-body
+ ((aserve-request req)
+ (entity-aserve-entity ent)
+ :headers `((:location . ,url))))))
+ (:modlisp
+ (redirect-to-location url)))))
(defun dispatch-request (req ent)
(let ((proj (entity-project ent)))
(if (is-index-request req ent)
- (redirect-entity (project-index proj) ent)
+ (redirect-entity (project-index proj) req ent)
(progn
(request-decompile-uri req ent)
(compute-session req ent)
(let ((next-page (funcall handler req ent)))
(typecase next-page
(string
- (redirect-entity next-page ent))
+ (redirect-entity next-page req ent))
(cons
- (redirect-entity (car next-page) ent (cadr next-page)))
+ (redirect-entity (car next-page) req ent (cadr next-page)))
(null
t)
(t
(defun wol-version-string ()
(format nil "~{~D~^.~}" *wol-version*))
-
+
+(defun alist-key->keyword (alist)
+ (loop for a in alist
+ collect (cons (kmrcl:ensure-keyword (car a)) (cdr a))))
+
(defun request-query (req &key (uri t) (post t))
- (let ((desired (cons uri post)))
- (if (equal desired (request-desired-query req))
- ;; Same desired as cached
- (request-query-alist req)
- (progn
- (setf (request-desired-query req) desired)
- (setf (request-query-alist req)
- (append
- (when (and uri (request-uri-query req))
- (query-to-alist (request-uri-query req)))
- (when (and post (request-posted-content req))
- (query-to-alist (request-posted-content req)))))))))
+ (aif (aserve-request req)
+ (alist-key->keyword
+ (net.aserve:request-query it :uri uri :post post))
+ (let ((desired (cons uri post)))
+ (if (equal desired (request-desired-query req))
+ ;; Same desired as cached
+ (request-query-alist req)
+ (progn
+ (setf (request-desired-query req) desired)
+ (setf (request-query-alist req)
+ (append
+ (when (and uri (request-uri-query req))
+ (query-to-alist (request-uri-query req)))
+ (when (and post (request-posted-content req))
+ (query-to-alist (request-posted-content req))))))))))
(defun request-query-value (key req &key (uri t) (post t))
- (cdr (assoc key (request-query req :uri uri :post post)
- :test 'equal)))
+ (aif (aserve-request req)
+ (net.aserve:request-query-value (string key) it :uri uri :post post)
+ (cdr (assoc key (request-query req :uri uri :post post)
+ :test 'equal))))
(defun websession-variable (ws name)
(when ws
(defmacro with-wol-page ((req ent
+ &key (format :html) (precompute t) headers)
+ &body body)
+ `(ecase (project-connector (entity-project ,ent))
+ (:aserve
+ (net.aserve:with-http-response
+ ((aserve-request ,req)
+ (entity-aserve-entity ,ent)
+ :content-type (ml::format-string ,format))
+ (net.aserve:with-http-body
+ ((aserve-request ,req)
+ (entity-aserve-entity ,ent)
+ :headers ,headers)
+ (let ((*html-stream* net.html.generator:*html-stream*))
+ ,@body))))
+ (:modlisp
+ (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
+ :headers ,headers)
+ ,@body))))
+
+
+(defmacro %with-wol-page ((req ent
&key (format :html) (precompute t) headers)
&body body)
(declare (ignore req ent))
(:body
(:h1 "Not Found")
(:p "The request for "
- (:b (:write-string (request-uri req)))
+ (:b (:write-string (render-uri (request-uri req) nil)))
" was not found on this server.")
(:hr)
(:div (:i "WOL "
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: July 2003
;;;;
-;;;; $Id: uri.lisp,v 1.4 2003/07/23 23:08:29 kevin Exp $
+;;;; $Id: uri.lisp,v 1.5 2003/08/08 09:03:45 kevin Exp $
;;;;
;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************
+#+ignore
(defun make-html-url (page ent &optional query-args)
(make-url (concatenate 'string page ".html")
:base-dir (project-prefix
(entity-project ent))
:vars query-args :format :xhtml))
-(defvar *unspecified* (cons :unspecified nil))
-
-(defun make-wol-url (page ent
- &key (session-id *unspecified*)
- (object-id *unspecified*)
- (func *unspecified*) (key *unspecified*)
- (subobjects *unspecified*) (labels *unspecified*)
- (english-only *unspecified*)
- (format *unspecified*)
- (lang *unspecified*) (logged *unspecified*)
- (next-page *unspecified*) (caller *unspecified*)
- asp html)
- (let ((plist (list :page page))
+
+(defun make-wol-url (page ent &optional plist)
+ (let ((url-plist (append (list :page page) plist))
(prefix (project-prefix (entity-project ent))))
- (unless (eq session-id *unspecified*)
- (setq plist (append plist (list :session-id session-id))))
- (unless (eq object-id *unspecified*)
- (setq plist (append plist (list :object-id object-id))))
- (unless (eq lang *unspecified*)
- (setq plist (append plist (list :lang lang))))
- (unless (eq logged *unspecified*)
- (setq plist (append plist (list :logged logged))))
- (unless (eq func *unspecified*)
- (setq plist (append plist (list :func func))))
- (unless (eq subobjects *unspecified*)
- (setq plist (append plist (list :subobjects subobjects))))
- (unless (eq key *unspecified*)
- (setq plist (append plist (list :key key))))
- (unless (eq labels *unspecified*)
- (setq plist (append plist (list :labels labels))))
- (unless (eq english-only *unspecified*)
- (setq plist (append plist (list :english-only english-only))))
- (unless (eq next-page *unspecified*)
- (setq plist (append plist (list :next-page next-page))))
- (unless (eq format *unspecified*)
- (setq plist (append plist (list :format format))))
- (unless (eq caller *unspecified*)
- (setq plist (append plist (list :caller caller))))
- (if (and (null asp)
- (parameters-null session-id object-id lang logged func subobjects
- key labels english-only next-page format caller))
- (concatenate 'string prefix page ".html")
+ (if (null plist)
+ (concatenate 'string prefix page ".lsp")
(concatenate 'string
prefix
- (if html
- (concatenate 'string page ".lsp")
- +asp-header+)
- (concatenate 'string +plist-header+ (plist-to-url-string plist))))))
-
-(defun parameters-null (&rest params)
- (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params))
+ +asp-header+
+ (concatenate 'string +plist-header+
+ (plist-to-url-string url-plist))))))
;; Property lists