X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=uri.lisp;h=7c38f304226c95c1c43d190cb8aadb25143fff39;hb=628dda3f26ad183880fea5871c37b9cfa33b425a;hp=e0612a29c8ddd40da2d0462a91c67ea2c9ed42b9;hpb=3bffe3c738cf4026f76cd7428c378442e0e4bb2a;p=wol.git diff --git a/uri.lisp b/uri.lisp index e0612a2..7c38f30 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,51 @@ ;;;; 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.7 2003/08/09 21:42:24 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) + (setq cl-user::r 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 cookie-session-key (ent 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 +83,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 +108,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)))))