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

Merge branch 'cookie-sessions' of https://github.com/genworks/gendl into devo

parents 128623fd 2ba760ce
......@@ -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.~%")
......
......@@ -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,46 @@ 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)))
(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)))
(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*)
......
......@@ -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,22 @@
;;
(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*))
(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)))))
(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)))
*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
......
......@@ -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