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

diff --git a/uri.lisp b/uri.lisp
index 76eab37..d86e128 100644
--- a/uri.lisp
+++ b/uri.lisp
@@ -7,29 +7,48 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: uri.lisp,v 1.10 2003/08/10 17:56:44 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package #:wol)
 
-(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 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
@@ -47,70 +66,90 @@
   (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)))
+  (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 query) 
-	(decode-url (puri:uri-path (request-raw-uri req)))
+    (multiple-value-bind (page plists) (decode-url ppath)
       (when page
-	(setf (request-page req) (base-page-name page ent)))
+        (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) query))))
+          (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)))
+         (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))))
+        (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))
-	"")
+                 (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)))))))
+        (concatenate 'string page ".html")
+        (concatenate 'string
+          (concatenate 'string +plist-header+
+                       (plist-to-url-string url-plist)))))))
 
 
 ;; Property lists
@@ -118,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)
-	(uriencode-string 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)
-		    (uridecode-string str))))
+                    (base64-string-to-string str :uri t)
+                    (decode-uri-string str))))
     (when decode
       (ignore-errors (compressed-string-to-plist decode)))))
 
@@ -132,12 +171,12 @@
   "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"
@@ -150,7 +189,7 @@
     (:logged :g)
     (:caller :c)
     (:db :d)
-    
+
     ;; For lookup-func1
     (:func :f)
     (:format :r)
@@ -158,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
@@ -174,7 +213,7 @@
       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))))
 
@@ -190,7 +229,7 @@
       (#\G :logged)
       (#\C :caller)
       (#\D :db)
-      
+
       ;; For posting to lookup-func1
       (#\F :func)
       (#\K :key)
@@ -198,15 +237,15 @@
       (#\A :labels)
       (#\E :english-only)
       (#\R :format)
-      
+
       (#\X :xml)
       (#\P :page)
-      
+
       (otherwise elem))))
 
 
 
 
 
-	  
+