Commit 9aec05df authored by Dave Cooper's avatar Dave Cooper

messy attempt at cookies

parent 46e50d25
......@@ -325,7 +325,11 @@ instance at what time should the recovery instance expire?"
(if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part)
:instance-id instance-id
make-object-args) *dummy-version*) current)))
make-object-args) *dummy-version*) current))
(object (first root-part-and-version)))
(the-object object (set-slot! :cookies-to-send (list :iid instance-id)))
(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))
......@@ -356,13 +360,19 @@ package-qualified object name\")
(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? (not (assoc "cookies" query :test #'string-equal)))
(path (format nil "~a/~a" (package-name (symbol-package part-type))
part-type)))
(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)))
......@@ -376,14 +386,25 @@ package-qualified object name\")
(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)))
(the-object object (set-remote-host! req :original? t))
(setq *obj* object)
(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)))
(when (the-object object use-cookie?)
(set-cookie-header req :name "iid"
:path (let ((prefix (the-object object fixed-url-prefix)))
(when prefix (string-append "/" prefix)))
: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*)
......
......@@ -149,8 +149,10 @@ the browser in development mode). Defaults to NIL (the empty list)."
($$tatu-object (the $$tatu) :settable)
($$ta2-object (the $$ta2) :settable)
(use-cookie? nil :defaulting)
(plain-url? nil :defaulting)
(plain-url? (the use-cookie?) :defaulting)
(host nil :defaulting)
......@@ -174,9 +176,11 @@ 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)))
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the :instance-id) (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))))))
(with-all-servers (server)
(publish
:path url
......@@ -185,10 +189,16 @@ 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)))))
;;
;; FLAG -- do we need to do this when use-cookie? is t?
;;
(pushnew url (gethash (make-keyword (the instance-id)) *url-hash-table*) :test #'string-equal)
(when (the fixed-url-prefix) (publish-fixed-prefix (the fixed-url-prefix)))
......@@ -210,7 +220,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
......
......@@ -46,21 +46,115 @@
(defun compute-object-type (components)
;;
;; FLAG -- actually compute this.
;;
'stripe::qoob)
(defun present-part (req ent url &key instance-id header-plist fixed-prefix)
(declare (ignore header-plist))
(when fixed-prefix (setq url (subseq url (1+ (length fixed-prefix)))))
(let ((cookies (when *process-cookies?* (get-cookie-values req)))
(components (split url #\/)))
(let* ((hash-entry (gethash (ensure-keyword (or instance-id (second components))) *instance-hash-table*))
(root-object (if hash-entry (first hash-entry) (%gwl-make-object% (compute-object-type components))))
(skin (third hash-entry))
(root-path (multiple-value-bind (value found?) (gethash url *descriptive-url-hash*)
(if found? value
(compute-root-path (reverse (if instance-id components (rest (rest components))))))))
(respondent (when root-object (the-object root-object (follow-root-path root-path)))))
(when *debug?* (print-variables components instance-id root-object root-path respondent))
;;
;; FLAG -- use actual application-root rather than global root here
;;
(when (and respondent (the-object respondent root)
(typep (the-object respondent root) 'session-control-mixin))
(the-object respondent root (set-expires-at)))
(when (and respondent (the-object respondent root)
(the-object respondent root (set-time-last-touched!))))
(when (and respondent (the-object respondent root)
(the-object respondent root (set-slot! :last-visited-root-path root-path))))
(when (and respondent (the-object respondent root)
(the-object respondent root (set-remote-host! req))))
(when (and *process-cookies?* respondent) (the-object respondent (set-slot! :cookies-received cookies)))
(when *process-cookies?* (the-object respondent process-cookies!))
(let ((header-plist (when respondent (the-object respondent header-plist)))
(security-ok? (when respondent (the-object respondent root do-security-check))))
(cond ((and respondent security-ok?)
(with-http-response (req ent :response (cond ((getf header-plist :location)
*response-moved-permanently*)
(t *response-ok*)))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(mapc #'(lambda(key val)
(setf (reply-header-slot-value req key) val))
(plist-keys header-plist) (plist-values header-plist))
(when *process-cookies?*
(mapc #'(lambda(plist)
(apply #'set-cookie-header req plist))
(the-object respondent cookies-to-send)))
(with-http-body (req ent)
(when (null (getf header-plist :location))
(let ((*req* req) (*ent* ent) (*skin* skin))
(when *debug?* (print-variables (socket:remote-host (net.aserve:request-socket req))))
(the-object respondent (:before-present!))
(let ((*stream* *html-stream*))
(the-object respondent (:write-html-sheet)))
(the-object respondent (:after-present!)))))))
(respondent
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(the-object respondent root security-check-failed write-html-sheet))))
(stripe:*fresh-session-url*
(with-http-response (req ent :response *response-moved-permanently*)
(setf (reply-header-slot-value req :location) stripe:*fresh-session-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))))
(t (net.aserve::failed-request req)))))))
;;
;; FLAG -- start using ensure-keyword here.
;;
#+nil
(defun present-part (req ent url &key instance-id header-plist fixed-prefix)
(declare (ignore header-plist))
(when fixed-prefix (setq url (subseq url (1+ (length fixed-prefix)))))
(let ((cookies (when *process-cookies?* (get-cookie-values req)))
(components (split url #\/)))
(let* ((hash-entry (gethash (ensure-keyword (or instance-id (second components))) *instance-hash-table*))
(let* ( ;;(cookies (when *process-cookies?* (get-cookie-values req)))
(components (split url #\/))
(cookies (unless (string-equal (first components) "sessions")
(get-cookie-values req))))
(let* ((hash-entry
(or (gethash (ensure-keyword (or instance-id
(cdr (assoc "iid" cookies :test #'string-equal))
(second components)))
#+nil (ensure-keyword (or instance-id (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
(compute-root-path (reverse (if instance-id components (rest (rest components))))))))
(compute-root-path (reverse (if instance-id components (rest (rest components))))))))
(respondent (when root-object (the-object root-object (follow-root-path root-path)))))
(when *debug?* (print-variables components instance-id root-object root-path respondent))
......
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