X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=uri.lisp;h=d86e1281a65c3bb4424cccfad2dd728b6b9c3d61;hp=afbeb75e26109991780e17fe491b8e38913543d0;hb=HEAD;hpb=d91ff3b4d9cdcae003420c04609ea736161c7e65

diff --git a/uri.lisp b/uri.lisp
index afbeb75..d86e128 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,116 +7,149 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: uri.lisp,v 1.2 2003/07/18 21:34:18 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; 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 path->session-id (path ent)
+  "Returns session-id,remainder-path"
+  (let ((prefix (project-prefix (entity-project ent))))
+    (when (and (> (length path) (length prefix))
+               (string= prefix (subseq path 0 (length prefix))))
+      (let ((sans-prefix (subseq path (length prefix))))
+        (when (char= #\~ (schar sans-prefix 0))
+          (let* ((len (length sans-prefix))
+                 (next-tilde (position-char #\~ sans-prefix 1 len))
+                 (next-slash (position-char #\/ sans-prefix 1 len)))
+            (when (and next-tilde next-slash
+                       (< next-tilde next-slash))
+              (values
+               (subseq sans-prefix 0 (1+ next-tilde))
+               (subseq sans-prefix (1+ next-tilde))))))))))
+
+
+(defun req-recode-uri-sans-session-id (req ent)
+  (multiple-value-bind (raw-session-id remainder)
+      (path->session-id (request-decoded-uri-path req) ent)
+    (when raw-session-id
+      (let ((new-path (concatenate 'string (project-prefix
+                                            (entity-project ent))
+                                   (subseq remainder 1))))
+           (setf (uri-path (request-uri req)) new-path)
+           (setf (uri-path (request-raw-uri req)) new-path)
+           (setf (request-decoded-uri-path req) new-path))
+         (raw-session-id->session-id raw-session-id))))
+
+ (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 entity-project-prefix-string (ent)
+  (let ((prefix (project-prefix (entity-project ent))))
+    (if (= 1 (length prefix))
+        ""
+      (subseq prefix 1 (1- (length prefix))))))
+
+(defun compute-uris (req ent)
+  "Compute URI's of a request"
+  (let* ((url-session-id (req-recode-uri-sans-session-id req ent))
+         (uri (request-raw-uri req))
+         (ppath (puri:uri-parsed-path uri))
+         (prefix-string (entity-project-prefix-string ent)))
+
+    (assert (eq (first ppath) :absolute))
+
+    (cond
+     ((zerop (length prefix-string))
+      ;; strip :absolute
+      (setq ppath (cdr ppath)))
+     ((string-equal (second ppath) (entity-project-prefix-string ent))
+      (setq ppath (cddr ppath)))
+     (t
+      (warn "Non-prefix path ~S" ppath)
+      (return-from compute-uris nil)))
+
+    (compute-session req ent url-session-id)
+    (multiple-value-bind (page plists) (decode-url ppath)
+      (when page
+        (setf (request-page req) (base-page-name page)))
+      (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) (puri:uri-query uri)))))
 
 
 ;;; URI Functions
 
-(defun base-page-name (page ent)
+(defun base-page-name (page)
   "Return the base page name for a html url"
-  (let ((len-prefix (length (project-prefix (entity-project ent)))))
-    (assert (>= (length page) len-prefix))
-    (string-strip-ending (subseq page len-prefix)
-			 '(".html" ".lsp"))))
+  (string-strip-ending page '(".html" ".lsp")))
 
 (defun split-plist-url (url)
   (string-delimited-string-to-list url +plist-header+))
 
-(defun decode-url (url)
+(defun is-plist-header (str)
+  (string= +plist-header+ (subseq str 0 +plist-header-length+)))
+
+(defun decode-url (ppath)
   "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
+  (when (is-raw-session-id (car ppath))
+    (setq ppath (cdr ppath)))
   (let* ((plists '())
-	 (qsplit (delimited-string-to-list url #\?))
-	 (query (cadr qsplit))
-	 (split (split-plist-url (car qsplit)))
-	 (page-name 
-	  (when (and (plusp (length (car split)))
-		     (not (string= +full-asp-header+ (car split)))
-		     (not (string-starts-with +full-asp-header+ (car split))))
-	    (car split))))
-    (dolist (elem (cdr split))
-      (push (url-string-to-plist elem) plists))
-    (values page-name (nreverse plists) query)))
-
-
-
-(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))
-	(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))
+         (page-name (unless (is-plist-header (car ppath))
+                      (prog1
+                          (car ppath)
+                        (setq ppath (cdr ppath))))))
+    (dolist (elem ppath)
+      (if (is-plist-header elem)
+          (push (url-string-to-plist (subseq elem +plist-header-length+))
+                plists)
+        (warn "Non plist header found in url ~S" elem)))
+    (values page-name (nreverse plists))))
+
+
+
+(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))))
+    (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
+          (concatenate 'string +plist-header+
+                       (plist-to-url-string url-plist)))))))
 
 
 ;; Property lists
@@ -124,13 +157,13 @@
 (defun plist-to-url-string (plist &key (base64 t))
   (let ((str (plist-to-compressed-string plist)))
     (if base64
-	(string-to-base64-string str :uri t)
-	(escape-uri-field str))))
+        (string-to-base64-string str :uri t)
+        (encode-uri-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))))
+                    (base64-string-to-string str :uri t)
+                    (decode-uri-string str))))
     (when decode
       (ignore-errors (compressed-string-to-plist decode)))))
 
@@ -138,12 +171,13 @@
   "Decode an encoded plist"
     (assert (evenp (length plist)))
     (do* ((output '())
-	  (list plist (cddr list)))
-	 ((null list)
-	  (prin1-to-string (nreverse output)))
+          (list plist (cddr list)))
+         ((null list)
+          (prin1-to-string (nreverse output)))
       (push (compress-elem (car list)) output)
       (push (cadr list) output)))
 
+
 (defun compress-elem (elem)
   "Encode a plist elem"
   (case elem
@@ -154,7 +188,8 @@
     (:lang :l)
     (:logged :g)
     (:caller :c)
-    
+    (:db :d)
+
     ;; For lookup-func1
     (:func :f)
     (:format :r)
@@ -162,15 +197,15 @@
     (:labels :a)
     (:subobjects :b)
     (:english-only :e)
-   
+
     (:xml :x)
     (:next-page :n)
-    
+
     (otherwise elem)))
 
 (defun compressed-string-to-plist (encoded-str)
   (let ((encoded (ignore-errors (read-from-string encoded-str)))
-	(output '()))
+        (output '()))
     (unless encoded
       (cmsg "invalid encoded string")
       #+ignore
@@ -178,31 +213,39 @@
       nil)
     (assert (evenp (length encoded)))
     (do* ((elist encoded (cddr elist)))
-	 ((null elist) (nreverse output))
+         ((null elist) (nreverse output))
       (push (decompress-elem (car elist)) output)
       (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)))
-