From 0b0e46085776ad8e7b51a3b907e9de9953249c1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Apr 2008 03:09:00 -0500 Subject: [PATCH] Improved cookie support, and better session manager taking advantage of it --- extra/calendar/format/format-tests.factor | 7 + extra/calendar/format/format.factor | 186 +++++++++++------- .../format/macros/macros-tests.factor | 14 ++ extra/calendar/format/macros/macros.factor | 19 ++ extra/http/http-tests.factor | 2 +- extra/http/http.factor | 18 +- .../http/server/actions/actions-tests.factor | 1 + extra/http/server/actions/actions.factor | 17 +- extra/http/server/auth/basic/basic.factor | 2 +- extra/http/server/auth/login/edit-profile.xml | 18 +- extra/http/server/auth/login/login.factor | 12 +- extra/http/server/auth/login/login.xml | 12 +- extra/http/server/auth/login/recover-1.xml | 8 +- extra/http/server/auth/login/recover-3.xml | 12 +- extra/http/server/auth/login/recover-4.xml | 2 +- extra/http/server/auth/login/register.xml | 18 +- .../server/boilerplate/boilerplate.factor | 2 +- extra/http/server/callbacks/callbacks.factor | 2 +- extra/http/server/crud/crud.factor | 4 +- extra/http/server/db/db.factor | 2 +- extra/http/server/flows/flows.factor | 22 ++- extra/http/server/server-tests.factor | 6 +- extra/http/server/server.factor | 35 ++-- .../server/sessions/sessions-tests.factor | 15 +- extra/http/server/sessions/sessions.factor | 54 ++--- .../http/server/sessions/storage/db/db.factor | 4 +- extra/http/server/static/static.factor | 4 +- .../http/server/templating/chloe/chloe.factor | 44 +++-- .../factor-website/factor-website.factor | 2 +- extra/webapps/factor-website/page.xml | 2 +- extra/webapps/pastebin/annotation.xml | 16 +- extra/webapps/pastebin/new-annotation.xml | 14 +- extra/webapps/pastebin/new-paste.xml | 12 +- extra/webapps/pastebin/paste-list.xml | 2 +- extra/webapps/pastebin/paste-summary.xml | 6 +- extra/webapps/pastebin/paste.xml | 20 +- extra/webapps/pastebin/pastebin.factor | 2 +- extra/webapps/pastebin/pastebin.xml | 27 +-- extra/webapps/planet/admin.xml | 6 +- extra/webapps/planet/blog-admin-link.xml | 2 +- extra/webapps/planet/edit-blog.xml | 14 +- extra/webapps/planet/entry-summary.xml | 4 +- extra/webapps/planet/entry.xml | 6 +- extra/webapps/planet/planet.factor | 5 +- extra/webapps/planet/planet.xml | 22 +-- extra/webapps/planet/postings-summary.xml | 2 +- extra/webapps/planet/postings.xml | 4 +- extra/webapps/todo/todo-list.xml | 2 +- extra/webapps/todo/todo-summary.xml | 8 +- extra/webapps/todo/todo.xml | 10 +- extra/webapps/todo/view-todo.xml | 8 +- 51 files changed, 441 insertions(+), 297 deletions(-) create mode 100644 extra/calendar/format/macros/macros-tests.factor create mode 100644 extra/calendar/format/macros/macros.factor diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index 1ba892bef3..0d072f27f6 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -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 diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 7bdaea70b5..af536c2585 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -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 ; @@ -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 ; diff --git a/extra/calendar/format/macros/macros-tests.factor b/extra/calendar/format/macros/macros-tests.factor new file mode 100644 index 0000000000..91a8f80894 --- /dev/null +++ b/extra/calendar/format/macros/macros-tests.factor @@ -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 diff --git a/extra/calendar/format/macros/macros.factor b/extra/calendar/format/macros/macros.factor new file mode 100644 index 0000000000..6d6dd3ae23 --- /dev/null +++ b/extra/calendar/format/macros/macros.factor @@ -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 ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index a9e539c2a5..e624f56573 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -158,7 +158,7 @@ test-db [ "extra/http/test" resource-path >>default "nested" add-responder - [ "redirect-loop" f ] >>display + [ "redirect-loop" f ] >>display "redirect-loop" add-responder main-responder set diff --git a/extra/http/http.factor b/extra/http/http.factor index 3e81fccd24..99a48e58d8 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ; : ( 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 ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 615077821a..5aa761603f 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -22,6 +22,7 @@ blah ; [ 25 ] [ + init-request action-request-test-1 lf>crlf [ read-request ] with-string-reader request set diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index bfcbd20cca..6e1aac9627 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -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>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case + request get + [ request-params params set ] + [ + method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi ] [ <404> ] if diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 62625e116b..daf6e30eae 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -36,6 +36,6 @@ C: 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 ; diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml index 86a4e86551..c19b18c947 100644 --- a/extra/http/server/auth/login/edit-profile.xml +++ b/extra/http/server/auth/login/edit-profile.xml @@ -4,18 +4,18 @@ Edit Profile - + - + - + @@ -25,7 +25,7 @@ - + @@ -35,12 +35,12 @@ - + - + @@ -50,7 +50,7 @@ - + @@ -63,11 +63,11 @@

- + invalid password - + passwords do not match

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 5f58f51adb..716996dc5a 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -331,7 +331,7 @@ SYMBOL: lost-password-from [ f logged-in-user sset - "$login/login" f + "$login/login" end-flow ] >>submit ; ! ! ! Authentication logic @@ -342,19 +342,17 @@ C: protected : show-login-page ( -- response ) begin-flow - "$login/login" f ; + "$login/login" f ; -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 ; diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml index 2f16c09d8d..0524d0889f 100644 --- a/extra/http/server/auth/login/login.xml +++ b/extra/http/server/auth/login/login.xml @@ -4,18 +4,18 @@ Login - +
User name:
Real name:
Current password:
New password:
Verify:
E-mail:
- + - +
User name:
Password:
@@ -24,7 +24,7 @@ - + invalid username or password

@@ -33,11 +33,11 @@

- Register + Register | - Recover Password + Recover Password

diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml index dd3a60f1d1..7c72181c10 100644 --- a/extra/http/server/auth/login/recover-1.xml +++ b/extra/http/server/auth/login/recover-1.xml @@ -6,23 +6,23 @@

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.

- + - + - + - + diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml index 115c2cea21..61ef0aef86 100644 --- a/extra/http/server/auth/login/recover-3.xml +++ b/extra/http/server/auth/login/recover-3.xml @@ -6,21 +6,21 @@

Choose a new password for your account.

- +
User name:
E-mail:
Captcha:
- - + + - + - + @@ -33,7 +33,7 @@

- + passwords do not match

diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml index 3c10869fbd..f5d02fa858 100755 --- a/extra/http/server/auth/login/recover-4.xml +++ b/extra/http/server/auth/login/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

Your password has been reset. You may now log in.

+

Your password has been reset. You may now log in.

diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml index 1bacf71801..19917002b5 100644 --- a/extra/http/server/auth/login/register.xml +++ b/extra/http/server/auth/login/register.xml @@ -4,18 +4,18 @@ New User Registration - +
Password:
Verify password:
- + - + @@ -25,12 +25,12 @@ - + - + @@ -40,7 +40,7 @@ - + @@ -50,7 +50,7 @@ - + @@ -64,11 +64,11 @@ - + username taken - + passwords do not match diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index fbe027cc05..1dc5effbe2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -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>> diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index 42213d015f..5325ee3b55 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -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 ) '[ , , diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index 65de881adb..90af25df5b 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -18,7 +18,7 @@ IN: http.server.crud [ form view-form ] >>display ; : ( id next -- response ) - swap number>string "id" associate ; + swap number>string "id" associate ; :: ( form ctor next -- action ) @@ -53,7 +53,7 @@ IN: http.server.crud [ "id" get ctor call delete-tuple - next f + next f ] >>submit ; :: ( form ctor -- action ) diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 221608fc91..047af3f4ac 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -12,5 +12,5 @@ C: 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 ; diff --git a/extra/http/server/flows/flows.factor b/extra/http/server/flows/flows.factor index 14ac1d8d79..7a9b362111 100644 --- a/extra/http/server/flows/flows.factor +++ b/extra/http/server/flows/flows.factor @@ -10,12 +10,25 @@ TUPLE: flows < filter-responder ; C: 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 ; + flows sget at + [ first3 "POST" = [ end-flow-post ] [ ] if ] + [ f ] ?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* diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 2048164884..a5dffbc58b 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -27,7 +27,7 @@ TUPLE: mock-responder path ; C: mock-responder -M: mock-responder call-responder +M: mock-responder call-responder* nip path>> on "text/plain" ; @@ -81,7 +81,7 @@ TUPLE: path-check-responder ; C: path-check-responder -M: path-check-responder call-responder +M: path-check-responder call-responder* drop "text/plain" swap >array >>body ; @@ -121,7 +121,7 @@ TUPLE: base-path-check-responder ; C: 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" swap >>body ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 13ed36ec65..6c128b3d83 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 -M: trivial-responder call-responder nip response>> call ; +M: trivial-responder call-responder* nip response>> call ; : trivial-response-body ( code message -- ) @@ -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 : ( to query -- response ) 307 "Temporary Redirect" ; +: ( to query -- response ) + request get method>> "POST" = + [ ] [ ] 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 ; +: init-request ( -- ) + H{ } clone base-paths set + [ ] link-hook set + [ ] form-hook set ; + : do-request ( request -- response ) [ - H{ } clone base-paths set - [ ] link-hook set - [ ] form-hook set - - [ log-request ] + init-request [ request set ] + [ log-request ] [ path>> split-path main-responder get call-responder ] tri [ <404> ] unless* ] [ diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 4ff26c3a8f..548f3dc00b 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -16,7 +16,7 @@ C: foo M: foo init-session* drop 0 "x" sset ; -M: foo call-responder +M: foo call-responder* 2drop "x" [ 1+ ] schange "text/html" [ "x" sget pprint ] >>body ; @@ -53,8 +53,15 @@ M: foo call-responder "auth-test.db" temp-file sqlite-db [ + init-request init-sessions-table + [ ] [ + + 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 - [ ] [ - - sessions-in-db >>sessions - session-manager set - ] unit-test - [ t ] [ session-manager get begin-session id>> session-manager get sessions>> get-session session? diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index d2c1d90e0a..df2a5bbd28 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -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? ; : ( 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 ; : ( 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 @@ -73,21 +72,24 @@ TUPLE: session-manager < filter-responder sessions ; 2tri ; ! Destructor -TUPLE: session-saver session ; +TUPLE: session-saver manager session ; C: 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 -- ) 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 ; : ( id -- cookie ) - session-id-key ; + session-id-key + "$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 ] bi - put-cookie ; +: put-session-cookie ( response -- response' ) + session get id>> number>string put-cookie ; : session-form-field ( -- ) > 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 ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 637d86670f..58a0130b36 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -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 - 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 -- ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 1605144b61..af6018fbdc 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -77,7 +77,7 @@ TUPLE: file-responder root hook special ; find-index [ serve-file ] [ list-directory ] ?if ] [ drop - request get path>> "/" append f + request get path>> "/" append f ] 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 ; diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor index 99d6376fe8..622cfe900f 100644 --- a/extra/http/server/templating/chloe/chloe.factor +++ b/extra/http/server/templating/chloe/chloe.factor @@ -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 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 -- ) [ - hidden-form-field ; + [ +
+ hidden-form-field + ] with-scope ; : form-tag ( tag -- ) [ form-start-tag ] diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index d6ddeb32bb..0c7b95525e 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -47,7 +47,7 @@ IN: webapps.factor-website "page" factor-template >>template - + sessions-in-db >>sessions test-db ; diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index 2f67b5e857..3e2f43845a 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -10,7 +10,7 @@ - + body, button { diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml index af6a835a64..e5a95d8908 100644 --- a/extra/webapps/pastebin/annotation.xml +++ b/extra/webapps/pastebin/annotation.xml @@ -2,21 +2,21 @@ -

Annotation:

+

Annotation:

User name:
Real name:
Password:
Verify:
E-mail:
Captcha:
- - - + + +
Author:
Mode:
Date:
Author:
Mode:
Date:
- +
- - - + + + diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml index 4afc5cfec5..ad7152d209 100644 --- a/extra/webapps/pastebin/new-annotation.xml +++ b/extra/webapps/pastebin/new-annotation.xml @@ -4,15 +4,15 @@ New Annotation - - + + - - - - - + + + + + diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml index 4b2b4a46ce..86daf09aeb 100644 --- a/extra/webapps/pastebin/new-paste.xml +++ b/extra/webapps/pastebin/new-paste.xml @@ -4,14 +4,14 @@ New Paste - +
Summary:
Author:
Mode:
Description:
Captcha:
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
- - - - - + + + + + diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml index 12b926c7d1..c91aa6fc42 100644 --- a/extra/webapps/pastebin/paste-list.xml +++ b/extra/webapps/pastebin/paste-list.xml @@ -9,7 +9,7 @@ - +
Summary:
Author:
Mode:
Description:
Captcha:
Summary:
Author:
Mode:
Description:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.Paste by: Date:
diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml index 952d0de73d..eca46e254d 100644 --- a/extra/webapps/pastebin/paste-summary.xml +++ b/extra/webapps/pastebin/paste-summary.xml @@ -3,9 +3,9 @@ - - - + + + diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 89d1891221..9db60bfcc3 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -4,24 +4,22 @@ Pastebin -

Paste:

+

Paste:

- - - + + +
Author:
Mode:
Date:
Author:
Mode:
Date:
-
- -
+
- - + + | - Annotate + Annotate - + diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 07b3e9c02d..9301b14353 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -242,7 +242,7 @@ TUPLE: pastebin < dispatcher ; "feed.xml" add-responder [ ] "view-paste" add-responder [ ] "$pastebin/list" "delete-paste" add-responder - [ ] "$pastebin/view-paste" "delete-annotation" add-responder + [ ] "$pastebin/view-paste" "delete-annotation" add-responder [ ] "$pastebin/view-paste" add-responder [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder [ now >>date ] "$pastebin/view-paste" "annotate" add-responder diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml index 6b49162637..99fede727e 100644 --- a/extra/webapps/pastebin/pastebin.xml +++ b/extra/webapps/pastebin/pastebin.xml @@ -2,24 +2,27 @@ - + - +
- Pastes - | New Paste - | Atom Feed + Pastes + | New Paste + | Atom Feed + + + + + | Edit Profile + + + + | + - - - | Edit Profile - - | - -

diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 3bd406ee38..c79fe2efd1 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -4,11 +4,11 @@ Planet Factor Administration - +

- Add Blog - | Update + Add Blog + | Update

diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml index a92af8dd1d..8d6c890643 100644 --- a/extra/webapps/planet/blog-admin-link.xml +++ b/extra/webapps/planet/blog-admin-link.xml @@ -2,6 +2,6 @@ - + diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml index 83273540a5..b2eab2b0b4 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -4,25 +4,25 @@ Edit Blog - + - + - + - + - +
Blog name:
Home page:
Feed:
@@ -31,8 +31,8 @@ - - + + diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml index 905795373b..741b123456 100644 --- a/extra/webapps/planet/entry-summary.xml +++ b/extra/webapps/planet/entry-summary.xml @@ -3,8 +3,8 @@

-
- Read More... +
+ Read More...

diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml index 0e52c191a5..5e43717384 100644 --- a/extra/webapps/planet/entry.xml +++ b/extra/webapps/planet/entry.xml @@ -3,15 +3,15 @@

- +

- +

- +

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 752db18ee7..2acff094c3 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -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 ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 328be84544..fdbfe6d841 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -8,19 +8,19 @@
- Front Page - | Atom Feed - | Admin + Front Page + | Atom Feed + | Admin - - - | Edit Profile + + + | Edit Profile + + + + | + - - - | - -

diff --git a/extra/webapps/planet/postings-summary.xml b/extra/webapps/planet/postings-summary.xml index 950191e4c3..765c3a8006 100644 --- a/extra/webapps/planet/postings-summary.xml +++ b/extra/webapps/planet/postings-summary.xml @@ -2,6 +2,6 @@ - + diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml index f59a4f61b8..c2c73d7e89 100644 --- a/extra/webapps/planet/postings.xml +++ b/extra/webapps/planet/postings.xml @@ -6,12 +6,12 @@ - +

Blogroll

- +
diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml index 1887fccdc1..66abeafc86 100644 --- a/extra/webapps/todo/todo-list.xml +++ b/extra/webapps/todo/todo-list.xml @@ -6,7 +6,7 @@ - +
SummaryPriorityViewEdit
diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml index 008b0acaf5..056c9cab0a 100644 --- a/extra/webapps/todo/todo-summary.xml +++ b/extra/webapps/todo/todo-summary.xml @@ -4,16 +4,16 @@ - + - + - View + View - Edit + Edit diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 4e307b7cae..ff58b27df2 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -5,14 +5,14 @@
- List Items - | Add Item + List Items + | Add Item - - | Edit Profile + + | Edit Profile - + |
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml index e8c2fd3983..f77396c73c 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -10,13 +10,13 @@
- +
- Edit + Edit | - - + +