Improved cookie support, and better session manager taking advantage of it
Slava Pestov
parent
02fdb4efca
commit
0b0e460857
|
|
@ -43,3 +43,10 @@ IN: calendar.format.tests
|
|||
] unit-test
|
||||
|
||||
[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test
|
||||
|
||||
[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test
|
||||
|
||||
[ "Sun, 4 May 2008 07:00:00" ] [
|
||||
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
|
||||
timestamp>string
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,50 @@
|
|||
USING: math math.parser kernel sequences io calendar
|
||||
USING: math math.parser kernel sequences io
|
||||
accessors arrays io.streams.string splitting
|
||||
combinators accessors debugger ;
|
||||
combinators accessors debugger
|
||||
calendar calendar.format.macros ;
|
||||
IN: calendar.format
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: pad-0000 number>string 4 CHAR: 0 pad-left ;
|
||||
|
||||
: pad-00000 number>string 5 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: write-0000 pad-0000 write ;
|
||||
|
||||
: write-00000 pad-00000 write ;
|
||||
|
||||
: hh hour>> write-00 ;
|
||||
|
||||
: mm minute>> write-00 ;
|
||||
|
||||
: ss second>> >integer write-00 ;
|
||||
|
||||
: D day>> number>string write ;
|
||||
|
||||
: DD day>> write-00 ;
|
||||
|
||||
: DAY day-of-week day-abbreviations3 nth write ;
|
||||
|
||||
: MM month>> write-00 ;
|
||||
|
||||
: MONTH month>> month-abbreviations nth write ;
|
||||
|
||||
: YYYY year>> write-0000 ;
|
||||
|
||||
: YYYYY year>> write-00000 ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-000 3 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
M: integer day. ( n -- )
|
||||
|
|
@ -25,7 +67,7 @@ M: array month. ( pair -- )
|
|||
] with each nl ;
|
||||
|
||||
M: timestamp month. ( timestamp -- )
|
||||
{ year>> month>> } get-slots 2array month. ;
|
||||
[ year>> ] [ month>> ] bi 2array month. ;
|
||||
|
||||
GENERIC: year. ( obj -- )
|
||||
|
||||
|
|
@ -35,28 +77,14 @@ M: integer year. ( n -- )
|
|||
M: timestamp year. ( timestamp -- )
|
||||
year>> year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: pad-0000 number>string 4 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: write-0000 pad-0000 write ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
dup day-of-week day-abbreviations3 nth write ", " write
|
||||
dup day>> number>string write bl
|
||||
dup month>> month-abbreviations nth write bl
|
||||
dup year>> number>string write bl
|
||||
dup hour>> write-00 ":" write
|
||||
dup minute>> write-00 ":" write
|
||||
second>> >integer write-00 ;
|
||||
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
|
||||
[ hh ] [ mm ] bi ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
dup instant <=> sgn {
|
||||
|
|
@ -69,9 +97,9 @@ M: timestamp year. ( timestamp -- )
|
|||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
dup (timestamp>string)
|
||||
" " write
|
||||
gmt-offset>> write-gmt-offset
|
||||
[ (timestamp>string) " " write ]
|
||||
[ gmt-offset>> write-gmt-offset ]
|
||||
bi
|
||||
] with-string-writer ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
|
|
@ -79,40 +107,32 @@ M: timestamp year. ( timestamp -- )
|
|||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822 ;
|
||||
|
||||
: (timestamp>cookie-string) ( timestamp -- )
|
||||
>gmt
|
||||
{ DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
|
||||
|
||||
: timestamp>cookie-string ( timestamp -- str )
|
||||
[ (timestamp>cookie-string) ] with-string-writer ;
|
||||
|
||||
: (write-rfc3339-gmt-offset) ( duration -- )
|
||||
[ hour>> write-00 CHAR: : write1 ]
|
||||
[ minute>> write-00 ] bi ;
|
||||
[ hh ":" write ] [ mm ] bi ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( duration -- )
|
||||
dup instant <=> sgn {
|
||||
{ 0 [ drop "Z" write ] }
|
||||
{ -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
|
||||
{ 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
|
||||
{ -1 [ "-" write before (write-rfc3339-gmt-offset) ] }
|
||||
{ 1 [ "+" write (write-rfc3339-gmt-offset) ] }
|
||||
} case ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
{
|
||||
[ year>> number>string write CHAR: - write1 ]
|
||||
[ month>> write-00 CHAR: - write1 ]
|
||||
[ day>> write-00 CHAR: T write1 ]
|
||||
[ hour>> write-00 CHAR: : write1 ]
|
||||
[ minute>> write-00 CHAR: : write1 ]
|
||||
[ second>> >fixnum write-00 ]
|
||||
YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
|
||||
[ gmt-offset>> write-rfc3339-gmt-offset ]
|
||||
} cleave ;
|
||||
} formatted ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
[ (timestamp>rfc3339) ] with-string-writer ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-000 3 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
: signed-gmt-offset ( dt ch -- dt' )
|
||||
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
|
||||
|
||||
|
|
@ -142,17 +162,18 @@ M: timestamp year. ( timestamp -- )
|
|||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[ (rfc3339>timestamp) ] with-string-reader ;
|
||||
|
||||
ERROR: invalid-rfc822-date ;
|
||||
ERROR: invalid-timestamp-format ;
|
||||
|
||||
: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
|
||||
: check-timestamp ( obj/f -- obj )
|
||||
[ invalid-timestamp-format ] unless* ;
|
||||
|
||||
: read-token ( seps -- token )
|
||||
[ read-until ] keep member? check-rfc822-date drop ;
|
||||
[ read-until ] keep member? check-timestamp drop ;
|
||||
|
||||
: read-sp ( -- token ) " " read-token ;
|
||||
|
||||
: checked-number ( str -- n )
|
||||
string>number check-rfc822-date ;
|
||||
string>number check-timestamp ;
|
||||
|
||||
: parse-rfc822-gmt-offset ( string -- dt )
|
||||
dup "GMT" = [ drop instant ] [
|
||||
|
|
@ -163,10 +184,10 @@ ERROR: invalid-rfc822-date ;
|
|||
|
||||
: (rfc822>timestamp) ( -- timestamp )
|
||||
timestamp new
|
||||
"," read-token day-abbreviations3 member? check-rfc822-date drop
|
||||
"," read-token day-abbreviations3 member? check-timestamp drop
|
||||
read1 CHAR: \s assert=
|
||||
read-sp checked-number >>day
|
||||
read-sp month-abbreviations index check-rfc822-date >>month
|
||||
read-sp month-abbreviations index check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
|
|
@ -176,6 +197,42 @@ ERROR: invalid-rfc822-date ;
|
|||
: rfc822>timestamp ( str -- timestamp )
|
||||
[ (rfc822>timestamp) ] with-string-reader ;
|
||||
|
||||
: (cookie-string>timestamp-1) ( -- timestamp )
|
||||
timestamp new
|
||||
"," read-token day-abbreviations3 member? check-timestamp drop
|
||||
read1 CHAR: \s assert=
|
||||
"-" read-token checked-number >>day
|
||||
"-" read-token month-abbreviations index check-timestamp >>month
|
||||
read-sp checked-number >>year
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
" " read-token checked-number >>second
|
||||
readln parse-rfc822-gmt-offset >>gmt-offset ;
|
||||
|
||||
: cookie-string>timestamp-1 ( str -- timestamp )
|
||||
[ (cookie-string>timestamp-1) ] with-string-reader ;
|
||||
|
||||
: (cookie-string>timestamp-2) ( -- timestamp )
|
||||
timestamp new
|
||||
read-sp day-abbreviations3 member? check-timestamp drop
|
||||
read-sp month-abbreviations index check-timestamp >>month
|
||||
read-sp checked-number >>day
|
||||
":" read-token checked-number >>hour
|
||||
":" read-token checked-number >>minute
|
||||
" " read-token checked-number >>second
|
||||
read-sp checked-number >>year
|
||||
readln parse-rfc822-gmt-offset >>gmt-offset ;
|
||||
|
||||
: cookie-string>timestamp-2 ( str -- timestamp )
|
||||
[ (cookie-string>timestamp-2) ] with-string-reader ;
|
||||
|
||||
: cookie-string>timestamp ( str -- timestamp )
|
||||
{
|
||||
[ cookie-string>timestamp-1 ]
|
||||
[ cookie-string>timestamp-2 ]
|
||||
[ rfc822>timestamp ]
|
||||
} attempt-all-quots ;
|
||||
|
||||
: (ymdhms>timestamp) ( -- timestamp )
|
||||
read-ymd " " expect read-hms instant <timestamp> ;
|
||||
|
||||
|
|
@ -195,41 +252,30 @@ ERROR: invalid-rfc822-date ;
|
|||
[ (ymd>timestamp) ] with-string-reader ;
|
||||
|
||||
: (timestamp>ymd) ( timestamp -- )
|
||||
dup timestamp-year write-0000
|
||||
"-" write
|
||||
dup timestamp-month write-00
|
||||
"-" write
|
||||
timestamp-day write-00 ;
|
||||
{ YYYY "-" MM "-" DD } formatted ;
|
||||
|
||||
: timestamp>ymd ( timestamp -- str )
|
||||
[ (timestamp>ymd) ] with-string-writer ;
|
||||
|
||||
: (timestamp>hms)
|
||||
dup timestamp-hour write-00
|
||||
":" write
|
||||
dup timestamp-minute write-00
|
||||
":" write
|
||||
timestamp-second >integer write-00 ;
|
||||
{ hh ":" mm ":" ss } formatted ;
|
||||
|
||||
: timestamp>hms ( timestamp -- str )
|
||||
[ (timestamp>hms) ] with-string-writer ;
|
||||
|
||||
: timestamp>ymdhms ( timestamp -- str )
|
||||
>gmt
|
||||
[
|
||||
dup (timestamp>ymd)
|
||||
" " write
|
||||
(timestamp>hms)
|
||||
>gmt
|
||||
{ (timestamp>ymd) " " (timestamp>hms) } formatted
|
||||
] with-string-writer ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
[ month>> month-abbreviations nth write ] keep bl
|
||||
[ day>> number>string 2 32 pad-left write ] keep bl
|
||||
dup now [ year>> ] bi@ = [
|
||||
[ hour>> write-00 ] keep ":" write
|
||||
minute>> write-00
|
||||
] [
|
||||
year>> number>string 5 32 pad-left write
|
||||
] if
|
||||
{
|
||||
MONTH " " DD " "
|
||||
[
|
||||
dup now [ year>> ] bi@ =
|
||||
[ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
|
||||
]
|
||||
} formatted
|
||||
] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
USING: tools.test kernel ;
|
||||
IN: calendar.format.macros
|
||||
|
||||
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
|
||||
|
||||
[ 2 ] [ { [ 1 throw ] [ 2 ] } attempt-all-quots ] unit-test
|
||||
|
||||
[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with
|
||||
|
||||
: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ;
|
||||
|
||||
\ compiled-test-1 must-infer
|
||||
|
||||
[ 2 ] [ compiled-test-1 ] unit-test
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
USING: macros kernel words quotations io sequences combinators
|
||||
continuations ;
|
||||
IN: calendar.format.macros
|
||||
|
||||
MACRO: formatted ( spec -- )
|
||||
[
|
||||
{
|
||||
{ [ dup word? ] [ 1quotation ] }
|
||||
{ [ dup quotation? ] [ ] }
|
||||
[ [ nip write ] curry [ ] like ]
|
||||
} cond
|
||||
] map [ cleave ] curry ;
|
||||
|
||||
MACRO: attempt-all-quots ( quots -- )
|
||||
dup length 1 = [ first ] [
|
||||
unclip swap
|
||||
[ nip attempt-all-quots ] curry
|
||||
[ recover ] 2curry
|
||||
] if ;
|
||||
|
|
@ -158,7 +158,7 @@ test-db [
|
|||
"extra/http/test" resource-path <static> >>default
|
||||
"nested" add-responder
|
||||
<action>
|
||||
[ "redirect-loop" f <permanent-redirect> ] >>display
|
||||
[ "redirect-loop" f <standard-redirect> ] >>display
|
||||
"redirect-loop" add-responder
|
||||
main-responder set
|
||||
|
||||
|
|
|
|||
|
|
@ -135,11 +135,12 @@ IN: http
|
|||
] { } assoc>map
|
||||
"&" join ;
|
||||
|
||||
TUPLE: cookie name value path domain expires http-only ;
|
||||
TUPLE: cookie name value path domain expires max-age http-only ;
|
||||
|
||||
: <cookie> ( value name -- cookie )
|
||||
cookie new
|
||||
swap >>name swap >>value ;
|
||||
swap >>name
|
||||
swap >>value ;
|
||||
|
||||
: parse-cookies ( string -- seq )
|
||||
[
|
||||
|
|
@ -147,7 +148,8 @@ TUPLE: cookie name value path domain expires http-only ;
|
|||
|
||||
";" split [
|
||||
[ blank? ] trim "=" split1 swap >lower {
|
||||
{ "expires" [ >>expires ] }
|
||||
{ "expires" [ cookie-string>timestamp >>expires ] }
|
||||
{ "max-age" [ string>number seconds ] }
|
||||
{ "domain" [ >>domain ] }
|
||||
{ "path" [ >>path ] }
|
||||
{ "httponly" [ drop t >>http-only ] }
|
||||
|
|
@ -163,7 +165,14 @@ TUPLE: cookie name value path domain expires http-only ;
|
|||
{
|
||||
{ f [ drop ] }
|
||||
{ t [ , ] }
|
||||
[ "=" swap 3append , ]
|
||||
[
|
||||
{
|
||||
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
|
||||
{ [ dup duration? ] [ dt>seconds number>string ] }
|
||||
[ ]
|
||||
} cond
|
||||
"=" swap 3append ,
|
||||
]
|
||||
} case ;
|
||||
|
||||
: unparse-cookie ( cookie -- strings )
|
||||
|
|
@ -172,6 +181,7 @@ TUPLE: cookie name value path domain expires http-only ;
|
|||
"path" over path>> (unparse-cookie)
|
||||
"domain" over domain>> (unparse-cookie)
|
||||
"expires" over expires>> (unparse-cookie)
|
||||
"max-age" over max-age>> (unparse-cookie)
|
||||
"httponly" over http-only>> (unparse-cookie)
|
||||
drop
|
||||
] { } make ;
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ blah
|
|||
;
|
||||
|
||||
[ 25 ] [
|
||||
init-request
|
||||
action-request-test-1 lf>crlf
|
||||
[ read-request ] with-string-reader
|
||||
request set
|
||||
|
|
|
|||
|
|
@ -37,16 +37,19 @@ TUPLE: action init display submit get-params post-params ;
|
|||
: validation-failed ( -- * )
|
||||
action get display>> call exit-with ;
|
||||
|
||||
M: action call-responder ( path action -- response )
|
||||
M: action call-responder* ( path action -- response )
|
||||
'[
|
||||
, [ CHAR: / = ] right-trim empty? [
|
||||
, action set
|
||||
request-params params set
|
||||
request get method>> {
|
||||
request get
|
||||
[ request-params params set ]
|
||||
[
|
||||
method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] bi
|
||||
] [
|
||||
<404>
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -36,6 +36,6 @@ C: <basic-auth> basic-auth
|
|||
: logged-in? ( request responder -- ? )
|
||||
provider>> swap "authorization" header authorization-ok? ;
|
||||
|
||||
M: basic-auth call-responder ( request path responder -- response )
|
||||
M: basic-auth call-responder* ( request path responder -- response )
|
||||
pick over logged-in?
|
||||
[ call-next-method ] [ 2nip realm>> <401> ] if ;
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@
|
|||
|
||||
<t:title>Edit Profile</t:title>
|
||||
|
||||
<t:form action="edit-profile">
|
||||
<t:form t:action="edit-profile">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:view component="username" /></td>
|
||||
<td><t:view t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit component="realname" /></td>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">Current password:</th>
|
||||
<td><t:edit component="password" /></td>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -35,12 +35,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit component="new-password" /></td>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit component="verify-password" /></td>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit component="email" /></td>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -63,11 +63,11 @@
|
|||
<p>
|
||||
<input type="submit" value="Update" />
|
||||
|
||||
<t:if var="http.server.auth.login:login-failed?">
|
||||
<t:if t:var="http.server.auth.login:login-failed?">
|
||||
<t:error>invalid password</t:error>
|
||||
</t:if>
|
||||
|
||||
<t:if var="http.server.auth.login:password-mismatch?">
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
|
|
|||
|
|
@ -331,7 +331,7 @@ SYMBOL: lost-password-from
|
|||
<action>
|
||||
[
|
||||
f logged-in-user sset
|
||||
"$login/login" f <permanent-redirect>
|
||||
"$login/login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
|
|
@ -342,19 +342,17 @@ C: <protected> protected
|
|||
|
||||
: show-login-page ( -- response )
|
||||
begin-flow
|
||||
"$login/login" f <temporary-redirect> ;
|
||||
"$login/login" f <standard-redirect> ;
|
||||
|
||||
M: protected call-responder ( path responder -- response )
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
logged-in-user sget dup [
|
||||
save-user-after
|
||||
call-next-method
|
||||
] [
|
||||
3drop
|
||||
request get method>> { "GET" "HEAD" } member?
|
||||
[ show-login-page ] [ <400> ] if
|
||||
3drop show-login-page
|
||||
] if ;
|
||||
|
||||
M: login call-responder ( path responder -- response )
|
||||
M: login call-responder* ( path responder -- response )
|
||||
dup login set
|
||||
call-next-method ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@
|
|||
|
||||
<t:title>Login</t:title>
|
||||
|
||||
<t:form action="login">
|
||||
<t:form t:action="login">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit component="username" /></td>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit component="password" /></td>
|
||||
<td><t:edit t:component="password" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
@ -24,7 +24,7 @@
|
|||
|
||||
<input type="submit" value="Log in" />
|
||||
|
||||
<t:if var="http.server.auth.login:login-failed?">
|
||||
<t:if t:var="http.server.auth.login:login-failed?">
|
||||
<t:error>invalid username or password</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
|
@ -33,11 +33,11 @@
|
|||
|
||||
<p>
|
||||
<t:if code="http.server.auth.login:login-failed?">
|
||||
<t:a href="register">Register</t:a>
|
||||
<t:a t:href="register">Register</t:a>
|
||||
</t:if>
|
||||
|
|
||||
<t:if code="http.server.auth.login:allow-password-recovery?">
|
||||
<t:a href="recover-password">Recover Password</t:a>
|
||||
<t:a t:href="recover-password">Recover Password</t:a>
|
||||
</t:if>
|
||||
</p>
|
||||
|
||||
|
|
|
|||
|
|
@ -6,23 +6,23 @@
|
|||
|
||||
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
|
||||
|
||||
<t:form action="recover-password">
|
||||
<t:form t:action="recover-password">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit component="username" /></td>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit component="email" /></td>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:edit component="captcha" /></td>
|
||||
<td><t:edit t:component="captcha" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
|
|||
|
|
@ -6,21 +6,21 @@
|
|||
|
||||
<p>Choose a new password for your account.</p>
|
||||
|
||||
<t:form action="new-password">
|
||||
<t:form t:action="new-password">
|
||||
|
||||
<table>
|
||||
|
||||
<t:edit component="username" />
|
||||
<t:edit component="ticket" />
|
||||
<t:edit t:component="username" />
|
||||
<t:edit t:component="ticket" />
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit component="new-password" /></td>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify password:</th>
|
||||
<td><t:edit component="verify-password" /></td>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -33,7 +33,7 @@
|
|||
<p>
|
||||
<input type="submit" value="Set password" />
|
||||
|
||||
<t:if var="http.server.auth.login:password-mismatch?">
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
|
|
|||
|
|
@ -4,6 +4,6 @@
|
|||
|
||||
<t:title>Recover lost password: step 4 of 4</t:title>
|
||||
|
||||
<p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>
|
||||
<p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@
|
|||
|
||||
<t:title>New User Registration</t:title>
|
||||
|
||||
<t:form action="register">
|
||||
<t:form t:action="register">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit component="username" /></td>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit component="realname" /></td>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -25,12 +25,12 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">Password:</th>
|
||||
<td><t:edit component="new-password" /></td>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit component="verify-password" /></td>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -40,7 +40,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit component="email" /></td>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label">Captcha:</th>
|
||||
<td><t:edit component="captcha" /></td>
|
||||
<td><t:edit t:component="captcha" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
|
|
@ -64,11 +64,11 @@
|
|||
|
||||
<input type="submit" value="Register" />
|
||||
|
||||
<t:if var="http.server.auth.login:user-exists?">
|
||||
<t:if t:var="http.server.auth.login:user-exists?">
|
||||
<t:error>username taken</t:error>
|
||||
</t:if>
|
||||
|
||||
<t:if var="http.server.auth.login:password-mismatch?">
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: f call-template* drop call-next-template ;
|
|||
bi*
|
||||
] with-scope ; inline
|
||||
|
||||
M: boilerplate call-responder
|
||||
M: boilerplate call-responder*
|
||||
tuck call-next-method
|
||||
dup "content-type" header "text/html" = [
|
||||
clone swap template>>
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ SYMBOL: current-show
|
|||
: resuming-callback ( responder request -- id )
|
||||
cont-id query-param swap callbacks>> at ;
|
||||
|
||||
M: callback-responder call-responder ( path responder -- response )
|
||||
M: callback-responder call-responder* ( path responder -- response )
|
||||
'[
|
||||
, ,
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: http.server.crud
|
|||
[ form view-form ] >>display ;
|
||||
|
||||
: <id-redirect> ( id next -- response )
|
||||
swap number>string "id" associate <permanent-redirect> ;
|
||||
swap number>string "id" associate <standard-redirect> ;
|
||||
|
||||
:: <edit-action> ( form ctor next -- action )
|
||||
<action>
|
||||
|
|
@ -53,7 +53,7 @@ IN: http.server.crud
|
|||
[
|
||||
"id" get ctor call delete-tuple
|
||||
|
||||
next f <permanent-redirect>
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <list-action> ( form ctor -- action )
|
||||
|
|
|
|||
|
|
@ -12,5 +12,5 @@ C: <db-persistence> db-persistence
|
|||
[ db>> ] [ params>> ] bi make-db db-open
|
||||
[ db set ] [ add-always-destructor ] bi ;
|
||||
|
||||
M: db-persistence call-responder
|
||||
M: db-persistence call-responder*
|
||||
[ connect-db ] [ call-next-method ] bi ;
|
||||
|
|
|
|||
|
|
@ -10,12 +10,25 @@ TUPLE: flows < filter-responder ;
|
|||
C: <flows> flows
|
||||
|
||||
: begin-flow* ( -- id )
|
||||
request get [ path>> ] [ query>> ] bi 2array
|
||||
request get
|
||||
[ path>> ] [ request-params ] [ method>> ] tri 3array
|
||||
flows sget set-at-unique
|
||||
session-changed ;
|
||||
|
||||
: end-flow-post ( path params -- response )
|
||||
request [
|
||||
clone
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>path
|
||||
] change
|
||||
request get path>> split-path
|
||||
flows get responder>> call-responder ;
|
||||
|
||||
: end-flow* ( default id -- response )
|
||||
flows sget at [ first2 ] [ f ] ?if <permanent-redirect> ;
|
||||
flows sget at
|
||||
[ first3 "POST" = [ end-flow-post ] [ <standard-redirect> ] if ]
|
||||
[ f <standard-redirect> ] ?if ;
|
||||
|
||||
SYMBOL: flow-id
|
||||
|
||||
|
|
@ -39,10 +52,11 @@ SYMBOL: flow-id
|
|||
input/>
|
||||
] when* ;
|
||||
|
||||
M: flows call-responder
|
||||
M: flows call-responder*
|
||||
dup flows set
|
||||
[ add-flow-id ] add-link-hook
|
||||
[ flow-form-field ] add-form-hook
|
||||
flow-id-key request-params at flow-id set
|
||||
flow-id-key request get request-params at flow-id set
|
||||
call-next-method ;
|
||||
|
||||
M: flows init-session*
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ TUPLE: mock-responder path ;
|
|||
|
||||
C: <mock-responder> mock-responder
|
||||
|
||||
M: mock-responder call-responder
|
||||
M: mock-responder call-responder*
|
||||
nip
|
||||
path>> on
|
||||
"text/plain" <content> ;
|
||||
|
|
@ -81,7 +81,7 @@ TUPLE: path-check-responder ;
|
|||
|
||||
C: <path-check-responder> path-check-responder
|
||||
|
||||
M: path-check-responder call-responder
|
||||
M: path-check-responder call-responder*
|
||||
drop
|
||||
"text/plain" <content> swap >array >>body ;
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ TUPLE: base-path-check-responder ;
|
|||
|
||||
C: <base-path-check-responder> base-path-check-responder
|
||||
|
||||
M: base-path-check-responder call-responder
|
||||
M: base-path-check-responder call-responder*
|
||||
2drop
|
||||
"$funny-dispatcher" resolve-base-path
|
||||
"text/plain" <content> swap >>body ;
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: http.server
|
|||
|
||||
! path is a sequence of path component strings
|
||||
|
||||
GENERIC: call-responder ( path responder -- response )
|
||||
GENERIC: call-responder* ( path responder -- response )
|
||||
|
||||
: request-params ( -- assoc )
|
||||
request get dup method>> {
|
||||
: request-params ( request -- assoc )
|
||||
dup method>> {
|
||||
{ "GET" [ query>> ] }
|
||||
{ "HEAD" [ query>> ] }
|
||||
{ "POST" [ post-data>> ] }
|
||||
|
|
@ -28,7 +28,7 @@ TUPLE: trivial-responder response ;
|
|||
|
||||
C: <trivial-responder> trivial-responder
|
||||
|
||||
M: trivial-responder call-responder nip response>> call ;
|
||||
M: trivial-responder call-responder* nip response>> call ;
|
||||
|
||||
: trivial-response-body ( code message -- )
|
||||
<html>
|
||||
|
|
@ -67,6 +67,9 @@ SYMBOL: base-paths
|
|||
[ invert-slice ] [ class word-name ] bi*
|
||||
base-paths get set-at ;
|
||||
|
||||
: call-responder ( path responder -- response )
|
||||
[ add-base-path ] [ call-responder* ] 2bi ;
|
||||
|
||||
SYMBOL: link-hook
|
||||
|
||||
: add-link-hook ( quot -- )
|
||||
|
|
@ -139,6 +142,10 @@ SYMBOL: form-hook
|
|||
: <temporary-redirect> ( to query -- response )
|
||||
307 "Temporary Redirect" <redirect> ;
|
||||
|
||||
: <standard-redirect> ( to query -- response )
|
||||
request get method>> "POST" =
|
||||
[ <permanent-redirect> ] [ <temporary-redirect> ] if ;
|
||||
|
||||
TUPLE: dispatcher default responders ;
|
||||
|
||||
: new-dispatcher ( class -- dispatcher )
|
||||
|
|
@ -158,8 +165,8 @@ TUPLE: dispatcher default responders ;
|
|||
[ >r drop 1 tail-slice r> ] [ drop default>> ] if
|
||||
] if ;
|
||||
|
||||
M: dispatcher call-responder ( path dispatcher -- response )
|
||||
[ add-base-path ] [ find-responder call-responder ] 2bi ;
|
||||
M: dispatcher call-responder* ( path dispatcher -- response )
|
||||
find-responder call-responder ;
|
||||
|
||||
TUPLE: vhost-dispatcher default responders ;
|
||||
|
||||
|
|
@ -170,7 +177,7 @@ TUPLE: vhost-dispatcher default responders ;
|
|||
request get host>> over responders>> at*
|
||||
[ nip ] [ drop default>> ] if ;
|
||||
|
||||
M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
||||
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
|
||||
find-vhost call-responder ;
|
||||
|
||||
: add-responder ( dispatcher responder path -- dispatcher )
|
||||
|
|
@ -183,7 +190,7 @@ M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
|||
|
||||
TUPLE: filter-responder responder ;
|
||||
|
||||
M: filter-responder call-responder
|
||||
M: filter-responder call-responder*
|
||||
responder>> call-responder ;
|
||||
|
||||
SYMBOL: main-responder
|
||||
|
|
@ -234,14 +241,16 @@ SYMBOL: exit-continuation
|
|||
: split-path ( string -- path )
|
||||
"/" split [ empty? not ] subset ;
|
||||
|
||||
: do-request ( request -- response )
|
||||
[
|
||||
: init-request ( -- )
|
||||
H{ } clone base-paths set
|
||||
[ ] link-hook set
|
||||
[ ] form-hook set
|
||||
[ ] form-hook set ;
|
||||
|
||||
[ log-request ]
|
||||
: do-request ( request -- response )
|
||||
[
|
||||
init-request
|
||||
[ request set ]
|
||||
[ log-request ]
|
||||
[ path>> split-path main-responder get call-responder ] tri
|
||||
[ <404> ] unless*
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ C: <foo> foo
|
|||
|
||||
M: foo init-session* drop 0 "x" sset ;
|
||||
|
||||
M: foo call-responder
|
||||
M: foo call-responder*
|
||||
2drop
|
||||
"x" [ 1+ ] schange
|
||||
"text/html" <content> [ "x" sget pprint ] >>body ;
|
||||
|
|
@ -53,8 +53,15 @@ M: foo call-responder
|
|||
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
|
||||
init-request
|
||||
init-sessions-table
|
||||
|
||||
[ ] [
|
||||
<foo> <session-manager>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
] unit-test
|
||||
|
||||
[
|
||||
empty-session
|
||||
123 >>id session set
|
||||
|
|
@ -70,12 +77,6 @@ M: foo call-responder
|
|||
[ t ] [ session get changed?>> ] unit-test
|
||||
] with-scope
|
||||
|
||||
[ ] [
|
||||
<foo> <session-manager>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
session-manager get begin-session id>>
|
||||
session-manager get sessions>> get-session session?
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ http.server.sessions.storage.null
|
|||
html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
TUPLE: session id expiry namespace changed? ;
|
||||
TUPLE: session id expires namespace changed? ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new
|
||||
|
|
@ -24,10 +24,13 @@ M: dispatcher init-session* default>> init-session* ;
|
|||
|
||||
M: filter-responder init-session* responder>> init-session* ;
|
||||
|
||||
TUPLE: session-manager < filter-responder sessions ;
|
||||
TUPLE: session-manager < filter-responder sessions timeout domain ;
|
||||
|
||||
: <session-manager> ( responder -- responder' )
|
||||
null-sessions session-manager boa ;
|
||||
session-manager new
|
||||
swap >>responder
|
||||
null-sessions >>sessions
|
||||
20 minutes >>timeout ;
|
||||
|
||||
: (session-changed) ( session -- )
|
||||
t >>changed? drop ;
|
||||
|
|
@ -47,18 +50,14 @@ TUPLE: session-manager < filter-responder sessions ;
|
|||
[ namespace>> swap change-at ] keep
|
||||
(session-changed) ; inline
|
||||
|
||||
: sessions session-manager get sessions>> ;
|
||||
|
||||
: init-session ( session managed -- )
|
||||
>r session r> '[ , init-session* ] with-variable ;
|
||||
|
||||
: timeout 20 minutes ;
|
||||
|
||||
: cutoff-time ( -- time )
|
||||
now timeout time+ timestamp>millis ;
|
||||
session-manager get timeout>> from-now timestamp>millis ;
|
||||
|
||||
: touch-session ( session -- )
|
||||
cutoff-time >>expiry drop ;
|
||||
cutoff-time >>expires drop ;
|
||||
|
||||
: empty-session ( -- session )
|
||||
f <session>
|
||||
|
|
@ -73,21 +72,24 @@ TUPLE: session-manager < filter-responder sessions ;
|
|||
2tri ;
|
||||
|
||||
! Destructor
|
||||
TUPLE: session-saver session ;
|
||||
TUPLE: session-saver manager session ;
|
||||
|
||||
C: <session-saver> session-saver
|
||||
|
||||
M: session-saver dispose
|
||||
session>> dup changed?>> [
|
||||
[ touch-session ] [ sessions update-session ] bi
|
||||
] [ drop ] if ;
|
||||
[ session>> ] [ manager>> sessions>> ] bi
|
||||
over changed?>> [
|
||||
[ drop touch-session ] [ update-session ] 2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: save-session-after ( session -- )
|
||||
: save-session-after ( manager session -- )
|
||||
<session-saver> add-always-destructor ;
|
||||
|
||||
: existing-session ( path responder session -- response )
|
||||
[ session set ] [ save-session-after ] bi
|
||||
[ session-manager set ] [ responder>> call-responder ] bi ;
|
||||
: existing-session ( path manager session -- response )
|
||||
[ nip session set ]
|
||||
[ save-session-after ]
|
||||
[ drop responder>> ] 2tri
|
||||
call-responder ;
|
||||
|
||||
: session-id-key "factorsessid" ;
|
||||
|
||||
|
|
@ -109,13 +111,13 @@ M: session-saver dispose
|
|||
>r request-session-id r> sessions>> get-session ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
session-id-key <cookie> ;
|
||||
session-id-key <cookie>
|
||||
"$session-manager" resolve-base-path >>path
|
||||
session-manager get timeout>> from-now >>expires
|
||||
session-manager get domain>> >>domain ;
|
||||
|
||||
: new-session ( path responder -- response )
|
||||
dup begin-session
|
||||
[ existing-session ]
|
||||
[ id>> number>string <session-cookie> ] bi
|
||||
put-cookie ;
|
||||
: put-session-cookie ( response -- response' )
|
||||
session get id>> number>string <session-cookie> put-cookie ;
|
||||
|
||||
: session-form-field ( -- )
|
||||
<input
|
||||
|
|
@ -124,6 +126,8 @@ M: session-saver dispose
|
|||
session get id>> number>string =value
|
||||
input/> ;
|
||||
|
||||
M: session-manager call-responder ( path responder -- response )
|
||||
M: session-manager call-responder* ( path responder -- response )
|
||||
[ session-form-field ] add-form-hook
|
||||
dup request-session [ existing-session ] [ new-session ] if* ;
|
||||
dup session-manager set
|
||||
dup request-session [ dup begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ session "SESSIONS"
|
|||
{
|
||||
! { "id" "ID" +random-id+ system-random-generator }
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "expiry" "EXPIRY" BIG-INTEGER +not-null+ }
|
||||
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
|
|
@ -31,7 +31,7 @@ M: sessions-in-db new-session ( session storage -- )
|
|||
|
||||
: expired-sessions ( -- session )
|
||||
f <session>
|
||||
USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expiry
|
||||
USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires
|
||||
select-tuples ;
|
||||
|
||||
: start-expiring-sessions ( db seq -- )
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ TUPLE: file-responder root hook special ;
|
|||
find-index [ serve-file ] [ list-directory ] ?if
|
||||
] [
|
||||
drop
|
||||
request get path>> "/" append f <permanent-redirect>
|
||||
request get path>> "/" append f <standard-redirect>
|
||||
] if ;
|
||||
|
||||
: serve-object ( filename -- response )
|
||||
|
|
@ -86,7 +86,7 @@ TUPLE: file-responder root hook special ;
|
|||
[ drop <404> ]
|
||||
if ;
|
||||
|
||||
M: file-responder call-responder ( path responder -- response )
|
||||
M: file-responder call-responder* ( path responder -- response )
|
||||
file-responder set
|
||||
".." over member?
|
||||
[ drop <400> ] [ "/" join serve-object ] if ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors kernel sequences combinators kernel namespaces
|
||||
classes.tuple assocs splitting words arrays
|
||||
classes.tuple assocs splitting words arrays memoize
|
||||
io io.files io.encodings.utf8 html.elements unicode.case
|
||||
tuple-syntax xml xml.data xml.writer xml.utilities
|
||||
http.server
|
||||
|
|
@ -19,23 +19,31 @@ C: <chloe> chloe
|
|||
|
||||
DEFER: process-template
|
||||
|
||||
: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
|
||||
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
|
||||
|
||||
: filter-chloe-attrs ( assoc -- assoc' )
|
||||
[ drop name-url chloe-ns = not ] assoc-subset ;
|
||||
|
||||
: chloe-tag? ( tag -- ? )
|
||||
{
|
||||
{ [ dup tag? not ] [ f ] }
|
||||
{ [ dup chloe-ns names-match? not ] [ f ] }
|
||||
{ [ dup url>> chloe-ns = not ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
SYMBOL: tags
|
||||
|
||||
MEMO: chloe-name ( string -- name )
|
||||
name new
|
||||
swap >>tag
|
||||
chloe-ns >>url ;
|
||||
|
||||
: required-attr ( tag name -- value )
|
||||
dup rot at*
|
||||
dup chloe-name rot at*
|
||||
[ nip ] [ drop " attribute is required" append throw ] if ;
|
||||
|
||||
: optional-attr ( tag name -- value )
|
||||
swap at ;
|
||||
chloe-name swap at ;
|
||||
|
||||
: write-title-tag ( tag -- )
|
||||
drop
|
||||
|
|
@ -84,7 +92,7 @@ SYMBOL: tags
|
|||
dup empty?
|
||||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||
|
||||
: a-flow-attr ( tag -- )
|
||||
: flow-attr ( tag -- )
|
||||
"flow" optional-attr {
|
||||
{ "none" [ flow-id off ] }
|
||||
{ "begin" [ begin-flow ] }
|
||||
|
|
@ -92,7 +100,7 @@ SYMBOL: tags
|
|||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
: a-session-attr ( tag -- )
|
||||
: session-attr ( tag -- )
|
||||
"session" optional-attr {
|
||||
{ "none" [ session off flow-id off ] }
|
||||
{ "current" [ ] }
|
||||
|
|
@ -102,8 +110,8 @@ SYMBOL: tags
|
|||
: a-start-tag ( tag -- )
|
||||
[
|
||||
<a
|
||||
dup a-flow-attr
|
||||
dup a-session-attr
|
||||
dup flow-attr
|
||||
dup session-attr
|
||||
dup "value" optional-attr [ value f ] [
|
||||
[ "href" required-attr ]
|
||||
[ "query" optional-attr parse-query-attr ]
|
||||
|
|
@ -122,12 +130,18 @@ SYMBOL: tags
|
|||
tri ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
[
|
||||
<form
|
||||
"POST" =method
|
||||
{
|
||||
[ flow-attr ]
|
||||
[ session-attr ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ tag-attrs [ drop name-tag "action" = not ] assoc-subset print-attrs ] bi
|
||||
[ tag-attrs filter-chloe-attrs print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
hidden-form-field ;
|
||||
hidden-form-field
|
||||
] with-scope ;
|
||||
|
||||
: form-tag ( tag -- )
|
||||
[ form-start-tag ]
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ IN: webapps.factor-website
|
|||
<boilerplate>
|
||||
"page" factor-template >>template
|
||||
<flows>
|
||||
<url-sessions>
|
||||
<session-manager>
|
||||
sessions-in-db >>sessions
|
||||
test-db <db-persistence> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
<head>
|
||||
<t:write-title />
|
||||
|
||||
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
|
||||
<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
|
||||
|
||||
<t:style>
|
||||
body, button {
|
||||
|
|
|
|||
|
|
@ -2,21 +2,21 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<h2>Annotation: <t:view component="summary" /></h2>
|
||||
<h2>Annotation: <t:view t:component="summary" /></h2>
|
||||
|
||||
<table>
|
||||
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
|
||||
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
|
||||
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
|
||||
</table>
|
||||
|
||||
<div class="description">
|
||||
<t:view component="contents" />
|
||||
<t:view t:component="contents" />
|
||||
</div>
|
||||
|
||||
<t:form action="$pastebin/delete-annotation" class="inline">
|
||||
<t:edit component="id" />
|
||||
<t:edit component="aid" />
|
||||
<t:form t:action="$pastebin/delete-annotation" class="inline">
|
||||
<t:edit t:component="id" />
|
||||
<t:edit t:component="aid" />
|
||||
<button class="link-button link">Delete Annotation</button>
|
||||
</t:form>
|
||||
|
||||
|
|
|
|||
|
|
@ -4,15 +4,15 @@
|
|||
|
||||
<t:title>New Annotation</t:title>
|
||||
|
||||
<t:form action="$pastebin/annotate">
|
||||
<t:edit component="id" />
|
||||
<t:form t:action="$pastebin/annotate">
|
||||
<t:edit t:component="id" />
|
||||
|
||||
<table>
|
||||
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
|
||||
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="contents" /></td></tr>
|
||||
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
|
||||
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
|
||||
<tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="contents" /></td></tr>
|
||||
<tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@
|
|||
|
||||
<t:title>New Paste</t:title>
|
||||
|
||||
<t:form action="$pastebin/new-paste">
|
||||
<t:form t:action="$pastebin/new-paste">
|
||||
|
||||
<table>
|
||||
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
|
||||
<tr><th class="field-label big-field-label">Description: </th><td><t:edit component="contents" /></td></tr>
|
||||
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
|
||||
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
|
||||
<tr><th class="field-label big-field-label">Description: </th><td><t:edit t:component="contents" /></td></tr>
|
||||
<tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
|
||||
<tr>
|
||||
<td></td>
|
||||
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
<th align="left" width="100">Paste by:</th>
|
||||
<th align="left" width="200">Date:</th>
|
||||
|
||||
<t:summary component="pastes" />
|
||||
<t:summary t:component="pastes" />
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@
|
|||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<tr>
|
||||
<td><t:a href="view-paste" query="id"><t:view component="summary" /></t:a></td>
|
||||
<td><t:view component="author" /></td>
|
||||
<td><t:view component="date" /></td>
|
||||
<td><t:a t:href="view-paste" query="id"><t:view t:component="summary" /></t:a></td>
|
||||
<td><t:view t:component="author" /></td>
|
||||
<td><t:view t:component="date" /></td>
|
||||
</tr>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,24 +4,22 @@
|
|||
|
||||
<t:title>Pastebin</t:title>
|
||||
|
||||
<h2>Paste: <t:view component="summary" /></h2>
|
||||
<h2>Paste: <t:view t:component="summary" /></h2>
|
||||
|
||||
<table>
|
||||
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
|
||||
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
|
||||
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
|
||||
<tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
|
||||
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
|
||||
</table>
|
||||
|
||||
<div class="description">
|
||||
<t:view component="contents" />
|
||||
</div>
|
||||
<pre class="description"><t:view t:component="contents" /></pre>
|
||||
|
||||
<t:form action="$pastebin/delete-paste" class="inline">
|
||||
<t:edit component="id" />
|
||||
<t:form t:action="$pastebin/delete-paste" class="inline">
|
||||
<t:edit t:component="id" />
|
||||
<button class="link-button link">Delete Paste</button>
|
||||
</t:form>
|
||||
|
|
||||
<t:a href="$pastebin/annotate" query="id">Annotate</t:a>
|
||||
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
|
||||
|
||||
<t:view component="annotations" />
|
||||
<t:view t:component="annotations" />
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -242,7 +242,7 @@ TUPLE: pastebin < dispatcher ;
|
|||
<feed-action> "feed.xml" add-responder
|
||||
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
|
||||
[ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" add-responder
|
||||
[ <annotation> ] "$pastebin/view-paste" <protected> <delete-annotation-action> "delete-annotation" add-responder
|
||||
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> <protected> "delete-annotation" add-responder
|
||||
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
|
||||
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
|
||||
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
|
||||
|
|
|
|||
|
|
@ -2,24 +2,27 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:atom title="Pastebin - Atom" href="$pastebin/feed.xml" />
|
||||
<t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
|
||||
|
||||
<t:style include="resource:extra/webapps/pastebin/pastebin.css" />
|
||||
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a href="$pastebin/list">Pastes</t:a>
|
||||
| <t:a href="$pastebin/new-paste">New Paste</t:a>
|
||||
| <t:a href="$pastebin/feed.xml">Atom Feed</t:a>
|
||||
<t:a t:href="$pastebin/list">Pastes</t:a>
|
||||
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
|
||||
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
|
||||
|
||||
<t:comment>
|
||||
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
|
||||
<t:if t:svar="http.server.auth:logged-in-user">
|
||||
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
</t:if>
|
||||
|
||||
<t:form action="$login/logout" class="inline">
|
||||
<t:form t:action="$login/logout" t:flow="begin" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</t:comment>
|
||||
|
||||
</t:if>
|
||||
|
||||
</div>
|
||||
|
||||
<h1><t:write-title /></h1>
|
||||
|
|
|
|||
|
|
@ -4,11 +4,11 @@
|
|||
|
||||
<t:title>Planet Factor Administration</t:title>
|
||||
|
||||
<t:summary component="blogroll" />
|
||||
<t:summary t:component="blogroll" />
|
||||
|
||||
<p>
|
||||
<t:a href="$planet-factor/admin/edit-blog">Add Blog</t:a>
|
||||
| <t:a href="$planet-factor/admin/update">Update</t:a>
|
||||
<t:a t:href="$planet-factor/admin/edit-blog">Add Blog</t:a>
|
||||
| <t:a t:href="$planet-factor/admin/update">Update</t:a>
|
||||
</p>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -2,6 +2,6 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:a href="$planet-factor/admin/edit-blog" query="id"><t:view component="name" /></t:a>
|
||||
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id"><t:view t:component="name" /></t:a>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,25 +4,25 @@
|
|||
|
||||
<t:title>Edit Blog</t:title>
|
||||
|
||||
<t:form action="$planet-factor/admin/edit-blog">
|
||||
<t:form t:action="$planet-factor/admin/edit-blog">
|
||||
|
||||
<t:edit component="id" />
|
||||
<t:edit t:component="id" />
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Blog name:</th>
|
||||
<td><t:edit component="name" /></td>
|
||||
<td><t:edit t:component="name" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Home page:</th>
|
||||
<td><t:edit component="www-url" /></td>
|
||||
<td><t:edit t:component="www-url" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Feed:</th>
|
||||
<td><t:edit component="feed-url" /></td>
|
||||
<td><t:edit t:component="feed-url" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
@ -31,8 +31,8 @@
|
|||
|
||||
</t:form>
|
||||
|
||||
<t:form action="$planet-factor/admin/delete-blog" class="inline">
|
||||
<t:edit component="id" />
|
||||
<t:form t:action="$planet-factor/admin/delete-blog" class="inline">
|
||||
<t:edit t:component="id" />
|
||||
<button type="submit" class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<p class="news">
|
||||
<strong><t:view component="title" /></strong> <br/>
|
||||
<t:a value="link" session="none" class="more">Read More...</t:a>
|
||||
<strong><t:view t:component="title" /></strong> <br/>
|
||||
<t:a value="link" t:session="none" class="more">Read More...</t:a>
|
||||
</p>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -3,15 +3,15 @@
|
|||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<h2 class="posting-title">
|
||||
<t:a value="link" session="none"><t:view component="title" /></t:a>
|
||||
<t:a t:value="link" t:session="none"><t:view t:component="title" /></t:a>
|
||||
</h2>
|
||||
|
||||
<p class="posting-body">
|
||||
<t:view component="description" />
|
||||
<t:view t:component="description" />
|
||||
</p>
|
||||
|
||||
<p class="posting-date">
|
||||
<t:a value="link" session="none"><t:view component="pub-date" /></t:a>
|
||||
<t:a t:value="link" t:session="none"><t:view t:component="pub-date" /></t:a>
|
||||
</p>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -169,5 +169,8 @@ blog "BLOGS"
|
|||
|
||||
: start-update-task ( planet db seq -- )
|
||||
'[
|
||||
, , , [ update-cached-postings ] with-db
|
||||
, , , [
|
||||
dup filter-responder? [ responder>> ] when
|
||||
update-cached-postings
|
||||
] with-db
|
||||
] 10 minutes every drop ;
|
||||
|
|
|
|||
|
|
@ -8,19 +8,19 @@
|
|||
<t:style include="resource:extra/webapps/planet/planet.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a href="$planet-factor/list">Front Page</t:a>
|
||||
| <t:a href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||
| <t:a href="$planet-factor/admin">Admin</t:a>
|
||||
<t:a t:href="$planet-factor/list">Front Page</t:a>
|
||||
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||
| <t:a t:href="$planet-factor/admin">Admin</t:a>
|
||||
|
||||
<t:comment>
|
||||
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
|
||||
<t:if t:svar="http.server.auth:logged-in-user">
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
</t:if>
|
||||
|
||||
<t:form action="$login/logout" class="inline">
|
||||
<t:form t:action="$login/logout" t:flow="begin" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</t:comment>
|
||||
</t:if>
|
||||
</div>
|
||||
|
||||
<h1><t:write-title /></h1>
|
||||
|
|
|
|||
|
|
@ -2,6 +2,6 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:summary component="postings" />
|
||||
<t:summary t:component="postings" />
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -6,12 +6,12 @@
|
|||
|
||||
<table width="100%" cellpadding="10">
|
||||
<tr>
|
||||
<td> <t:view component="postings" /> </td>
|
||||
<td> <t:view t:component="postings" /> </td>
|
||||
|
||||
<td valign="top" width="25%" class="infobox">
|
||||
<h2>Blogroll</h2>
|
||||
|
||||
<t:summary component="blogroll" />
|
||||
<t:summary t:component="blogroll" />
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<table class="todo-list">
|
||||
<tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
|
||||
<t:summary component="list" />
|
||||
<t:summary t:component="list" />
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@
|
|||
|
||||
<tr>
|
||||
<td>
|
||||
<t:view component="summary" />
|
||||
<t:view t:component="summary" />
|
||||
</td>
|
||||
<td>
|
||||
<t:view component="priority" />
|
||||
<t:view t:component="priority" />
|
||||
</td>
|
||||
<td>
|
||||
<t:a href="$todo-list/view" query="id">View</t:a>
|
||||
<t:a t:href="$todo-list/view" t:query="id">View</t:a>
|
||||
</td>
|
||||
<td>
|
||||
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
||||
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
|
||||
</td>
|
||||
</tr>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,14 +5,14 @@
|
|||
<t:style include="resource:extra/webapps/todo/todo.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a href="$todo-list/list">List Items</t:a>
|
||||
| <t:a href="$todo-list/edit">Add Item</t:a>
|
||||
<t:a t:href="$todo-list/list">List Items</t:a>
|
||||
| <t:a t:href="$todo-list/edit">Add Item</t:a>
|
||||
|
||||
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a href="$login/edit-profile" flow="begin">Edit Profile</t:a>
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
</t:if>
|
||||
|
||||
<t:form action="$login/logout" class="inline">
|
||||
<t:form t:action="$login/logout" t:flow="begin" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</div>
|
||||
|
|
|
|||
|
|
@ -10,13 +10,13 @@
|
|||
</table>
|
||||
|
||||
<div class="description">
|
||||
<t:view component="description" />
|
||||
<t:view t:component="description" />
|
||||
</div>
|
||||
|
||||
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
||||
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
|
||||
|
|
||||
<t:form action="$todo-list/delete" class="inline">
|
||||
<t:edit component="id" />
|
||||
<t:form t:action="$todo-list/delete" class="inline">
|
||||
<t:edit t:component="id" />
|
||||
<button class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue