Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
d50d635b
Commit
d50d635b
authored
Aug 12, 2014
by
Dave Cooper
Browse files
child paths still not working for cookiefied sessions
parent
a0c70179
Changes
4
Hide whitespace changes
Inline
Side-by-side
gwl/source/answer.lisp
View file @
d50d635b
...
...
@@ -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*
)
...
...
gwl/source/base-html-sheet.lisp
View file @
d50d635b
...
...
@@ -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
...
...
gwl/source/macros.lisp
View file @
d50d635b
...
...
@@ -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
)))))
...
...
gwl/source/new-urls.lisp
View file @
d50d635b
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment