From 0c0d797b5e6c5afa9050b8021ea4729f4ab68aca Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 8 Aug 2003 23:40:13 +0000
Subject: [PATCH] r5473: *** empty log message ***

---
 classes.lisp  |  11 ++++--
 project.lisp  | 102 +++++++++++++++++++++++++++++++-------------------
 sessions.lisp |  80 +++++++++++++++++++++++++--------------
 uri.lisp      |  73 ++++++++++++++++++++++++------------
 4 files changed, 172 insertions(+), 94 deletions(-)

diff --git a/classes.lisp b/classes.lisp
index ba5440a..965491e 100644
--- a/classes.lisp
+++ b/classes.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
+x;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: classes.lisp,v 1.5 2003/08/08 09:03:45 kevin Exp $
+;;;; $Id: classes.lisp,v 1.6 2003/08/08 23:40:13 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -29,7 +29,7 @@
    (lifetime :initarg :lifetime :initform nil
 	     :accessor websession-lifetime)
    (data :initform nil :accessor websession-data)
-   (method :initarg :method :accessor websession-method)
+   (method :initarg :method :accessor websession-method :initform nil)
    (variables :initform (make-hash-table :test 'equal)
 	      :accessor websession-variables)))
    
@@ -55,6 +55,9 @@
 (defclass http-request ()
   ((method  :initarg :method :accessor request-method)
    (uri  :initarg :uri :accessor request-uri)
+   (decoded-uri-path :initarg :decoded-uri-path
+		     :accessor request-decoded-uri-path)
+   (raw-request :initarg :raw-request :accessor request-raw-request)
    (raw-uri :initarg :raw-uri :accessor request-raw-uri)
    (protocol :initarg :protocol :reader request-protocol)
    (protocol-string :initarg :protocol-string :reader request-protocol-string)
@@ -95,3 +98,5 @@
 
 (defvar *wol-stream* nil
   "The output stream for the current request")
+
+(defconstant +length-session-id+ 24)
diff --git a/project.lisp b/project.lisp
index 346ccd3..6a285f6 100644
--- a/project.lisp
+++ b/project.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: project.lisp,v 1.7 2003/08/08 09:03:45 kevin Exp $
+;;;; $Id: project.lisp,v 1.8 2003/08/08 23:40:13 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -78,32 +78,37 @@
 
 (defun wol-aserve-processor (as-req as-ent)
   "Processes an incoming modlisp command"
-  (let* ((req (make-request-from-aserve as-req))
-	 (ent (make-entity-from-aserve req as-ent)))
+  (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
     (dispatch-request req ent)))
 
-(defun make-request-from-aserve (as-req)
-  (make-instance 'http-request
-		 :method (net.aserve:request-method as-req)
-		 ;;:host (net.aserve:request-host as-req)
-		 :raw-uri (puri:intern-uri
-			   (net.uri:render-uri
-			    (net.aserve:request-raw-uri as-req) nil))
-		 :uri (puri:intern-uri
-		       (net.uri:render-uri
-			(net.aserve:request-uri as-req) nil))
-		 :protocol (net.aserve:request-protocol as-req)
-		 :protocol-string
-		 (net.aserve:request-protocol-string as-req)
-		 :posted-content (net.aserve::request-request-body as-req)
-		 :socket (net.aserve:request-socket as-req)
-		 :aserve-server net.aserve:*wserver*
-		 :aserve-request as-req))
-
-(defun make-entity-from-aserve (req as-ent)
-  (make-instance 'entity
-		 :project (find-project-for-request req)
-		 :aserve-entity as-ent))
+
+    
+(defun make-request/ent-from-aserve (as-req as-ent)
+  (let* ((req (make-instance
+	       'http-request
+	       :method (net.aserve:request-method as-req)
+	       ;;:host (net.aserve:request-host as-req)
+	       :raw-request (net.aserve::request-raw-request as-req)
+	       :raw-uri (puri:intern-uri
+			 (net.uri:render-uri
+			 (net.aserve:request-raw-uri as-req) nil))
+	       :decoded-uri-path
+	       (net.aserve::request-decoded-uri-path as-req)
+	       :uri (puri:intern-uri
+		     (net.uri:render-uri
+		     (net.aserve:request-uri as-req) nil))
+	       :protocol (net.aserve:request-protocol as-req)
+	       :protocol-string
+	       (net.aserve:request-protocol-string as-req)
+	       :posted-content (net.aserve::request-request-body as-req)
+	       :socket (net.aserve:request-socket as-req)
+	       :headers (net.aserve::request-headers as-req)
+	       :aserve-server net.aserve:*wserver*
+	       :aserve-request as-req))
+	 (ent (make-instance 'entity
+			     :project (find-project-for-request req)
+			     :aserve-entity as-ent)))
+    (values req ent)))
 
 
 (defun command->request (command &key ml-server)
@@ -111,14 +116,9 @@
   (let ((req
 	 (make-instance 'http-request
 	   :host (header-value command :host)
-	   :raw-uri  (aif (ignore-errors
-			   (puri:intern-uri (header-value command :url)))
-			  it
-			  (header-value command :url))
-	   :uri (aif (ignore-errors
-		      (puri:intern-uri (command->uri command)))
-		     it
-		     (command->uri command))
+	   :raw-request (header-value command :url) 
+	   :raw-uri  (puri:intern-uri (header-value command :url))
+	   :uri (puri:intern-uri (command->uri command))
 	   :protocol (ensure-keyword
 		      (header-value command :server-protocol))
 	   :protocol-string (header-value command :server-protocol)
@@ -127,6 +127,8 @@
 	   :headers command
 	   :socket *modlisp-socket*
 	   :ml-server ml-server)))
+    (awhen (request-raw-uri req)
+	   (setf (request-decoded-uri-path req) (puri:uri-path it)))
     req))
 
 (defun header-slot-value (req slot)
@@ -139,18 +141,42 @@
 	  (header-value command :url)))
 
 (defun is-index-request (req ent)
-  (string= (puri:uri-path (request-raw-uri req)) 
+  (string= (request-decoded-uri-path req)
 	   (project-prefix (entity-project ent))))
 
+(defun set-cookie (req ent)
+  (let ((session (websession-from-req req)))
+    (when (and session (websession-key session)
+	       (not (eq :url (websession-method session))))
+      (let ((proj (entity-project ent)))
+	(ecase (project-connector proj)
+	  (:aserve
+	   (cmsg "Set-cookie: ~A"  (websession-key
+						 (websession-from-req req)))
+	   (net.aserve:set-cookie-header (aserve-request req)
+					 :name (project-name
+						(entity-project ent))
+					 :expires :never
+					 :secure nil
+					 :domain ".b9.com"
+					 :value (websession-key
+						 (websession-from-req req))
+					 :path "/"))
+	  (:modlisp
+	   ;; fixme
+	   ))))))
+
+
 (defun redirect-entity (page req ent &optional plist)
   (let ((proj (entity-project ent))
-	(url (make-wol-url page ent plist)))
+	(url (make-wol-url page req ent plist)))
     (ecase (project-connector proj)
       (:aserve
        (net.aserve:with-http-response 
 	   ((aserve-request req) 
 	    (entity-aserve-entity ent)
 	    :response net.aserve:*response-moved-permanently*)
+	 (set-cookie req ent)
 	 (net.aserve:with-http-body 
 	     ((aserve-request req) 
 	      (entity-aserve-entity ent)
@@ -163,8 +189,7 @@
     (if (is-index-request req ent)
 	(redirect-entity (project-index proj) req ent)
 	(progn
-	  (request-decompile-uri req ent)
-	  (compute-session req ent)
+	  (compute-uris req ent)
 	  (dispatch-to-handler req ent)))))
 
 (defun make-entity (&key project)
@@ -183,7 +208,7 @@
 
 (defun request-matches-prefix (req prefix)
   "Returns project if request matches project"
-  (string-starts-with prefix (puri:uri-path (request-raw-uri req))))
+  (string-starts-with prefix (request-decoded-uri-path req)))
 
 
 (defun dispatch-to-handler (req ent)
@@ -274,6 +299,7 @@
 	  ((aserve-request ,req) 
 	   (entity-aserve-entity ,ent)
 	   :content-type (ml::format-string ,format))
+	(set-cookie ,req ,ent)
 	(net.aserve:with-http-body 
 	    ((aserve-request ,req) 
 	     (entity-aserve-entity ,ent)
diff --git a/sessions.lisp b/sessions.lisp
index 045d0dd..39e2fe5 100644
--- a/sessions.lisp
+++ b/sessions.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: sessions.lisp,v 1.3 2003/07/16 20:40:43 kevin Exp $
+;;;; $Id: sessions.lisp,v 1.4 2003/08/08 23:40:13 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,48 +15,61 @@
 (in-package #:wol)
 
 
-(defun make-new-session-id ()
-  (random-string :length 24 :set :lower-alphanumeric))
+#||
+(awhen (and session-id (find-websession session-id ent))
+       (setf (websession-from-req req) it)
+       (setf (websession-method it) :url))
+||#
 
-(defun ensure-websession (key req ent method)
-  "Find or make websession for key"
+(defun find-websession (key ent)
   (let ((sessions (sessions (session-master (entity-project ent)))))
-    ;; if sessions doesn't exist, then project is not session enabled
-    (when sessions
-      (cond 
-       ((null key)
-	(make-websession req ent method))
-       (t
-	(maphash
-	 (lambda (k v)
-	   (declare (ignore k))
-	   (when (equal key (websession-key v))
-	     (setf (websession-lastref v) (get-universal-time))
-	     (return-from ensure-websession v)))
-	 sessions)
-	(make-websession req ent method))))))
+    (maphash
+     (lambda (k v)
+       (declare (ignore k))
+       (when (equal key (websession-key v))
+	 (setf (websession-lastref v) (get-universal-time))
+	 (return-from find-websession v)))
+     sessions)
+    nil))
+
+(defun is-session-enabled (ent)
+  (not (null (sessions (session-master (entity-project ent))))))
 
   
-(defun make-websession (req ent method)
-  (let* ((key (random-string :length 24 :set :lower-alphanumeric))
+(defun make-websession (req ent)
+  (let* ((key (random-string :length +length-session-id+
+			     :set :lower-alphanumeric))
 	 (sess (make-instance 'websession
 		 :key key
 		 :lastref (get-universal-time)
 		 :lifetime (lifetime (session-master (entity-project ent)))
-		 :method method))
+		 :method :try-cookie))
 	 (hash (sessions (session-master (entity-project ent)))))
     (when hash
       (setf (gethash key hash) sess)
       (setf (websession-from-req req) sess)
       sess)))
 
-(defun compute-session (req ent)
-  (awhen (and (request-plist req)
-	      (getf (request-plist req) :session-id))
-	 (setf (websession-from-req req) 
-	   (ensure-websession it req ent :uri))))
-
 
+(defun compute-session (req ent)
+  (when (is-session-enabled ent)
+    (let ((key (cookie-session-key ent (request-cookies req)))
+	  (has-cookie-key nil)
+	  (has-url-key nil))
+      (if key
+	  (setq has-cookie-key t)
+	(when (setq key (url-session-key (request-raw-uri req)))
+	  (setq has-url-key t)))
+      (let* ((found-session (when key (find-websession key ent)))
+	     (session (aif found-session it (make-websession req ent)))) 
+	(setf (websession-from-req req) session)
+	(when found-session
+	  (if has-cookie-key
+	      (setf (websession-method session) :cookies)
+	    (when has-url-key
+	      (setf (websession-method session) :url))))
+	session))))
+  
 
 ;;; Reap expired sessions
 
@@ -93,8 +106,17 @@
 (defmethod flush-expired (s)
   (let ((sessions (sessions (session-master (cdr s)))))
     (remhash (car s) sessions)
-    (add-log-entry (cdr s) "flush expired session: key=~A" (websession-key (car s)))))
+    (add-log-entry (cdr s) "flush expired session: key=~A" 
+		   (websession-key (car s)))))
 
 (defun is-session-expired (ws)
   (> (get-universal-time)  (+ (websession-lastref ws)
 			      (websession-lifetime ws))))
+
+(defun is-raw-session-id (str)
+  (and (stringp str)
+       (> (length str) 2)
+       (char= #\~ (schar str 0) (schar str (1- (length str))))))
+
+(defun raw-session-id->session-id (str)
+  (subseq str 1 (1- (length str))))
diff --git a/uri.lisp b/uri.lisp
index e3b631d..1011b10 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,16 +7,43 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: uri.lisp,v 1.5 2003/08/08 09:03:45 kevin Exp $
+;;;; $Id: uri.lisp,v 1.6 2003/08/08 23:40:13 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)"
+(defun uri->recode-uri-sans-session-id (uri)
+  (let ((parsed-path (puri:uri-parsed-path uri)))
+    (cond
+     ((and (eq :absolute (first parsed-path))
+	   (is-raw-session-id (second parsed-path)))
+      (values (copy-uri uri :place t
+			      :parsed-path 
+			      (list* :absolute (cddr parsed-path)))
+	      (raw-session-id->session-id (second parsed-path))))
+     (t
+      (values uri nil)))))
+
+(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 url-session-key (url)
+  "Return a session key encoded in a URL"
+  nil)
+
+(defun compute-uris (req ent)
+  "Compute URI's of a request"
+  (compute-session req ent)
   (multiple-value-bind (page plists query) 
       (decode-url (puri:uri-path (request-raw-uri req)))
     (when page
@@ -27,8 +54,7 @@
       (when (null page)
 	(awhen (getf (request-plist req) :page)
 	       (setf (request-page req) it))))
-    (setf (request-uri-query req) query))
-  req)
+    (setf (request-uri-query req) query)))
 
 
 ;;; URI Functions
@@ -60,24 +86,23 @@
 
 
 
-#+ignore
-(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))
-
-
-(defun make-wol-url (page ent &optional plist)
-  (let ((url-plist (append (list :page page) plist))
+(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))))
-    (if (null plist)
-	(concatenate 'string prefix page ".lsp")
-      (concatenate 'string
-	prefix
-	+asp-header+
-	(concatenate 'string +plist-header+ 
-		     (plist-to-url-string url-plist))))))
+    (concatenate 'string
+      (if (and session
+		 (websession-key session)
+		 (eq :url (websession-method session)))
+	  (format nil "/~~~A~~/" (websession-key session))
+	"")
+      prefix
+      (if (null plist)
+	(concatenate 'string page ".html")
+	(concatenate 'string
+	  +asp-header+
+	  (concatenate 'string +plist-header+ 
+		       (plist-to-url-string url-plist)))))))
 
 
 ;; Property lists
-- 
2.34.1