Commit 2ba760ce authored by Dave Cooper's avatar Dave Cooper
Browse files

protect computed-slots from toplevel inputs, fix message-list to exclude...

protect computed-slots from toplevel inputs, fix message-list to exclude overidden slots in requested category, cleaned up cookie support with three items remaining on to-do list.
parent d50d635b
......@@ -75,6 +75,8 @@ o allow input of required input-slots.
:computed-slots
(
(use-cookie? nil)
(fixed-url-prefix nil)
(ui-specific-layout-js (when (the use-jquery?) "/static/gwl/js/tasty-initlayout-3.js"))
......
......@@ -21,9 +21,48 @@
(in-package :gdl)
(defparameter *warn-on-invalid-toplevel-inputs?* t)
(defun make-part (&rest args)
(apply #'make-object args))
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
:arguments (object-name \"Symbol. Should name a GDL object type.\"
arguments \"spliced-in plist. A plist of keyword symbols and values for initial <tt>input-slots</tt>.\")"
(let (*notify-cons*
(keys (plist-keys args))
(vals (plist-values args)))
(let ((object (apply #'make-instance
object-type
:allow-other-keys t
(list :%name% (list (format nil "~a" object-type) nil t)
:%parent% (list nil nil t)))))
(let ((input-slots
(append (the-object object (message-list :category :required-input-slots))
(the-object object (message-list :category :optional-input-slots))
(the-object object (message-list :category :settable-optional-input-slots))
(the-object object (message-list :category :defaulted-input-slots))
(the-object object (message-list :category :settable-defaulted-input-slots)))))
(mapc #'(lambda(key val)
(if (member key input-slots)
(setf (slot-value object (glisp:intern key :gdl-acc))
(list val nil t))
(when *warn-on-invalid-toplevel-inputs?*
(warn "~&~%~s is not a defined input-slot for ~s.
The argument ~s, and its value ~s, have been ignored
[you may (setq *warn-on-invalid-toplevel-inputs?* nil) to suppress this warning).~%~%"
key object-type key val)))) keys vals))
(setf (gdl-acc::%root% object) object
(gdl-acc::%toplevel-inputs% object) args) object)))
#+nil
(defun make-object (object-type &rest args)
"GDL Object. Instantiates an object with specified initial values for input-slots.
......
......@@ -625,7 +625,8 @@ otherwise it will be evaluated as a variable according to normal Lisp functional
(the (:follow-root-path
(mapcar #'(lambda (component) (list component 0)) reference-chain))))
("List of Keyword Symbols. Returns the messages (slots, objects, and functions) of this object, according to the filtering criteria as specified by the arguments.
("List of Keyword Symbols. Returns the messages (slots, objects, and functions) of this object, according to the filtering criteria as specified by the arguments.
:&key ((category :all) \"Keyword. Either <tt>:all</tt> or the individual category of
messages to be returned. This can be one of:
<tt><ul>
......@@ -656,7 +657,7 @@ the function returns NIL. If <tt>:normal</tt> (the default), then no filtering i
(&key (category :all) (message-type :global) return-category? base-part-type
(sort-order :unsorted) (filter :normal))
(let ((unfiltered
(gdl-rule::%message-list% self category message-type base-part-type)))
(gdl-rule::%message-list% self :all message-type base-part-type)))
(let* ((whittled (remove-duplicates unfiltered :key #'first :from-end t))
(chiseled (case category
(:all whittled)
......@@ -674,6 +675,7 @@ the function returns NIL. If <tt>:normal</tt> (the default), then no filtering i
(:by-category (sort filtered #'string-lessp :key #'second)))))
(if return-category? (flatten-pairs sorted) (mapcar #'first sorted))))))
("Void. Uncaches all cached data in slots and objects throughout the instance
tree from this node, forcing all code to run again the next time values are
......
......@@ -281,7 +281,8 @@ If you are interested in this effort we would love to hear from you at open-sour
#:room-report
#:*onclick-function*
#:*already-loaded-systems*
#:*packages-to-lock*))
#:*packages-to-lock*
#:*warn-on-invalid-toplevel-inputs?))
#-(or allegro lispworks sbcl ccl abcl ecl clisp) (error "Need package for mop:validate-superclass for currently running lisp.~%")
......
......@@ -358,8 +358,6 @@ package-qualified object name\")
(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
......@@ -381,18 +379,19 @@ 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))
(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)))))))
(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*)
......
......@@ -53,15 +53,17 @@
(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)))))
(when (and fixed-prefix
(string-equal (subseq url (1+ (length fixed-prefix))
(+ 1 (length fixed-prefix) (length "/sessions")))
"/sessions"))
(setq url (subseq url (1+ (length fixed-prefix)))))
(print-variables url)
(let (;;(cookies (when *process-cookies?* (get-cookie-values req)))
(cookies (get-cookie-values req))
(components (split url #\/)))
(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 (gethash (ensure-keyword (or instance-id
(cdr (assoc "iid" cookies :test #'string-equal))
(second components)))
......
......@@ -8,3 +8,21 @@ o Fix arguments between publish and publish-shared
o Add natural way to have a child or descendant be the page which
answers the published URL.
o Add support for cookies rather than URL rewriting:
o Detect when cookies are disabled in browser
o Report on all active sessions from a particular IP
o Enable copy/pasting URLs and default new session for missing cookie.
x Override default fixed-url-prefix (in base-html-sheet)
x Allow a default of old-style url rewriting instead of cookies (in base-html-sheet)
x Allow multiple instances of an app (maybe fixed-url as query arg)
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