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?"
(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))
......@@ -333,7 +333,8 @@ instance at what time should the recovery instance expire?"
(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
publish function, makes an instance of the specified part and responds to the request
with a redirect to a URI representing the instance.
......@@ -351,34 +352,47 @@ package-qualified object name\")
:function #'(lambda(req ent) (gwl-make-object req ent \"calendar:assembly\")))
</pre>"
(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*))
(skin (if skin (make-instance skin) t))
(root-part-and-version
(if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part)
:instance-id instance-id ;;:query-toplevel query
(list (apply #'make-object part-type
:instance-id instance-id ;;:query-toplevel query
:use-cookie? (not session-urls?)
:fixed-url-prefix (unless session-urls? path)
make-object-args)
*dummy-version*)
current)))
(setf (gethash (first root-part-and-version) *weak-objects*) t)
(setq root-part-and-version (append root-part-and-version (list skin)))
(when (or (not share?) (not current))
(setf (gethash (make-keyword-sensitive instance-id) *instance-hash-table*) root-part-and-version))
*dummy-version*)
current)))
(setf (gethash (first root-part-and-version) *weak-objects*) t)
(setq root-part-and-version (append root-part-and-version (list skin)))
(when (or (not share?) (not current))
(setf (gethash (make-keyword-sensitive instance-id) *instance-hash-table*) root-part-and-version))
(let ((object (first root-part-and-version)))
(when (typep object 'session-control-mixin)
(the-object object set-expires-at))
(the-object object set-instantiation-time!)
(the-object object set-time-last-touched!)
(the-object object (set-remote-host! req :original? t)))
(let ((object (first root-part-and-version)))
(when (typep object 'session-control-mixin)
(the-object object set-expires-at))
(the-object object set-instantiation-time!)
(the-object object set-time-last-touched!)
(the-object object (set-remote-host! req :original? t)))
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :location)
(format nil "~a" (the-object (first root-part-and-version) url)))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)))))))
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :location)
(format nil "~a" (the-object (first root-part-and-version) url)))
(unless session-urls?
(set-cookie-header req :name "iid"
: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*)
......
......@@ -144,14 +144,15 @@ the browser in development mode). Defaults to NIL (the empty list)."
($$tatu-object (the $$tatu) :settable)
($$ta2-object (the $$ta2) :settable)
(plain-url? nil :defaulting)
(use-cookie? nil :defaulting)
(plain-url? (the use-cookie?) :defaulting)
(host nil :defaulting)
(query-toplevel nil :settable)
)
(query-toplevel nil :settable))
:computed-slots
(
......@@ -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."
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)) "")
(the :instance-id) (the (compute-url))))))
(publish
......@@ -179,11 +182,14 @@ the browser in development mode). Defaults to NIL (the empty list)."
:host (the host)
:function #'(lambda (req ent)
(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))
:header-plist (the header-plist)
: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))
(when *debug?* (print-variables url))
......@@ -202,7 +208,7 @@ the submitted form fields automatically."
:trickle-down-slots
(tree-root instance-id plain-url? host home-page query-toplevel
fixed-url-prefix)
fixed-url-prefix use-cookie?)
:hidden-objects
(($$update :type 'update
......
......@@ -78,11 +78,14 @@ FLAG -- fill in.
"
(let ((%enctype% (gensym))
(fixed-prefix (gensym)))
`(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data")))
(,fixed-prefix (the fixed-url-prefix)))
(,@(if cl-who? '(with-html-output (*stream* nil :indent t))
'(html
;;html-stream *stream*
......@@ -90,7 +93,7 @@ FLAG -- fill in.
))
((: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")))
:name ,(or name `(the root-path-string))
......@@ -103,7 +106,9 @@ FLAG -- fill in.
((:input :type :hidden :name :|requestor| :value ,(if (null requestor) `(the 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 @@
;;
(defun present-part (req ent url &key instance-id header-plist fixed-prefix)
(declare (ignore header-plist))
(print-variables url)
(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 #\/)))
(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-path (multiple-value-bind (value found?) (gethash url *descriptive-url-hash*)
(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