steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working on user capabilities

db4
Slava Pestov 2008-05-01 16:24:50 -05:00
parent 0994c4f29e
commit 79f91f6b7d
26 changed files with 233 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
extra/checksums/null/null.factor Normal file
View File

@ -0,0 +1,8 @@
USING: checksums ;
IN: checksums.null
SINGLETON: null
INSTANCE: null checksum
M: null checksum-bytes ;

16
extra/http/http-tests.factor
View File

@ -1,6 +1,6 @@
USING: http tools.test multiline tuple-syntax USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite ; assocs io.sockets db db.sqlite continuations ;
IN: http.tests IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -93,7 +93,7 @@ Host: www.sex.com
STRING: read-response-test-1 STRING: read-response-test-1
HTTP/1.1 404 not found HTTP/1.1 404 not found
Content-Type: text/html Content-Type: text/html; charset=UTF8
blah blah
; ;
@ -103,8 +103,10 @@ blah
version: "1.1" version: "1.1"
code: 404 code: 404
message: "not found" message: "not found"
header: H{ { "content-type" "text/html" } } header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ } cookies: V{ }
content-type: "text/html"
content-charset: "UTF8"
} }
] [ ] [
read-response-test-1 lf>crlf read-response-test-1 lf>crlf
@ -114,7 +116,7 @@ blah
STRING: read-response-test-1' STRING: read-response-test-1'
HTTP/1.1 404 not found HTTP/1.1 404 not found
content-type: text/html content-type: text/html; charset=UTF8
; ;
@ -140,11 +142,13 @@ accessors namespaces threads ;
: add-quit-action : add-quit-action
<action> <action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display [ stop-server [ "Goodbye" write ] <html-content> ] >>display
"quit" add-responder ; "quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ; : test-db "test.db" temp-file sqlite-db ;
[ test-db drop delete-file ] ignore-errors
test-db [ test-db [
init-sessions-table init-sessions-table
] with-db ] with-db
@ -191,7 +195,7 @@ test-db [
[ ] [ [ ] [
[ [
<dispatcher> <dispatcher>
<action> <protected> <action> f <protected>
<login> <login>
<sessions> <sessions>
"" add-responder "" add-responder

25
extra/http/http.factor
View File

@ -291,6 +291,12 @@ SYMBOL: max-post-request
: extract-cookies ( request -- request ) : extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ; dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: read-request ( -- request ) : read-request ( -- request )
<request> <request>
read-method read-method
@ -377,6 +383,8 @@ code
message message
header header
cookies cookies
content-type
content-charset
body ; body ;
: <response> : <response>
@ -403,7 +411,10 @@ body ;
: read-response-header : read-response-header
read-header >>header read-header >>header
dup "set-cookie" header [ parse-cookies >>cookies ] when* ; extract-cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;
: read-response ( -- response ) : read-response ( -- response )
<response> <response>
@ -422,10 +433,15 @@ body ;
: write-response-message ( response -- response ) : write-response-message ( response -- response )
dup message>> write crlf ; dup message>> write crlf ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> ] bi
[ "; charset=" swap 3append ] when* ;
: write-response-header ( response -- response ) : write-response-header ( response -- response )
dup header>> clone dup header>> clone
over cookies>> f like over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
[ unparse-cookies "set-cookie" pick set-at ] when* over unparse-content-type "content-type" pick set-at
write-header ; write-header ;
GENERIC: write-response-body* ( body -- ) GENERIC: write-response-body* ( body -- )
@ -453,9 +469,6 @@ M: response write-full-response ( request response -- )
dup write-response dup write-response
swap method>> "HEAD" = [ write-response-body ] unless ; swap method>> "HEAD" = [ write-response-body ] unless ;
: set-content-type ( request/response content-type -- request/response )
"content-type" set-header ;
: get-cookie ( request/response name -- cookie/f ) : get-cookie ( request/response name -- cookie/f )
>r cookies>> r> '[ , _ name>> = ] find nip ; >r cookies>> r> '[ , _ name>> = ] find nip ;

13
extra/http/server/auth/admin/admin.factor
View File

@ -7,6 +7,7 @@ http.server.boilerplate
http.server.auth.providers http.server.auth.providers
http.server.auth.providers.db http.server.auth.providers.db
http.server.auth.login http.server.auth.login
http.server.auth
http.server.forms http.server.forms
http.server.components.inspector http.server.components.inspector
http.server.components http.server.components
@ -28,6 +29,7 @@ IN: http.server.auth.admin
"new-password" <password> t >>required add-field "new-password" <password> t >>required add-field
"verify-password" <password> t >>required add-field "verify-password" <password> t >>required add-field
"email" <email> add-field ; "email" <email> add-field ;
! "capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form ) : <edit-user-form> ( -- form )
"user" <form> "user" <form>
@ -39,6 +41,7 @@ IN: http.server.auth.admin
"verify-password" <password> add-field "verify-password" <password> add-field
"email" <email> add-field "email" <email> add-field
"profile" <inspector> add-field ; "profile" <inspector> add-field ;
! "capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form ) : <user-list-form> ( -- form )
"user-list" <form> "user-list" <form>
@ -77,7 +80,7 @@ IN: http.server.auth.admin
"username" value <user> "username" value <user>
"realname" value >>realname "realname" value >>realname
"email" value >>email "email" value >>email
"new-password" value >>password "new-password" value >>encoded-password
H{ } clone >>profile H{ } clone >>profile
insert-tuple insert-tuple
@ -116,7 +119,7 @@ IN: http.server.auth.admin
{ "new-password" "verify-password" } { "new-password" "verify-password" }
[ value empty? ] all? [ [ value empty? ] all? [
same-password-twice same-password-twice
"new-password" value >>password "new-password" value >>encoded-password
] unless ] unless
update-tuple update-tuple
@ -139,6 +142,10 @@ IN: http.server.auth.admin
TUPLE: user-admin < dispatcher ; TUPLE: user-admin < dispatcher ;
SYMBOL: can-administer-users?
can-administer-users? define-capability
:: <user-admin> ( -- responder ) :: <user-admin> ( -- responder )
[let | ctor [ [ <user> ] ] | [let | ctor [ [ <user> ] ] |
user-admin new-dispatcher user-admin new-dispatcher
@ -148,5 +155,5 @@ TUPLE: user-admin < dispatcher ;
ctor "$user-admin" <delete-user-action> "delete" add-responder ctor "$user-admin" <delete-user-action> "delete" add-responder
<boilerplate> <boilerplate>
"admin" admin-template >>template "admin" admin-template >>template
<protected> { can-administer-users? } <protected>
] ; ] ;

8
extra/http/server/auth/auth.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel USING: accessors assocs namespaces kernel sequences
http.server http.server
http.server.sessions http.server.sessions
http.server.auth.providers ; http.server.auth.providers ;
@ -33,3 +33,9 @@ M: filter-responder init-user-profile
: uchange ( quot key -- ) : uchange ( quot key -- )
profile swap change-at profile swap change-at
user-changed ; inline user-changed ; inline
SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get push-new ;

60
extra/http/server/auth/login/login.factor
View File

@ -1,16 +1,23 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting USING: accessors quotations assocs kernel splitting
base64 io combinators sequences io.files namespaces hashtables combinators sequences namespaces hashtables
fry io.sockets arrays threads locals qualified continuations fry arrays threads locals qualified random
io
io.sockets
io.encodings.utf8
io.encodings.string
io.binary
continuations
destructors destructors
checksums
checksums.sha2
html.elements html.elements
http http
http.server http.server
http.server.auth http.server.auth
http.server.auth.providers http.server.auth.providers
http.server.auth.providers.null http.server.auth.providers.db
http.server.actions http.server.actions
http.server.components http.server.components
http.server.flows http.server.flows
@ -25,9 +32,24 @@ QUALIFIED: smtp
SYMBOL: login-failed? SYMBOL: login-failed?
TUPLE: login < dispatcher users ; TUPLE: login < dispatcher users checksum ;
: users login get users>> ; : users ( -- provider )
login get users>> ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
login get checksum>> checksum-bytes ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: valid-login? ( password user -- ? )
[ salt>> encode-password ] [ password>> ] bi = ;
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
! Destructor ! Destructor
TUPLE: user-saver user ; TUPLE: user-saver user ;
@ -72,8 +94,7 @@ M: user-saver dispose
form validate-form form validate-form
"password" value "username" value "password" value "username" value check-login [
users check-login [
successful-login successful-login
] [ ] [
login-failed? on login-failed? on
@ -125,7 +146,7 @@ SYMBOL: user-exists?
"username" value <user> "username" value <user>
"realname" value >>realname "realname" value >>realname
"new-password" value >>password "new-password" value >>encoded-password
"email" value >>email "email" value >>email
H{ } clone >>profile H{ } clone >>profile
@ -179,10 +200,10 @@ SYMBOL: user-exists?
[ value empty? ] all? [ [ value empty? ] all? [
same-password-twice same-password-twice
"password" value uid users check-login "password" value uid check-login
[ login-failed? on validation-failed ] unless [ login-failed? on validation-failed ] unless
"new-password" value >>password "new-password" value >>encoded-password
] unless ] unless
"realname" value >>realname "realname" value >>realname
@ -314,7 +335,7 @@ SYMBOL: lost-password-from
"ticket" value "ticket" value
"username" value "username" value
users claim-ticket [ users claim-ticket [
"new-password" value >>password "new-password" value >>encoded-password
users update-user users update-user
"recover-4" login-template serve-template "recover-4" login-template serve-template
@ -334,7 +355,7 @@ SYMBOL: lost-password-from
! ! ! Authentication logic ! ! ! Authentication logic
TUPLE: protected < filter-responder ; TUPLE: protected < filter-responder capabilities ;
C: <protected> protected C: <protected> protected
@ -342,13 +363,19 @@ C: <protected> protected
begin-flow begin-flow
"$login/login" f <standard-redirect> ; "$login/login" f <standard-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] [ profile>> ] bi* '[ , at ] all? ;
M: protected call-responder* ( path responder -- response ) M: protected call-responder* ( path responder -- response )
uid dup [ uid dup [
users get-user users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi [ logged-in-user set ] [ save-user-after ] bi
call-next-method call-next-method
] [ ] [
3drop show-login-page 3drop show-login-page
] if
] [
3drop show-login-page
] if ; ] if ;
M: login call-responder* ( path responder -- response ) M: login call-responder* ( path responder -- response )
@ -364,12 +391,13 @@ M: login call-responder* ( path responder -- response )
swap >>default swap >>default
<login-action> <login-boilerplate> "login" add-responder <login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ; users-in-db >>users
sha-256 >>checksum ;
! ! ! Configuration ! ! ! Configuration
: allow-edit-profile ( login -- login ) : allow-edit-profile ( login -- login )
<edit-profile-action> <protected> <login-boilerplate> <edit-profile-action> f <protected> <login-boilerplate>
"edit-profile" add-responder ; "edit-profile" add-responder ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )

22
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -1,33 +1,35 @@
IN: http.server.auth.providers.assoc.tests IN: http.server.auth.providers.assoc.tests
USING: http.server.auth.providers USING: http.server.actions http.server.auth.providers
http.server.auth.providers.assoc tools.test http.server.auth.providers.assoc tools.test
namespaces accessors kernel ; namespaces accessors kernel ;
<users-in-memory> "provider" set <action> <login>
<users-in-memory> >>users
login set
[ t ] [ [ t ] [
"slava" <user> "slava" <user>
"foobar" >>password "foobar" >>encoded-password
"slava@factorcode.org" >>email "slava@factorcode.org" >>email
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
username>> "slava" = username>> "slava" =
] unit-test ] unit-test
[ f ] [ [ f ] [
"slava" <user> "slava" <user>
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
] unit-test ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test [ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test [ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "foobar" "slava" check-login >boolean ] unit-test

26
extra/http/server/auth/providers/db/db-tests.factor
View File

@ -1,10 +1,14 @@
IN: http.server.auth.providers.db.tests IN: http.server.auth.providers.db.tests
USING: http.server.auth.providers USING: http.server.actions
http.server.auth.login
http.server.auth.providers
http.server.auth.providers.db tools.test http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ; io.files accessors kernel ;
users-in-db "provider" set <action> <login>
users-in-db >>users
login set
[ "auth-test.db" temp-file delete-file ] ignore-errors [ "auth-test.db" temp-file delete-file ] ignore-errors
@ -14,30 +18,30 @@ users-in-db "provider" set
[ t ] [ [ t ] [
"slava" <user> "slava" <user>
"foobar" >>password "foobar" >>encoded-password
"slava@factorcode.org" >>email "slava@factorcode.org" >>email
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
username>> "slava" = username>> "slava" =
] unit-test ] unit-test
[ f ] [ [ f ] [
"slava" <user> "slava" <user>
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
] unit-test ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test [ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test [ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ ] [ "user" get "provider" get update-user ] unit-test [ ] [ "user" get users update-user ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "foobar" "slava" check-login >boolean ] unit-test
] with-db ] with-db

3
extra/http/server/auth/providers/db/db.factor
View File

@ -9,7 +9,8 @@ user "USERS"
{ {
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ } { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } } { "realname" "REALNAME" { VARCHAR 256 } }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ } { "password" "PASSWORD" BLOB +not-null+ }
{ "salt" "SALT" INTEGER +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } } { "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } } { "ticket" "TICKET" { VARCHAR 256 } }
{ "profile" "PROFILE" FACTOR-BLOB } { "profile" "PROFILE" FACTOR-BLOB }

5
extra/http/server/auth/providers/providers.factor
View File

@ -4,7 +4,7 @@ USING: kernel accessors random math.parser locals
sequences math ; sequences math ;
IN: http.server.auth.providers IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile deleted changed? ; TUPLE: user username realname password salt email ticket profile deleted changed? ;
: <user> ( username -- user ) : <user> ( username -- user )
user new user new
@ -17,9 +17,6 @@ GENERIC: update-user ( user provider -- )
GENERIC: new-user ( user provider -- user/f ) GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
! Password recovery support ! Password recovery support
:: issue-ticket ( email username provider -- user/f ) :: issue-ticket ( email username provider -- user/f )

17
extra/http/server/boilerplate/boilerplate.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings USING: accessors kernel namespaces boxes sequences strings
io io.streams.string arrays io io.streams.string arrays locals
html.elements html.elements
http http
http.server http.server
@ -47,7 +47,7 @@ SYMBOL: nested-template?
SYMBOL: next-template SYMBOL: next-template
: call-next-template ( -- ) : call-next-template ( -- )
next-template get write ; next-template get write-html ;
M: f call-template* drop call-next-template ; M: f call-template* drop call-next-template ;
@ -68,9 +68,10 @@ M: f call-template* drop call-next-template ;
bi* bi*
] with-scope ; inline ] with-scope ; inline
M: boilerplate call-responder* M:: boilerplate call-responder* ( path responder -- )
tuck call-next-method path responder call-next-method
dup "content-type" header "text/html" = [ dup content-type>> "text/html" = [
clone swap template>> clone [| body |
[ [ with-boilerplate ] 2curry ] curry change-body [ body responder template>> with-boilerplate ]
] [ nip ] if ; ] change-body
] when ;

2
extra/http/server/callbacks/callbacks-tests.factor
View File

@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
<action> [ <action> [
[ [
"hello" print "hello" print
"text/html" <content> swap '[ , write ] >>body '[ , write ] <html-content>
] show-page ] show-page
"byebye" print "byebye" print
[ 123 ] show-final [ 123 ] show-final

2
extra/http/server/components/code/code.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors USING: splitting kernel io sequences xmode.code2html accessors
http.server.components ; http.server.components xml.entities ;
IN: http.server.components.code IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ; TUPLE: code-renderer < text-renderer mode ;

46
extra/http/server/components/components.factor
View File

@ -3,7 +3,7 @@
USING: accessors namespaces kernel io math.parser assocs classes USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math hashtables fry combinators continuations math
calendar.format html.elements calendar.format html.elements xml.entities
http.server.validators ; http.server.validators ;
IN: http.server.components IN: http.server.components
@ -18,13 +18,13 @@ TUPLE: field type ;
C: <field> field C: <field> field
M: field render-view* drop write ; M: field render-view* drop escape-string write ;
M: field render-edit* M: field render-edit*
<input type>> =type [ =id ] [ =name ] bi =value input/> ; <input type>> =type [ =id ] [ =name ] bi =value input/> ;
: render-error ( message -- ) : render-error ( message -- )
<span "error" =class span> write </span> ; <span "error" =class span> escape-string write </span> ;
TUPLE: hidden < field ; TUPLE: hidden < field ;
@ -232,7 +232,7 @@ TUPLE: text-renderer rows cols ;
text-renderer new-text-renderer ; text-renderer new-text-renderer ;
M: text-renderer render-view* M: text-renderer render-view*
drop write ; drop escape-string write ;
M: text-renderer render-edit* M: text-renderer render-edit*
<textarea <textarea
@ -241,7 +241,7 @@ M: text-renderer render-edit*
[ =id ] [ =id ]
[ =name ] bi [ =name ] bi
textarea> textarea>
write escape-string write
</textarea> ; </textarea> ;
TUPLE: text < string ; TUPLE: text < string ;
@ -261,7 +261,7 @@ TUPLE: html-text-renderer < text-renderer ;
html-text-renderer new-text-renderer ; html-text-renderer new-text-renderer ;
M: html-text-renderer render-view* M: html-text-renderer render-view*
drop write ; drop escape-string write ;
TUPLE: html-text < text ; TUPLE: html-text < text ;
@ -286,7 +286,7 @@ GENERIC: link-href ( obj -- url )
SINGLETON: link-renderer SINGLETON: link-renderer
M: link-renderer render-view* M: link-renderer render-view*
drop <a dup link-href =href a> link-title write </a> ; drop <a dup link-href =href a> link-title escape-string write </a> ;
TUPLE: link < string ; TUPLE: link < string ;
@ -341,15 +341,19 @@ TUPLE: choice-renderer choices ;
C: <choice-renderer> choice-renderer C: <choice-renderer> choice-renderer
M: choice-renderer render-view* M: choice-renderer render-view*
drop write ; drop escape-string write ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
escape-string write
</option> ;
: render-options ( text selected -- )
[ [ drop ] [ member? ] 2bi render-option ] curry each ;
M: choice-renderer render-edit* M: choice-renderer render-edit*
<select swap =name select> <select swap =name select>
choices>> [ choices>> swap 1array render-options
<option [ = [ "true" =selected ] when ] keep option>
write
</option>
] with each
</select> ; </select> ;
TUPLE: choice < string ; TUPLE: choice < string ;
@ -357,3 +361,19 @@ TUPLE: choice < string ;
: <choice> ( id choices -- component ) : <choice> ( id choices -- component )
swap choice new-string swap choice new-string
swap <choice-renderer> >>renderer ; swap <choice-renderer> >>renderer ;
! Menu
TUPLE: menu-renderer choices size ;
C: <menu-renderer> menu-renderer
M: menu-renderer render-edit*
<select dup size>> [ number>string =size ] when* swap =name select>
choices>> render-options
</select> ;
TUPLE: menu < string ;
: <menu> ( id choices -- component )
swap menu new-string
swap <menu-renderer> >>renderer ;

2
extra/http/server/components/farkup/farkup.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences farkup accessors USING: splitting kernel io sequences farkup accessors
http.server.components ; http.server.components xml.entities ;
IN: http.server.components.farkup IN: http.server.components.farkup
TUPLE: farkup-renderer < text-renderer ; TUPLE: farkup-renderer < text-renderer ;

4
extra/http/server/components/inspector/inspector.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences inspector accessors USING: splitting kernel io sequences inspector accessors
http.server.components ; http.server.components xml.entities html ;
IN: http.server.components.inspector IN: http.server.components.inspector
SINGLETON: inspector-renderer SINGLETON: inspector-renderer
M: inspector-renderer render-view* M: inspector-renderer render-view*
drop describe ; drop [ describe ] with-html-stream ;
TUPLE: inspector < component ; TUPLE: inspector < component ;

4
extra/http/server/forms/forms.factor
View File

@ -37,9 +37,7 @@ M: form init V{ } clone >>components ;
] with-form ; ] with-form ;
: <form-response> ( form template -- response ) : <form-response> ( form template -- response )
[ components>> components set ] [ components>> components set ] [ <html-content> ] bi* ;
[ "text/html" <content> swap >>body ]
bi* ;
: view-form ( form -- response ) : view-form ( form -- response )
dup view-template>> <form-response> ; dup view-template>> <form-response> ;

15
extra/http/server/server.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar threads sequences prettyprint io.server logging calendar
html.elements accessors math.parser combinators.lib http html html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators tools.vocabs debugger continuations random combinators
destructors io.encodings.8-bit fry classes words ; destructors io.encodings.8-bit fry classes words ;
IN: http.server IN: http.server
@ -22,7 +22,10 @@ GENERIC: call-responder* ( path responder -- response )
<response> <response>
200 >>code 200 >>code
"Document follows" >>message "Document follows" >>message
swap set-content-type ; swap >>content-type ;
: <html-content> ( quot -- response )
"text/html" <content> swap >>body ;
TUPLE: trivial-responder response ; TUPLE: trivial-responder response ;
@ -38,9 +41,7 @@ M: trivial-responder call-responder* nip response>> call ;
</html> ; </html> ;
: <trivial-response> ( code message -- response ) : <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ] 2dup '[ , , trivial-response-body ] <html-content>
"text/html" <content>
swap >>body
swap >>message swap >>message
swap >>code ; swap >>code ;

2
extra/http/server/sessions/sessions-tests.factor
View File

@ -143,7 +143,7 @@ M: foo call-responder*
] with-destructors response set ] with-destructors response set
] unit-test ] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test [ "text/plain" ] [ response get content-type>> ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test [ f ] [ response get cookies>> empty? ] unit-test
] with-scope ] with-scope

