Commit d50d635b authored by Dave Cooper's avatar Dave Cooper
Browse files

child paths still not working for cookiefied sessions

parent a0c70179
...@@ -291,7 +291,7 @@ instance at what time should the recovery instance expire?" ...@@ -291,7 +291,7 @@ instance at what time should the recovery instance expire?"
(gwl-make-part req ent part)))) (gwl-make-part req ent part))))
(defun gwl-make-part (&rest args) (apply #'gwl-make-object args)) (defun gwl-make-part (&rest args) (apply 'gwl-make-object args))
(defparameter *weak-objects* (glisp:make-weak-hash-table)) (defparameter *weak-objects* (glisp:make-weak-hash-table))
...@@ -333,7 +333,8 @@ instance at what time should the recovery instance expire?" ...@@ -333,7 +333,8 @@ instance at what time should the recovery instance expire?"
(first root-part-and-version))) (first root-part-and-version)))
(defun gwl-make-object (req ent part &key make-object-args share? skin (instance-id (if share? "share" (make-new-instance-id)))) (defun gwl-make-object (req ent part &key make-object-args share? skin
(instance-id (if share? "share" (make-new-instance-id))))
"Void. Used within the context of the body of a :function argument to Allegroserve's "Void. Used within the context of the body of a :function argument to Allegroserve's
publish function, makes an instance of the specified part and responds to the request publish function, makes an instance of the specified part and responds to the request
with a redirect to a URI representing the instance. with a redirect to a URI representing the instance.
...@@ -351,34 +352,47 @@ package-qualified object name\") ...@@ -351,34 +352,47 @@ package-qualified object name\")
:function #'(lambda(req ent) (gwl-make-object req ent \"calendar:assembly\"))) :function #'(lambda(req ent) (gwl-make-object req ent \"calendar:assembly\")))
</pre>" </pre>"
(let ((query (request-query req))) (let ((query (request-query req)))
(let ((part (or part (rest (assoc "part" query :test #'string-equal))))) (let* ((part (or part (rest (assoc "part" query :test #'string-equal))))
(part-type (read-safe-string part))
(session-urls? (assoc "session-urls" query :test #'string-equal))
(path (format nil "~a/~a" (package-name (symbol-package part-type))
part-type)))
(print-variables session-urls? query)
(let* ((current (gethash (make-keyword-sensitive instance-id) *instance-hash-table*)) (let* ((current (gethash (make-keyword-sensitive instance-id) *instance-hash-table*))
(skin (if skin (make-instance skin) t)) (skin (if skin (make-instance skin) t))
(root-part-and-version (root-part-and-version
(if (or (not share?) (not current)) (if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part) (list (apply #'make-object part-type
:instance-id instance-id ;;:query-toplevel query :instance-id instance-id ;;:query-toplevel query
:use-cookie? (not session-urls?)
:fixed-url-prefix (unless session-urls? path)
make-object-args) make-object-args)
*dummy-version*) *dummy-version*)
current))) current)))
(setf (gethash (first root-part-and-version) *weak-objects*) t) (setf (gethash (first root-part-and-version) *weak-objects*) t)
(setq root-part-and-version (append root-part-and-version (list skin))) (setq root-part-and-version (append root-part-and-version (list skin)))
(when (or (not share?) (not current)) (when (or (not share?) (not current))
(setf (gethash (make-keyword-sensitive instance-id) *instance-hash-table*) root-part-and-version)) (setf (gethash (make-keyword-sensitive instance-id) *instance-hash-table*) root-part-and-version))
(let ((object (first root-part-and-version))) (let ((object (first root-part-and-version)))
(when (typep object 'session-control-mixin) (when (typep object 'session-control-mixin)
(the-object object set-expires-at)) (the-object object set-expires-at))
(the-object object set-instantiation-time!) (the-object object set-instantiation-time!)
(the-object object set-time-last-touched!) (the-object object set-time-last-touched!)
(the-object object (set-remote-host! req :original? t))) (the-object object (set-remote-host! req :original? t)))
(with-http-response (req ent :response *response-found*) (with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :location) (setf (reply-header-slot-value req :location)
(format nil "~a" (the-object (first root-part-and-version) url))) (format nil "~a" (the-object (first root-part-and-version) url)))
(setf (reply-header-slot-value req :cache-control) "no-cache") (unless session-urls?
(setf (reply-header-slot-value req :pragma) "no-cache") (set-cookie-header req :name "iid"
(with-http-body (req ent))))))) :path (format nil "/~a" path)
:value instance-id))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)))))))
(defun publish-shared (&key path object-type host (server *wserver*) (defun publish-shared (&key path object-type host (server *wserver*)
......
...@@ -144,14 +144,15 @@ the browser in development mode). Defaults to NIL (the empty list)." ...@@ -144,14 +144,15 @@ the browser in development mode). Defaults to NIL (the empty list)."
($$tatu-object (the $$tatu) :settable) ($$tatu-object (the $$tatu) :settable)
($$ta2-object (the $$ta2) :settable) ($$ta2-object (the $$ta2) :settable)
(plain-url? nil :defaulting) (use-cookie? nil :defaulting)
(plain-url? (the use-cookie?) :defaulting)
(host nil :defaulting) (host nil :defaulting)
(query-toplevel nil :settable) (query-toplevel nil :settable))
)
:computed-slots :computed-slots
( (
...@@ -170,7 +171,9 @@ the browser in development mode). Defaults to NIL (the empty list)." ...@@ -170,7 +171,9 @@ the browser in development mode). Defaults to NIL (the empty list)."
("String. The web address in the current session which points at this page. Published on demand." ("String. The web address in the current session which points at this page. Published on demand."
url (let ((url url (let ((url
(if (the plain-url?) (format nil "/~a" (the (compute-url))) (if (the plain-url?) (format nil "~a/~a"
(if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the (compute-url)))
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "") (format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the :instance-id) (the (compute-url)))))) (the :instance-id) (the (compute-url))))))
(publish (publish
...@@ -179,11 +182,14 @@ the browser in development mode). Defaults to NIL (the empty list)." ...@@ -179,11 +182,14 @@ the browser in development mode). Defaults to NIL (the empty list)."
:host (the host) :host (the host)
:function #'(lambda (req ent) :function #'(lambda (req ent)
(the before-response!) (the before-response!)
(present-part req ent url :instance-id (when (the plain-url?) (present-part req ent url :instance-id (when (and (the plain-url?)
(not (the use-cookie?)))
(the instance-id)) (the instance-id))
:header-plist (the header-plist) :header-plist (the header-plist)
:fixed-prefix (the fixed-url-prefix)))) :fixed-prefix (the fixed-url-prefix))))
(pushnew url (gethash (make-keyword (the instance-id)) *url-hash-table*) :test #'string-equal)
(unless (the use-cookie?)
(pushnew url (gethash (make-keyword (the instance-id)) *url-hash-table*) :test #'string-equal))
(setf (gethash url *descriptive-url-hash*) (the root-path)) (setf (gethash url *descriptive-url-hash*) (the root-path))
(when *debug?* (print-variables url)) (when *debug?* (print-variables url))
...@@ -202,7 +208,7 @@ the submitted form fields automatically." ...@@ -202,7 +208,7 @@ the submitted form fields automatically."
:trickle-down-slots :trickle-down-slots
(tree-root instance-id plain-url? host home-page query-toplevel (tree-root instance-id plain-url? host home-page query-toplevel
fixed-url-prefix) fixed-url-prefix use-cookie?)
:hidden-objects :hidden-objects
(($$update :type 'update (($$update :type 'update
......
...@@ -78,11 +78,14 @@ FLAG -- fill in. ...@@ -78,11 +78,14 @@ FLAG -- fill in.
" "
(let ((%enctype% (gensym)) (let ((%enctype% (gensym))
(fixed-prefix (gensym))) (fixed-prefix (gensym)))
`(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data"))) `(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data")))
(,fixed-prefix (the fixed-url-prefix))) (,fixed-prefix (the fixed-url-prefix)))
(,@(if cl-who? '(with-html-output (*stream* nil :indent t)) (,@(if cl-who? '(with-html-output (*stream* nil :indent t))
'(html '(html
;;html-stream *stream* ;;html-stream *stream*
...@@ -90,7 +93,7 @@ FLAG -- fill in. ...@@ -90,7 +93,7 @@ FLAG -- fill in.
)) ))
((:form :method :|post| ((:form :method :|post|
:action (string-append (or ,fixed-prefix "") :action (string-append "" ;;(or ,fixed-prefix "")
(format nil (if ,local-anchor (format nil "/answer#~a" ,local-anchor) "/answer"))) (format nil (if ,local-anchor (format nil "/answer#~a" ,local-anchor) "/answer")))
:name ,(or name `(the root-path-string)) :name ,(or name `(the root-path-string))
...@@ -103,7 +106,9 @@ FLAG -- fill in. ...@@ -103,7 +106,9 @@ FLAG -- fill in.
((:input :type :hidden :name :|requestor| :value ,(if (null requestor) `(the url-encoded-root-path) ((:input :type :hidden :name :|requestor| :value ,(if (null requestor) `(the url-encoded-root-path)
`(the-object ,requestor url-encoded-root-path)))) `(the-object ,requestor url-encoded-root-path))))
((:input :type :hidden :name :|iid| :value (the instance-id))) ,@body))))) ((:input :type :hidden :name :|iid| :value (the instance-id)))
,@body)))))
......
...@@ -52,11 +52,20 @@ ...@@ -52,11 +52,20 @@
;; ;;
(defun present-part (req ent url &key instance-id header-plist fixed-prefix) (defun present-part (req ent url &key instance-id header-plist fixed-prefix)
(declare (ignore header-plist)) (declare (ignore header-plist))
(print-variables url)
(when fixed-prefix (setq url (subseq url (1+ (length fixed-prefix))))) (when fixed-prefix (setq url (subseq url (1+ (length fixed-prefix)))))
(let ((cookies (when *process-cookies?* (get-cookie-values req))) (print-variables url)
(let (;;(cookies (when *process-cookies?* (get-cookie-values req)))
(cookies (get-cookie-values req))
(components (split url #\/))) (components (split url #\/)))
(let* ((hash-entry (gethash (ensure-keyword (or instance-id (second components))) *instance-hash-table*)) (let* ((hash-entry (gethash (ensure-keyword (or instance-id
(cdr (assoc "iid" cookies :test #'string-equal))
(second components)))
*instance-hash-table*))
(root-object (first hash-entry)) (skin (third hash-entry)) (root-object (first hash-entry)) (skin (third hash-entry))
(root-path (multiple-value-bind (value found?) (gethash url *descriptive-url-hash*) (root-path (multiple-value-bind (value found?) (gethash url *descriptive-url-hash*)
(if found? value (if found? value
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment