X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=uri.lisp;h=1011b1036dcd0e6a60f8d67753953dacaf04e4cc;hb=0c0d797b5e6c5afa9050b8021ea4729f4ab68aca;hp=16764b7772fbe2e6016da5bd18dc5f37663c64ff;hpb=b02132b356f13c6e1d04fde727eb86ac1ee0b3ce;p=wol.git diff --git a/uri.lisp b/uri.lisp index 16764b7..1011b10 100644 --- a/uri.lisp +++ b/uri.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,16 +7,43 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; -;;;; $Id: uri.lisp,v 1.3 2003/07/19 20:32:48 kevin Exp $ +;;;; $Id: uri.lisp,v 1.6 2003/08/08 23:40:13 kevin Exp $ ;;;; ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:wol) - -(defun request-decompile-uri (req ent) - "returns (VALUE PAGE PLIST QUERY-ALIST)" +(defun uri->recode-uri-sans-session-id (uri) + (let ((parsed-path (puri:uri-parsed-path uri))) + (cond + ((and (eq :absolute (first parsed-path)) + (is-raw-session-id (second parsed-path))) + (values (copy-uri uri :place t + :parsed-path + (list* :absolute (cddr parsed-path))) + (raw-session-id->session-id (second parsed-path)))) + (t + (values uri nil))))) + +(defun request-cookies (req) + (aif (aserve-request req) + (net.aserve:get-cookie-values it) + (loop for h in (request-headers req) + when (eq :cookie (car h)) + collect (cdr h)))) + +(defun cookie-session-key (ent cookies) + (let ((name (project-name (entity-project ent)))) + (cdr (assoc name cookies :test #'string-equal)))) + +(defun url-session-key (url) + "Return a session key encoded in a URL" + nil) + +(defun compute-uris (req ent) + "Compute URI's of a request" + (compute-session req ent) (multiple-value-bind (page plists query) (decode-url (puri:uri-path (request-raw-uri req))) (when page @@ -27,8 +54,7 @@ (when (null page) (awhen (getf (request-plist req) :page) (setf (request-page req) it)))) - (setf (request-uri-query req) query)) - req) + (setf (request-uri-query req) query))) ;;; URI Functions @@ -60,63 +86,23 @@ -(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 req ent &optional plist) + (let ((session (websession-from-req req)) + (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") - (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)) + (concatenate 'string + (if (and session + (websession-key session) + (eq :url (websession-method session))) + (format nil "/~~~A~~/" (websession-key session)) + "") + prefix + (if (null plist) + (concatenate 'string page ".html") + (concatenate 'string + +asp-header+ + (concatenate 'string +plist-header+ + (plist-to-url-string url-plist))))))) ;; Property lists @@ -154,6 +140,7 @@ (:lang :l) (:logged :g) (:caller :c) + (:db :d) ;; For lookup-func1 (:func :f) @@ -191,6 +178,7 @@ (:L :lang) (:G :logged) (:C :caller) + (:D :db) ;; For posting to lookup-func1 (:F :func)