39
extra/http/server/static/static.factor
View File

@ -1,21 +1,20 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: calendar html io io.files kernel math math.parser http USING: calendar html io io.files kernel math math.order
http.server namespaces parser sequences strings assocs math.parser http http.server namespaces parser sequences strings
hashtables debugger http.mime sorting html.elements logging assocs hashtables debugger http.mime sorting html.elements
calendar.format accessors io.encodings.binary fry ; logging calendar.format accessors io.encodings.binary fry ;
IN: http.server.static IN: http.server.static
! special maps mime types to quots with effect ( path -- ) ! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special ; TUPLE: file-responder root hook special ;
: file-http-date ( filename -- string ) : modified-since? ( filename -- ? )
file-info modified>> timestamp>http-string ; request get "if-modified-since" header dup [
[ file-info modified>> ] [ rfc822>timestamp ] bi* after?
: last-modified-matches? ( filename -- ? ) ] [
file-http-date dup [ 2drop t
request get "if-modified-since" header = ] if ;
] when ;
: <304> ( -- response ) : <304> ( -- response )
304 "Not modified" <trivial-response> ; 304 "Not modified" <trivial-response> ;
@ -26,16 +25,17 @@ TUPLE: file-responder root hook special ;
: <static> ( root -- responder ) : <static> ( root -- responder )
[ [
<content> <content>
swap swap [
[ file-info size>> "content-length" set-header ] file-info
[ file-http-date "last-modified" set-header ] [ size>> "content-length" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] [ modified>> "last-modified" set-header ] bi
tri ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] bi
] <file-responder> ; ] <file-responder> ;
: serve-static ( filename mime-type -- response ) : serve-static ( filename mime-type -- response )
over last-modified-matches? over modified-since?
[ 2drop <304> ] [ file-responder get hook>> call ] if ; [ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
file-responder get root>> right-trim-separators file-responder get root>> right-trim-separators
@ -65,8 +65,7 @@ TUPLE: file-responder root hook special ;
] simple-html-document ; ] simple-html-document ;
: list-directory ( directory -- response ) : list-directory ( directory -- response )
"text/html" <content> '[ , directory. ] <html-content> ;
swap '[ , directory. ] >>body ;
: find-index ( filename -- path ) : find-index ( filename -- path )
"index.html" append-path dup exists? [ drop f ] unless ; "index.html" append-path dup exists? [ drop f ] unless ;

