X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=uri.lisp;h=76eab37ed4de5aa4b7ff90f4dfa290cbdbb38061;hb=ca586910648f4844e335d92f23e619fd2b84f969;hp=16764b7772fbe2e6016da5bd18dc5f37663c64ff;hpb=b02132b356f13c6e1d04fde727eb86ac1ee0b3ce;p=wol.git diff --git a/uri.lisp b/uri.lisp index 16764b7..76eab37 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.3 2003/07/19 20:32:48 kevin Exp $ +;;;; $Id: uri.lisp,v 1.10 2003/08/10 17:56:44 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 (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)) - 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-url-plist req) (car plists)) + (setf (request-url-next-plists req) (cdr plists)) + (when (null page) + (awhen (getf (request-url-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))))) @@ -143,6 +137,7 @@ (prin1-to-string (nreverse output))) (push (compress-elem (car list)) output) (push (cadr list) output))) + (defun compress-elem (elem) "Encode a plist elem" @@ -154,6 +149,7 @@ (:lang :l) (:logged :g) (:caller :c) + (:db :d) ;; For lookup-func1 (:func :f) @@ -183,26 +179,34 @@ (push (cadr elist) output)))) (defun decompress-elem (elem) - (case elem - (:N :next-page) - (:T :posted) - (:O :object-id) - (:S :session-id) - (:L :lang) - (:G :logged) - (:C :caller) - - ;; For posting to lookup-func1 - (:F :func) - (:K :key) - (:B :subobjects) - (:A :labels) - (:E :english-only) - (:R :format) - - (:X :xml) - (:P :page) + (if (> (length (symbol-name elem)) 1) + elem + (case (char-upcase (schar (symbol-name elem ) 0)) + (#\N :next-page) + (#\T :posted) + (#\O :object-id) + (#\S :session-id) + (#\L :lang) + (#\G :logged) + (#\C :caller) + (#\D :db) + + ;; For posting to lookup-func1 + (#\F :func) + (#\K :key) + (#\B :subobjects) + (#\A :labels) + (#\E :english-only) + (#\R :format) + + (#\X :xml) + (#\P :page) + + (otherwise elem)))) + + + + - (otherwise elem)))