-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
+x;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; 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
;;;; *************************************************************************
(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)))
(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)
(defvar *wol-stream* nil
"The output stream for the current request")
+
+(defconstant +length-session-id+ 24)
;;;; 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
;;;; *************************************************************************
(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)
(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)
: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)
(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)
(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)
(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)
((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)
;;;; 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
;;;; *************************************************************************
(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
(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))))
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; 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
(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
-#+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
projects / wol.git / commitdiff