3
extra/http/server/templating/templating.factor
View File

@ -24,5 +24,4 @@ M: template write-response-body* call-template ;
! responder integration ! responder integration
: serve-template ( template -- response ) : serve-template ( template -- response )
"text/html" <content> '[ , call-template ] <html-content> ;
swap '[ , call-template ] >>body ;

9
extra/webapps/pastebin/pastebin.factor
View File

@ -8,6 +8,7 @@ http.server.actions
http.server.components http.server.components
http.server.components.code http.server.components.code
http.server.templating.chloe http.server.templating.chloe
http.server.auth
http.server.auth.login http.server.auth.login
http.server.boilerplate http.server.boilerplate
http.server.validators http.server.validators
@ -236,13 +237,17 @@ annotation "ANNOTATION"
TUPLE: pastebin < dispatcher ; TUPLE: pastebin < dispatcher ;
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
: <pastebin> ( -- responder ) : <pastebin> ( -- responder )
pastebin new-dispatcher pastebin new-dispatcher
<paste-list-action> "list" add-main-responder <paste-list-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder <feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" add-responder [ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> <protected> "delete-annotation" add-responder [ <annotation> ] "$pastebin/view-paste" { can-delete-pastes? } <delete-annotation-action> <protected> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" 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-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 <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder

9
extra/webapps/planet/planet.factor
View File

