X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=uri.lisp;h=1f2e22467d476acc74bef7a907befbeb8a4e6ced;hb=c28c5678e980a71b9f3d23650b0323ccb75198c4;hp=afbeb75e26109991780e17fe491b8e38913543d0;hpb=d91ff3b4d9cdcae003420c04609ea736161c7e65;p=wol.git diff --git a/uri.lisp b/uri.lisp index afbeb75..1f2e224 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,28 +7,62 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; -;;;; $Id: uri.lisp,v 1.2 2003/07/18 21:34:18 kevin Exp $ +;;;; $Id: uri.lisp,v 1.8 2003/08/10 05:16:52 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)" - (multiple-value-bind (page plists query) - (decode-url (request-raw-uri req)) - (when page - (setf (request-page req) (base-page-name page ent))) - (when plists - (setf (request-plist req) (car plists)) - (setf (request-next-plists req) (cdr plists)) - (when (null page) - (awhen (getf (request-plist req) :page) - (setf (request-page req) it)))) - (setf (request-uri-query req) query)) - req) +(defun req-recode-uri-sans-session-id (req) + (let ((ppath (puri:uri-parsed-path (request-uri req)))) + (when (is-raw-session-id (second ppath)) + (let ((new-path (list* (car ppath) (cddr ppath)))) + (setf (uri-parsed-path (request-uri req)) new-path) + (setf (uri-parsed-path (request-raw-uri req)) new-path)) + (setf (request-decoded-uri-path req) + (uridecode-string (uri-path (request-raw-uri req)))) + (raw-session-id->session-id (second ppath))))) + +(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 header-lines-matching (key headers) + (loop for hdr in headers + when (eq key (car hdr)) + collect (cdr hdr))) + +(defun set-cookies-in-headers (headers) + (header-lines-matching :set-cookie headers)) + +(defun cookies-in-headers (headers) + (header-lines-matching :cookie headers)) + +(defun cookie-session-key (ent cookies) + "Return the session key from the alist of cookies" + (let ((name (project-name (entity-project ent)))) + (cdr (assoc name cookies :test #'string-equal)))) + +(defun compute-uris (req ent) + "Compute URI's of a request" + (let ((url-session-id (req-recode-uri-sans-session-id req))) + (compute-session req ent url-session-id) + + (multiple-value-bind (page plists query) + (decode-url (puri:uri-path (request-raw-uri req))) + (when page + (setf (request-page req) (base-page-name page ent))) + (when plists + (setf (request-plist req) (car plists)) + (setf (request-next-plists req) (cdr plists)) + (when (null page) + (awhen (getf (request-plist req) :page) + (setf (request-page req) it)))) + (setf (request-uri-query req) query)))) ;;; URI Functions @@ -60,63 +94,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 + prefix + (if (and session + (websession-key session) + (not (eq :cookies (websession-method session)))) + (format nil "~~~A~~/" (websession-key session)) + "") + (if (null plist) + (concatenate 'string page ".html") + (concatenate 'string + +asp-header+ + (concatenate 'string +plist-header+ + (plist-to-url-string url-plist))))))) ;; Property lists @@ -125,12 +119,12 @@ (let ((str (plist-to-compressed-string plist))) (if base64 (string-to-base64-string str :uri t) - (escape-uri-field str)))) + (uriencode-string str)))) (defun url-string-to-plist (str &key (base64 t)) (let ((decode (if base64 (base64-string-to-string str :uri t) - (unescape-uri-field str)))) + (uridecode-string str)))) (when decode (ignore-errors (compressed-string-to-plist decode))))) @@ -154,6 +148,7 @@ (:lang :l) (:logged :g) (:caller :c) + (:db :d) ;; For lookup-func1 (:func :f) @@ -191,6 +186,7 @@ (:L :lang) (:G :logged) (:C :caller) + (:D :db) ;; For posting to lookup-func1 (:F :func)