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

27
extra/http/http.factor
View File

@ -291,6 +291,12 @@ SYMBOL: max-post-request
: extract-cookies ( request -- request )
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 )
<request>
read-method
@ -377,6 +383,8 @@ code
message
header
cookies
content-type
content-charset
body ;
: <response>
@ -403,7 +411,10 @@ body ;
: read-response-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 )
<response>
@ -422,10 +433,15 @@ body ;
: write-response-message ( response -- response )
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 )
dup header>> clone
over cookies>> f like
[ unparse-cookies "set-cookie" pick set-at ] when*
over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
over unparse-content-type "content-type" pick set-at
write-header ;
GENERIC: write-response-body* ( body -- )
@ -453,9 +469,6 @@ M: response write-full-response ( request response -- )
dup write-response
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 )
>r cookies>> r> '[ , _ name>> = ] find nip ;
@ -466,7 +479,7 @@ M: response write-full-response ( request response -- )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
TUPLE: raw-response
TUPLE: raw-response
version
code
message

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.db
http.server.auth.login
http.server.auth
http.server.forms
http.server.components.inspector
http.server.components
@ -28,6 +29,7 @@ IN: http.server.auth.admin
"new-password" <password> t >>required add-field
"verify-password" <password> t >>required add-field
"email" <email> add-field ;
! "capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form )
"user" <form>
@ -39,6 +41,7 @@ IN: http.server.auth.admin
"verify-password" <password> add-field
"email" <email> add-field
"profile" <inspector> add-field ;
! "capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form )
"user-list" <form>
@ -77,7 +80,7 @@ IN: http.server.auth.admin
"username" value <user>
"realname" value >>realname
"email" value >>email
"new-password" value >>password
"new-password" value >>encoded-password
H{ } clone >>profile
insert-tuple
@ -116,7 +119,7 @@ IN: http.server.auth.admin
{ "new-password" "verify-password" }
[ value empty? ] all? [
same-password-twice
"new-password" value >>password
"new-password" value >>encoded-password
] unless
update-tuple
@ -139,6 +142,10 @@ IN: http.server.auth.admin
TUPLE: user-admin < dispatcher ;
SYMBOL: can-administer-users?
can-administer-users? define-capability
:: <user-admin> ( -- responder )
[let | ctor [ [ <user> ] ] |
user-admin new-dispatcher
@ -148,5 +155,5 @@ TUPLE: user-admin < dispatcher ;
ctor "$user-admin" <delete-user-action> "delete" add-responder
<boilerplate>
"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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel
USING: accessors assocs namespaces kernel sequences
http.server
http.server.sessions
http.server.auth.providers ;
@ -33,3 +33,9 @@ M: filter-responder init-user-profile
: uchange ( quot key -- )
profile swap change-at
user-changed ; inline
SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get push-new ;

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

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

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

@ -9,7 +9,8 @@ user "USERS"
{
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
{ "password" "PASSWORD" BLOB +not-null+ }
{ "salt" "SALT" INTEGER +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } }
{ "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 ;
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 new
@ -17,9 +17,6 @@ GENERIC: update-user ( user provider -- )
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
:: 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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings
io io.streams.string arrays
io io.streams.string arrays locals
html.elements
http
http.server
@ -47,7 +47,7 @@ SYMBOL: nested-template?
SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
next-template get write-html ;
M: f call-template* drop call-next-template ;
@ -68,9 +68,10 @@ M: f call-template* drop call-next-template ;
bi*
] with-scope ; inline
M: boilerplate call-responder*
tuck call-next-method
dup "content-type" header "text/html" = [
clone swap template>>
[ [ with-boilerplate ] 2curry ] curry change-body
] [ nip ] if ;
M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
clone [| body |
[ body responder template>> with-boilerplate ]
] change-body
] when ;

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

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors
http.server.components ;
http.server.components xml.entities ;
IN: http.server.components.code
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
words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math
calendar.format html.elements
calendar.format html.elements xml.entities
http.server.validators ;
IN: http.server.components
@ -18,13 +18,13 @@ TUPLE: field type ;
C: <field> field
M: field render-view* drop write ;
M: field render-view* drop escape-string write ;
M: field render-edit*
<input type>> =type [ =id ] [ =name ] bi =value input/> ;
: render-error ( message -- )
<span "error" =class span> write </span> ;
<span "error" =class span> escape-string write </span> ;
TUPLE: hidden < field ;
@ -232,7 +232,7 @@ TUPLE: text-renderer rows cols ;
text-renderer new-text-renderer ;
M: text-renderer render-view*
drop write ;
drop escape-string write ;
M: text-renderer render-edit*
<textarea
@ -241,7 +241,7 @@ M: text-renderer render-edit*
[ =id ]
[ =name ] bi
textarea>
write
escape-string write
</textarea> ;
TUPLE: text < string ;
@ -261,7 +261,7 @@ TUPLE: html-text-renderer < text-renderer ;
html-text-renderer new-text-renderer ;
M: html-text-renderer render-view*
drop write ;
drop escape-string write ;
TUPLE: html-text < text ;
@ -286,7 +286,7 @@ GENERIC: link-href ( obj -- url )
SINGLETON: link-renderer
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 ;
@ -341,15 +341,19 @@ TUPLE: choice-renderer choices ;
C: <choice-renderer> choice-renderer
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*
<select swap =name select>
choices>> [
<option [ = [ "true" =selected ] when ] keep option>
write
</option>
] with each
choices>> swap 1array render-options
</select> ;
TUPLE: choice < string ;
@ -357,3 +361,19 @@ TUPLE: choice < string ;
: <choice> ( id choices -- component )
swap choice new-string
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
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences farkup accessors
http.server.components ;
http.server.components xml.entities ;
IN: http.server.components.farkup
TUPLE: farkup-renderer < text-renderer ;

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

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

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

@ -37,9 +37,7 @@ M: form init V{ } clone >>components ;
] with-form ;
: <form-response> ( form template -- response )
[ components>> components set ]
[ "text/html" <content> swap >>body ]
bi* ;
[ components>> components set ] [ <html-content> ] bi* ;
: view-form ( 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.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators
threads sequences prettyprint io.server logging calendar
http html html.elements accessors math.parser combinators.lib
tools.vocabs debugger continuations random combinators
destructors io.encodings.8-bit fry classes words ;
IN: http.server
@ -22,7 +22,10 @@ GENERIC: call-responder* ( path responder -- response )
<response>
200 >>code
"Document follows" >>message
swap set-content-type ;
swap >>content-type ;
: <html-content> ( quot -- response )
"text/html" <content> swap >>body ;
TUPLE: trivial-responder response ;
@ -38,9 +41,7 @@ M: trivial-responder call-responder* nip response>> call ;
</html> ;
: <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ]
"text/html" <content>
swap >>body
2dup '[ , , trivial-response-body ] <html-content>
swap >>message
swap >>code ;

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

@ -143,7 +143,7 @@ M: foo call-responder*
] with-destructors response set
] 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
] with-scope

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

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

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

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

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

@ -11,7 +11,8 @@ http.server.actions
http.server.boilerplate
http.server.templating.chloe
http.server.components
http.server.auth.login ;
http.server.auth.login
http.server.auth ;
IN: webapps.planet
TUPLE: planet-factor < dispatcher postings ;
@ -159,11 +160,15 @@ blog "BLOGS"
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 new-dispatcher
dup <planet-action> "list" add-main-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>
"planet" planet-template >>template ;

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

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