@ -11,7 +11,8 @@ http.server.actions
http.server.boilerplate http.server.boilerplate
http.server.templating.chloe http.server.templating.chloe
http.server.components http.server.components
http.server.auth.login ; http.server.auth.login
http.server.auth ;
IN: webapps.planet IN: webapps.planet
TUPLE: planet-factor < dispatcher postings ; TUPLE: planet-factor < dispatcher postings ;
@ -159,11 +160,15 @@ blog "BLOGS"
blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
] ; ] ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
: <planet-factor> ( -- responder ) : <planet-factor> ( -- responder )
planet-factor new-dispatcher planet-factor new-dispatcher
dup <planet-action> "list" add-main-responder dup <planet-action> "list" add-main-responder
dup <feed-action> "feed.xml" add-responder dup <feed-action> "feed.xml" add-responder
dup <planet-factor-admin> <protected> "admin" add-responder dup <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate> <boilerplate>
"planet" planet-template >>template ; "planet" planet-template >>template ;

16
extra/webapps/todo/edit-todo.xml
View File

@ -4,22 +4,22 @@
<t:title>Edit Item</t:title> <t:title>Edit Item</t:title>
<t:form action="$todo-list/edit"> <t:form t:action="$todo-list/edit">
<t:edit component="id" /> <t:edit t:component="id" />
<table> <table>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr> <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr> <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr> <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
</table> </table>
<input type="SUBMIT" value="Done" /> <input type="SUBMIT" value="Done" />
</t:form> </t:form>
<t:a href="$todo-list/view" query="id">View</t:a> <t:a t:href="$todo-list/view" t:query="id">View</t:a>
| |
<t:form action="$todo-list/delete" class="inline"> <t:form t:action="$todo-list/delete" t:class="inline">
<t:edit component="id" /> <t:edit t:component="id" />
<button type="submit" class="link-button link">Delete</button> <button type="submit" class="link-button link">Delete</button>
</t:form> </t:form>

2
extra/webapps/todo/todo.factor
View File

@ -76,5 +76,5 @@ TUPLE: todo-list < dispatcher ;
ctor "$todo-list/list" <delete-action> "delete" add-responder ctor "$todo-list/list" <delete-action> "delete" add-responder
<boilerplate> <boilerplate>
"todo" todo-template >>template "todo" todo-template >>template
<protected> f <protected>
] ; ] ;

4
extra/webapps/todo/view-todo.xml
View File

@ -5,8 +5,8 @@
<t:title>View Item</t:title> <t:title>View Item</t:title>
<table> <table>
<tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr> <tr><th class="field-label">Summary: </th><td><t:view t:component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr> <tr><th class="field-label">Priority: </th><td><t:view t:component="priority" /></td></tr>
</table> </table>
<div class="description"> <div class="description">