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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-06-02 15:43:33 -05:00
parent 96ce30a534 52df2a2b47
commit 9bac6e5852
113 changed files with 2599 additions and 1545 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/io/files/files.factor
View File

@ -147,6 +147,9 @@ PRIVATE>
] if
] unless ;
: file-extension ( filename -- extension )
"." last-split1 nip ;
! File info
TUPLE: file-info type size permissions modified ;

2
extra/combinators/lib/lib.factor
View File

@ -90,7 +90,7 @@ MACRO: 2|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
MACRO: 3|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
[ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte

4
extra/dns/cache/cache.factor vendored
View File

@ -80,10 +80,6 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;

64
extra/dns/forwarding/forwarding.factor
View File

@ -2,10 +2,12 @@
USING: kernel
combinators
vectors
sequences
io.sockets
accessors
combinators.lib
newfx
dns dns.cache ;
dns dns.cache dns.misc ;
IN: dns.forwarding
@ -17,7 +19,10 @@ IN: dns.forwarding
: socket ( -- socket ) (socket) 1st ;
: init-socket ( -- ) f 5353 <inet4> <datagram> 0 (socket) as-mutate ;
: init-socket-on-port ( port -- )
f swap <inet4> <datagram> 0 (socket) as-mutate ;
: init-socket ( -- ) 53 init-socket-on-port ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -27,30 +32,37 @@ IN: dns.forwarding
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
: init-upstream-server ( -- )
upstream-server not
[ resolv-conf-server set-upstream-server ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 1&& <-&& ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
: query->answer/cache ( query -- rrs/NX/f )
{
{ [ dup type>> CNAME = ] [ cache-get* ] }
{
[ dup clone CNAME >>type cache-get* vector? ]
[
dup clone CNAME >>type cache-get* 1st ! query rr/cname
dup rdata>> ! query rr/cname cname
>r swap clone r> ! rr/cname query cname
>>name ! rr/cname query
query->answer/cache ! rr/cname rrs/NX/f
{
{ [ dup vector? ] [ clone push-on ] }
{ [ dup NX = ] [ nip ] }
{ [ dup f = ] [ nip ] }
}
cond
dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
[ nip ]
[
drop
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
[ nip ]
[ ! query rrs
tuck ! rrs query rrs
1st ! rrs query rr/cname
rdata>> ! rrs query name
>r clone r> >>name ! rrs query
query->answer/cache ! rrs rrs/NX/f
dup rrs? [ append ] [ nip ] if
]
}
{ [ t ] [ cache-get* ] }
}
cond ;
if
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -88,4 +100,10 @@ IN: dns.forwarding
message->ba ! addr-spec byte-array
swap ! byte-array addr-spec
socket send
loop ;
loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( -- ) init-socket init-upstream-server loop ;
MAIN: start

12
extra/dns/misc/misc.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
IN: dns.misc
: resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines
[ " " split ] map
[ 1st "nameserver" = ] filter
[ 2nd ] map ;
: resolv-conf-server ( -- ip ) resolv-conf-servers random ;

7
extra/http/server/actions/actions-tests.factor → extra/furnace/actions/actions-tests.factor
View File

@ -1,7 +1,7 @@
USING: kernel http.server.actions validators
USING: kernel furnace.actions validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences splitting accessors ;
IN: http.server.actions.tests
IN: furnace.actions.tests
<action>
[ "a" param "b" param [ string>number ] bi@ + ] >>display
@ -16,9 +16,8 @@ blah
;
[ 25 ] [
init-request
action-request-test-1 lf>crlf
[ read-request ] with-string-reader
request set
init-request
{ } "action-1" get call-responder
] unit-test

29
extra/http/server/actions/actions.factor → extra/furnace/actions/actions.factor
View File

@ -1,9 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators http.server
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
boxes xml.entities html.elements html.components io arrays math ;
IN: http.server.actions
io arrays math boxes
xml.entities
http.server
http.server.responses
furnace
html.elements
html.components
html.templates.chloe
html.templates.chloe.syntax ;
IN: furnace.actions
SYMBOL: params
@ -17,6 +25,8 @@ SYMBOL: rest-param
</ul>
] if ;
CHLOE: validation-messages drop render-validation-messages ;
TUPLE: action rest-param init display validate submit ;
: new-action ( class -- action )
@ -75,7 +85,7 @@ M: action call-responder* ( path action -- response )
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values from-assoc
params get swap validate-values from-object
check-validation ;
: validate-integer-id ( -- )
@ -83,12 +93,9 @@ M: action call-responder* ( path action -- response )
TUPLE: page-action < action template ;
: <chloe-content> ( path -- response )
resolve-template-path <chloe> "text/html" <content> ;
: <page-action> ( -- page )
page-action new-action
dup '[ , template>> <html-content> ] >>display ;
TUPLE: feed-action < action feed ;
: <feed-action> ( -- feed )
feed-action new
dup '[ , feed>> call <feed-content> ] >>display ;
dup '[ , template>> <chloe-content> ] >>display ;

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

@ -2,9 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
http.server
http.server.sessions
http.server.auth.providers ;
IN: http.server.auth
http.server.filters
http.server.dispatchers
furnace.sessions
furnace.auth.providers ;
IN: furnace.auth
SYMBOL: logged-in-user

4
extra/http/server/auth/basic/basic.factor → extra/furnace/auth/basic/basic.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.login
furnace.auth.providers furnace.auth.login
http sequences ;
IN: http.server.auth.basic
IN: furnace.auth.basic
TUPLE: basic-auth < filter-responder realm provider ;

0
extra/http/server/auth/login/boilerplate.xml → extra/furnace/auth/login/boilerplate.xml
View File

0
extra/http/server/auth/login/edit-profile.xml → extra/furnace/auth/login/edit-profile.xml
View File

4
extra/http/server/auth/login/login-tests.factor → extra/furnace/auth/login/login-tests.factor
View File

@ -1,5 +1,5 @@
IN: http.server.auth.login.tests
USING: tools.test http.server.auth.login ;
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
\ <login> must-infer
\ allow-registration must-infer

79
extra/http/server/auth/login/login.factor → extra/furnace/auth/login/login.factor
View File

@ -15,19 +15,22 @@ checksums.sha2
validators
html.components
html.elements
html.templates
html.templates.chloe
urls
http
http.server
http.server.auth
http.server.auth.providers
http.server.auth.providers.db
http.server.actions
http.server.flows
http.server.sessions
http.server.boilerplate ;
http.server.dispatchers
http.server.filters
http.server.responses
furnace
furnace.auth
furnace.auth.providers
furnace.auth.providers.db
furnace.actions
furnace.flows
furnace.sessions
furnace.boilerplate ;
QUALIFIED: smtp
IN: http.server.auth.login
IN: furnace.auth.login
TUPLE: login < dispatcher users checksum ;
@ -59,21 +62,17 @@ M: user-saver dispose
: save-user-after ( user -- )
<user-saver> &dispose drop ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"
3append <chloe> ;
! ! ! Login
: successful-login ( user -- response )
username>> set-uid "$login" end-flow ;
username>> set-uid URL" $login" end-flow ;
: login-failed ( -- * )
"invalid username or password" validation-error
validation-failed ;
: <login-action> ( -- action )
<action>
[ "login" login-template <html-content> ] >>display
<page-action>
{ login "login" } >>template
[
{
@ -102,7 +101,7 @@ M: user-saver dispose
: <register-action> ( -- action )
<page-action>
"register" login-template >>template
{ login "register" } >>template
[
{
@ -134,7 +133,7 @@ M: user-saver dispose
! ! ! Editing user profile
: <edit-profile-action> ( -- action )
<action>
<page-action>
[
logged-in-user get
[ username>> "username" set-value ]
@ -143,7 +142,7 @@ M: user-saver dispose
tri
] >>init
[ "edit-profile" login-template <html-content> ] >>display
{ login "edit-profile" } >>template
[
uid "username" set-value
@ -178,7 +177,7 @@ M: user-saver dispose
drop
"$login" end-flow
URL" $login" end-flow
] >>submit ;
! ! ! Password recovery
@ -186,10 +185,10 @@ M: user-saver dispose
SYMBOL: lost-password-from
: current-host ( -- string )
request get host>> host-name or ;
request get url>> host>> host-name or ;
: new-password-url ( user -- url )
"new-password"
"recover-3"
swap [
[ username>> "username" set ]
[ ticket>> "ticket" set ]
@ -223,8 +222,8 @@ SYMBOL: lost-password-from
"E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action )
<action>
[ "recover-1" login-template <html-content> ] >>display
<page-action>
{ login "recover-1" } >>template
[
{
@ -240,11 +239,15 @@ SYMBOL: lost-password-from
send-password-email
] when*
"recover-2" login-template <html-content>
URL" $login/recover-2" <redirect>
] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
{ login "recover-2" } >>template ;
: <recover-action-3> ( -- action )
<action>
<page-action>
[
{
{ "username" [ v-username ] }
@ -252,7 +255,7 @@ SYMBOL: lost-password-from
} validate-params
] >>init
[ "recover-3" login-template <html-content> ] >>display
{ login "recover-3" } >>template
[
{
@ -272,18 +275,22 @@ SYMBOL: lost-password-from
"new-password" value >>encoded-password
users update-user
"recover-4" login-template <html-content>
URL" $login/recover-4" <redirect>
] [
<400>
<403>
] if*
] >>submit ;
: <recover-action-4> ( -- action )
<page-action>
{ login "recover-4" } >>template ;
! ! ! Logout
: <logout-action> ( -- action )
<action>
[
f set-uid
"$login/login" end-flow
URL" $login" end-flow
] >>submit ;
! ! ! Authentication logic
@ -294,7 +301,7 @@ C: <protected> protected
: show-login-page ( -- response )
begin-flow
"$login/login" f <standard-redirect> ;
URL" $login/login" <redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
@ -317,7 +324,7 @@ M: login call-responder* ( path responder -- response )
: <login-boilerplate> ( responder -- responder' )
<boilerplate>
"boilerplate" login-template >>template ;
{ login "boilerplate" } >>template ;
: <login> ( responder -- auth )
login new-dispatcher
@ -340,8 +347,12 @@ M: login call-responder* ( path responder -- response )
: allow-password-recovery ( login -- login )
<recover-action-1> <login-boilerplate>
"recover-password" add-responder
<recover-action-2> <login-boilerplate>
"recover-2" add-responder
<recover-action-3> <login-boilerplate>
"new-password" add-responder ;
"recover-3" add-responder
<recover-action-4> <login-boilerplate>
"recover-4" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;

4
extra/http/server/auth/login/login.xml → extra/furnace/auth/login/login.xml
View File

@ -30,11 +30,11 @@
</t:form>
<p>
<t:if code="http.server.auth.login:login-failed?">
<t:if t:code="furnace.auth.login:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
<t:if code="http.server.auth.login:allow-password-recovery?">
<t:if t:code="furnace.auth.login:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>

0
extra/http/server/auth/login/recover-1.xml → extra/furnace/auth/login/recover-1.xml
View File

0
extra/http/server/auth/login/recover-2.xml → extra/furnace/auth/login/recover-2.xml
View File

0
extra/http/server/auth/login/recover-3.xml → extra/furnace/auth/login/recover-3.xml
View File

0
extra/http/server/auth/login/recover-4.xml → extra/furnace/auth/login/recover-4.xml
View File

0
extra/http/server/auth/login/register.xml → extra/furnace/auth/login/register.xml
View File

6
extra/http/server/auth/providers/assoc/assoc-tests.factor → extra/furnace/auth/providers/assoc/assoc-tests.factor
View File

@ -1,6 +1,6 @@
IN: http.server.auth.providers.assoc.tests
USING: http.server.actions http.server.auth.providers
http.server.auth.providers.assoc http.server.auth.login
IN: furnace.auth.providers.assoc.tests
USING: furnace.actions furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
<action> <login>

5
extra/http/server/auth/providers/assoc/assoc.factor → extra/furnace/auth/providers/assoc/assoc.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.auth.providers.assoc
USING: accessors assocs kernel
http.server.auth.providers ;
IN: furnace.auth.providers.assoc
USING: accessors assocs kernel furnace.auth.providers ;
TUPLE: users-in-memory assoc ;

10
extra/http/server/auth/providers/db/db-tests.factor → extra/furnace/auth/providers/db/db-tests.factor
View File

@ -1,8 +1,8 @@
IN: http.server.auth.providers.db.tests
USING: http.server.actions
http.server.auth.login
http.server.auth.providers
http.server.auth.providers.db tools.test
IN: furnace.auth.providers.db.tests
USING: furnace.actions
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;

4
extra/http/server/auth/providers/db/db.factor → extra/furnace/auth/providers/db/db.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types accessors
http.server.auth.providers kernel continuations
furnace.auth.providers kernel continuations
classes.singleton ;
IN: http.server.auth.providers.db
IN: furnace.auth.providers.db
user "USERS"
{

4
extra/http/server/auth/providers/null/null.factor → extra/furnace/auth/providers/null/null.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
USING: furnace.auth.providers kernel ;
IN: furnace.auth.providers.null
TUPLE: no-users ;

2
extra/http/server/auth/providers/providers.factor → extra/furnace/auth/providers/providers.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors random math.parser locals
sequences math ;
IN: http.server.auth.providers
IN: furnace.auth.providers
TUPLE: user
username realname

16
extra/http/server/boilerplate/boilerplate.factor → extra/furnace/boilerplate/boilerplate.factor
View File

@ -1,8 +1,12 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces http.server html.templates
locals ;
IN: http.server.boilerplate
USING: accessors kernel namespaces
html.templates html.templates.chloe
locals
http.server
http.server.filters
furnace ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template ;
@ -12,6 +16,10 @@ M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
clone [| body |
[ body responder template>> with-boilerplate ]
[
body
responder template>> resolve-template-path <chloe>
with-boilerplate
]
] change-body
] when ;

4
extra/furnace/db/db-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: furnace.db.tests
USING: tools.test furnace.db ;
\ <db-persistence> must-infer

7
extra/http/server/db/db.factor → extra/furnace/db/db.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.pools io.pools http.server http.server.sessions
kernel accessors continuations namespaces destructors ;
IN: http.server.db
USING: kernel accessors continuations namespaces destructors
db db.pools io.pools http.server http.server.filters
furnace.sessions ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;

62
extra/http/server/flows/flows.factor → extra/furnace/flows/flows.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser
html.elements http http.server http.server.sessions ;
IN: http.server.flows
assocs assocs.lib hashtables math.parser urls combinators
furnace http http.server http.server.filters furnace.sessions
html.elements html.templates.chloe.syntax ;
IN: furnace.flows
TUPLE: flows < filter-responder ;
@ -11,24 +12,28 @@ C: <flows> flows
: begin-flow* ( -- id )
request get
[ path>> ] [ request-params ] [ method>> ] tri 3array
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
flows sget set-at-unique
session-changed ;
: end-flow-post ( path params -- response )
: end-flow-post ( url post-data -- response )
request [
clone
"POST" >>method
swap >>post-data
swap >>path
swap >>url
] change
request get path>> split-path
request get url>> path>> split-path
flows get responder>> call-responder ;
: end-flow* ( default id -- response )
flows sget at
[ first3 "POST" = [ end-flow-post ] [ <standard-redirect> ] if ]
[ f <standard-redirect> ] ?if ;
: end-flow* ( url id -- response )
flows sget at [
first3 {
{ "GET" [ drop <redirect> ] }
{ "HEAD" [ drop <redirect> ] }
{ "POST" [ end-flow-post ] }
} case
] [ <redirect> ] ?if ;
SYMBOL: flow-id
@ -40,10 +45,30 @@ SYMBOL: flow-id
: end-flow ( default -- response )
flow-id get end-flow* ;
: add-flow-id ( query -- query' )
M: flows call-responder*
dup flows set
flow-id-key request get request-params at flow-id set
call-next-method ;
M: flows init-session*
H{ } clone flows sset
call-next-method ;
M: flows link-attr ( tag -- )
drop
"flow" optional-attr {
{ "none" [ flow-id off ] }
{ "begin" [ begin-flow ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: flows modify-query ( query responder -- query' )
drop
flow-id get [ flow-id-key associate assoc-union ] when* ;
: flow-form-field ( -- )
M: flows hidden-form-field ( responder -- )
drop
flow-id get [
<input
"hidden" =type
@ -51,14 +76,3 @@ SYMBOL: flow-id
=value
input/>
] when* ;
M: flows call-responder*
dup flows set
[ add-flow-id ] add-link-hook
[ flow-form-field ] add-form-hook
flow-id-key request get request-params at flow-id set
call-next-method ;
M: flows init-session*
H{ } clone flows sset
call-next-method ;

30
extra/furnace/furnace-tests.factor Normal file
View File

@ -0,0 +1,30 @@
IN: furnace.tests
USING: http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;
C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
"text/plain" <content> ;
[ ] [
<dispatcher>
<dispatcher>
<funny-dispatcher>
<base-path-check-responder> "c" add-responder
"b" add-responder
"a" add-responder
main-responder set
] unit-test
[ "/a/b/" ] [
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test

183
extra/furnace/furnace.factor Normal file
View File

@ -0,0 +1,183 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
continuations namespaces sequences splitting words
vocabs.loader classes
fry urls multiline
xml
xml.data
xml.writer
xml.utilities
html.components
html.elements
html.templates
html.templates.chloe
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
IN: furnace
: nested-responders ( -- seq )
responder-nesting get a:values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class word-name = ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: vocab-path ( vocab -- path )
dup vocab-dir vocab-append-path ;
: resolve-template-path ( pair -- path )
[
first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
: adjust-url ( url -- url' )
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
GENERIC: hidden-form-field ( responder -- )
M: object hidden-form-field drop ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [ post-data>> ] }
} case ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
! Chloe tags
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
[ "title" required-attr ]
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
swap >>query
swap >>path
adjust-url relative-to-request
add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[
<a
dup link-attrs
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if
<url>
swap >>query
swap >>path
adjust-url relative-to-request =href
a>
] with-scope ;
CHLOE: a
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: form-start-tag ( tag -- )
[
[
<form
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
form>
] [
[ hidden-form-field ] each-responder
"for" optional-attr [ hidden render ] when*
] bi
] with-scope ;
CHLOE: form
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
tag-attrs swap update ;
CHLOE: button
button-tag-markup string>xml delegate
{
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
"code" required-attr attr>word execute ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

7
extra/furnace/json/json.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: json.writer http.server.responses ;
IN: furnace.json
: <json-content> ( body -- response )
>json "application/json" <content> ;

14
extra/furnace/rss/rss.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry
rss http.server.responses furnace.actions ;
IN: furnace.rss
: <feed-content> ( body -- response )
feed>xml "application/atom+xml" <content> ;
TUPLE: feed-action < action feed ;
: <feed-action> ( -- feed )
feed-action new-action
dup '[ , feed>> call <feed-content> ] >>display ;

0
extra/http/server/sessions/authors.txt → extra/furnace/sessions/authors.txt
View File

36
extra/http/server/sessions/sessions-tests.factor → extra/furnace/sessions/sessions-tests.factor
View File

@ -1,8 +1,10 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.actions http.server math namespaces kernel accessors
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
math namespaces kernel accessors
prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations ;
sequences db db.sqlite continuations urls math.parser
furnace ;
: with-session
[
@ -18,15 +20,16 @@ M: foo init-session* drop 0 "x" sset ;
M: foo call-responder*
2drop
"x" [ 1+ ] schange
[ "x" sget pprint ] <html-content> ;
"x" sget number>string "text/html" <content> ;
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
@ -36,21 +39,21 @@ M: foo call-responder*
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
dup url>> "/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action>
<action>
[ [ ] <text-content> exit-with ] >>display ;
[ [ ] "text/plain" <content> exit-with ] >>display ;
[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
"auth-test.db" temp-file sqlite-db [
init-request
<request> init-request
init-sessions-table
[ ] [
@ -112,8 +115,8 @@ M: foo call-responder*
[
<request>
"GET" >>method
"/" >>path
"GET" >>method
dup url>> "/" >>path drop
request set
{ "etc" } sessions get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
@ -131,8 +134,9 @@ M: foo call-responder*
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
request set
[

9
extra/http/server/sessions/sessions.factor → extra/furnace/sessions/sessions.factor
View File

@ -4,8 +4,9 @@ USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms
db db.tuples db.types
http http.server html.elements ;
IN: http.server.sessions
http http.server http.server.dispatchers http.server.filters
html.elements furnace ;
IN: furnace.sessions
TUPLE: session id expires uid namespace changed? ;
@ -136,7 +137,8 @@ M: session-saver dispose
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
: session-form-field ( -- )
M: sessions hidden-form-field ( responder -- )
drop
<input
"hidden" =type
session-id-key =name
@ -144,7 +146,6 @@ M: session-saver dispose
input/> ;
M: sessions call-responder* ( path responder -- response )
[ session-form-field ] add-form-hook
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;

4
extra/html/components/components-tests.factor
View File

@ -11,7 +11,7 @@ html.components namespaces ;
TUPLE: color red green blue ;
[ ] [ 1 2 3 color boa from-tuple ] unit-test
[ ] [ 1 2 3 color boa from-object ] unit-test
[ 1 ] [ "red" value ] unit-test
@ -107,7 +107,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
[
"delivery"
<checkbox>

43
extra/html/components/components.factor
View File

@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements html.streams xmode.code2html farkup inspector
lcs.diff2html ;
lcs.diff2html urls ;
IN: html.components
SYMBOL: values
@ -19,9 +19,9 @@ SYMBOL: values
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
: from-assoc ( assoc -- ) values get swap update ;
: from-tuple ( tuple -- ) <mirror> from-assoc ;
: from-object ( object -- )
dup assoc? [ <mirror> ] unless
values get swap update ;
: deposit-values ( destination names -- )
[ dup value ] H{ } map>assoc update ;
@ -32,24 +32,19 @@ SYMBOL: values
: with-each-index ( seq quot -- )
'[
[
blank-values 1+ "index" set-value @
values [ clone ] change
1+ "index" set-value @
] with-scope
] each-index ; inline
: with-each-value ( seq quot -- )
'[ "value" set-value @ ] with-each-index ; inline
: with-each-assoc ( seq quot -- )
'[ from-assoc @ ] with-each-index ; inline
: with-each-object ( seq quot -- )
'[ from-object @ ] with-each-index ; inline
: with-each-tuple ( seq quot -- )
'[ from-tuple @ ] with-each-index ; inline
: with-assoc-values ( assoc quot -- )
'[ blank-values , from-assoc @ ] with-scope ; inline
: with-tuple-values ( assoc quot -- )
'[ blank-values , from-tuple @ ] with-scope ; inline
: with-values ( object quot -- )
'[ blank-values , from-object @ ] with-scope ; inline
: nest-values ( name quot -- )
swap [
@ -58,22 +53,6 @@ SYMBOL: values
] with-scope
] dip set-value ; inline
: nest-tuple ( name quot -- )
swap [
[
H{ } clone [ <mirror> values set call ] keep
] with-scope
] dip set-value ; inline
: object>string ( object -- string )
{
{ [ dup real? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup string? ] [ ] }
{ [ dup word? ] [ word-name ] }
{ [ dup not ] [ drop "" ] }
} cond ;
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
@ -174,7 +153,7 @@ M: checkbox render*
<input
"checkbox" =type
swap =name
swap [ "true" =selected ] when
swap [ "true" =checked ] when
input>
label>> escape-string write
</input> ;

20
extra/html/elements/elements.factor
View File

@ -4,7 +4,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects ;
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators calendar calendar.format ;
IN: html.elements
@ -126,11 +127,22 @@ SYMBOL: html
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
: object>string ( object -- string )
#! Should this be generic and in the core?
{
{ [ dup real? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup url? ] [ url>string ] }
{ [ dup string? ] [ ] }
{ [ dup word? ] [ word-name ] }
{ [ dup not ] [ drop "" ] }
} cond ;
: write-attr ( value name -- )
" " write-html
write-html
"='" write-html
escape-quoted-string write-html
object>string escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
@ -162,7 +174,7 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple"
"media" "title" "multiple" "checked"
] [ define-attribute-word ] each
>>
@ -178,7 +190,7 @@ SYMBOL: html
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
</html> ; inline
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;

37
extra/html/templates/chloe/chloe-tests.factor
View File

@ -27,8 +27,7 @@ IN: html.templates.chloe.tests
: test-template ( name -- template )
"resource:extra/html/templates/chloe/test/"
swap
".xml" 3append <chloe> ;
prepend <chloe> ;
[ "Hello world" ] [
[
@ -50,7 +49,7 @@ IN: html.templates.chloe.tests
[
[
"test2" test-template call-template
] "test3" test-template with-boilerplate
] [ "test3" test-template ] with-boilerplate
] run-template
] unit-test
@ -70,24 +69,6 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
SYMBOL: test6-aux?
[ "True" ] [
[
test6-aux? on
"test6" test-template call-template
] run-template
] unit-test
SYMBOL: test7-aux?
[ "" ] [
[
test7-aux? off
"test7" test-template call-template
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
@ -128,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
[
"test9" test-template call-template
"test7" test-template call-template
] run-template [ blank? not ] filter
] unit-test
@ -143,7 +124,7 @@ TUPLE: person first-name last-name ;
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
"test10" test-template call-template
"test8" test-template call-template
] run-template [ blank? not ] filter
] unit-test
@ -156,6 +137,14 @@ TUPLE: person first-name last-name ;
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
"test11" test-template call-template
"test9" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ ] [ 1 "id" set-value ] unit-test
[ "<a name=\"1\">Hello</a>" ] [
[
"test10" test-template call-template
] run-template
] unit-test

281
extra/html/templates/chloe/chloe.factor
View File

@ -3,19 +3,16 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math
unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates
http.server
http.server.auth
http.server.flows
http.server.actions
http.server.sessions ;
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
SYMBOL: tag-stack
TUPLE: chloe path ;
@ -23,8 +20,6 @@ C: <chloe> chloe
DEFER: process-template
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
: chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = ] assoc-filter ;
@ -38,35 +33,23 @@ DEFER: process-template
[ t ]
} cond nip ;
SYMBOL: tags
MEMO: chloe-name ( string -- name )
name new
swap >>tag
chloe-ns >>url ;
: required-attr ( tag name -- value )
dup chloe-name rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
chloe-name swap at ;
: process-tag-children ( tag -- )
[ process-template ] each ;
CHLOE: chloe process-tag-children ;
: children>string ( tag -- string )
[ process-tag-children ] with-string-writer ;
: title-tag ( tag -- )
children>string set-title ;
CHLOE: title children>string set-title ;
: write-title-tag ( tag -- )
CHLOE: write-title
drop
"head" tags get member? "title" tags get member? not and
"head" tag-stack get member?
"title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
: style-tag ( tag -- )
CHLOE: style
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
@ -76,146 +59,12 @@ MEMO: chloe-name ( string -- name )
drop children>string
] if add-style ;
: write-style-tag ( tag -- )
CHLOE: write-style
drop <style> write-style </style> ;
: atom-tag ( tag -- )
[ "title" required-attr ]
[ "href" required-attr ]
bi set-atom-feed ;
CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
: write-atom-tag ( tag -- )
drop
"head" tags get member? [
write-atom-feed
] [
atom-feed get value>> second write
] if ;
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: flow-attr ( tag -- )
"flow" optional-attr {
{ "none" [ flow-id off ] }
{ "begin" [ begin-flow ] }
{ "current" [ ] }
{ f [ ] }
} case ;
: session-attr ( tag -- )
"session" optional-attr {
{ "none" [ session off flow-id off ] }
{ "current" [ ] }
{ f [ ] }
} case ;
: a-start-tag ( tag -- )
[
<a
dup flow-attr
dup session-attr
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if link>string =href
a>
] with-scope ;
: a-tag ( tag -- )
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: form-start-tag ( tag -- )
[
[
<form
"POST" =method
{
[ flow-attr ]
[ session-attr ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
} cleave
form>
] [
hidden-form-field
"for" optional-attr [ hidden render ] when*
] bi
] with-scope ;
: form-tag ( tag -- )
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
DEFER: process-chloe-tag
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
tag-attrs swap update ;
: button-tag ( tag -- )
button-tag-markup string>xml delegate
{
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
t swap
{
[ "code" optional-attr [ attr>word execute and ] when* ]
[ "var" optional-attr [ attr>var get and ] when* ]
[ "svar" optional-attr [ attr>var sget and ] when* ]
[ "uvar" optional-attr [ attr>var uget and ] when* ]
[ "value" optional-attr [ value and ] when* ]
} cleave ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
: even-tag ( tag -- )
"index" value even? [ process-tag-children ] [ drop ] if ;
: odd-tag ( tag -- )
"index" value odd? [ process-tag-children ] [ drop ] if ;
: (each-tag) ( tag quot -- )
[
[ "values" required-attr value ] keep
'[ , process-tag-children ]
] dip call ; inline
: each-tag ( tag -- )
[ with-each-value ] (each-tag) ;
: each-tuple-tag ( tag -- )
[ with-each-tuple ] (each-tag) ;
: each-assoc-tag ( tag -- )
[ with-each-assoc ] (each-tag) ;
CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
: (bind-tag) ( tag quot -- )
[
@ -223,94 +72,56 @@ STRING: button-tag-markup
'[ , process-tag-children ]
] dip call ; inline
: bind-tuple-tag ( tag -- )
[ with-tuple-values ] (bind-tag) ;
CHLOE: each [ with-each-value ] (bind-tag) ;
: bind-assoc-tag ( tag -- )
[ with-assoc-values ] (bind-tag) ;
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
CHLOE: bind [ with-values ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
: validation-messages-tag ( tag -- )
drop render-validation-messages ;
CHLOE: comment drop ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
CHLOE: call-next-template drop call-next-template ;
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap tag>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
CHLOE-SINGLETON: farkup
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ process-tag-children ] }
! HTML head
{ "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "atom" [ atom-tag ] }
{ "write-atom" [ write-atom-tag ] }
! HTML elements
{ "a" [ a-tag ] }
{ "button" [ button-tag ] }
! Components
{ "label" [ label singleton-component-tag ] }
{ "link" [ link singleton-component-tag ] }
{ "code" [ code tuple-component-tag ] }
{ "farkup" [ farkup singleton-component-tag ] }
{ "inspector" [ inspector singleton-component-tag ] }
{ "comparison" [ comparison singleton-component-tag ] }
{ "html" [ html singleton-component-tag ] }
! Forms
{ "form" [ form-tag ] }
{ "error-message" [ error-message-tag ] }
{ "validation-messages" [ validation-messages-tag ] }
{ "hidden" [ hidden singleton-component-tag ] }
{ "field" [ field tuple-component-tag ] }
{ "password" [ password tuple-component-tag ] }
{ "textarea" [ textarea tuple-component-tag ] }
{ "choice" [ choice tuple-component-tag ] }
{ "checkbox" [ checkbox tuple-component-tag ] }
! Control flow
{ "if" [ if-tag ] }
{ "even" [ even-tag ] }
{ "odd" [ odd-tag ] }
{ "each" [ each-tag ] }
{ "each-assoc" [ each-assoc-tag ] }
{ "each-tuple" [ each-tuple-tag ] }
{ "bind-assoc" [ bind-assoc-tag ] }
{ "bind-tuple" [ bind-tuple-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " prepend throw ]
} case ;
dup name-tag dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
[ name-tag >lower tags get push ]
[ name-tag >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tags get pop* ]
[ drop tag-stack get pop* ]
} cleave ;
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
[ "@" ?head [ value object>string ] when ] assoc-map
] change-attrs
] when ;
: process-template ( xml -- )
expand-attrs
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
@ -319,7 +130,7 @@ STRING: button-tag-markup
: process-chloe ( xml -- )
[
V{ } clone tags set
V{ } clone tag-stack set
nested-template? get [
process-template
@ -334,6 +145,6 @@ STRING: button-tag-markup
] with-scope ;
M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ;
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template

61
extra/html/templates/chloe/syntax/syntax.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates ;
SYMBOL: tags
tags global [ H{ } clone or ] change-at
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
: CHLOE:
scan parse-definition define-chloe-tag ; parsing
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
MEMO: chloe-name ( string -- name )
name new
swap >>tag
chloe-ns >>url ;
: required-attr ( tag name -- value )
dup chloe-name rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
chloe-name swap at ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
: CHLOE-SINGLETON:
scan-word
[ word-name ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap tag>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
: CHLOE-TUPLE:
scan-word
[ word-name ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

14
extra/html/templates/chloe/test/test10.xml
View File

@ -1,14 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
<t:each-tuple t:values="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:each-tuple>
</table>
</t:chloe>

14
extra/html/templates/chloe/test/test11.xml
View File

@ -1,14 +0,0 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
<t:each-assoc t:values="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:each-assoc>
</table>
</t:chloe>

24
extra/html/templates/chloe/test/test6.xml
View File

@ -2,8 +2,26 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if t:var="html.templates.chloe.tests:test6-aux?">
True
</t:if>
<t:label t:name="label" />
<t:link t:name="link" />
<t:code t:name="code" mode="mode" />
<t:farkup t:name="farkup" />
<t:inspector t:name="inspector" />
<t:html t:name="html" />
<t:field t:name="field" t:size="13" />
<t:password t:name="password" t:size="10" />
<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
<t:choice t:name="choice" t:choices="choices" />
<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
</t:chloe>

8
extra/html/templates/chloe/test/test7.xml
View File

@ -2,8 +2,10 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if t:var="html.templates.chloe.tests:test7-aux?">
True
</t:if>
<ul>
<t:each t:name="numbers">
<li><t:label t:name="value"/></li>
</t:each>
</ul>
</t:chloe>

29
extra/html/templates/chloe/test/test8.xml
View File

@ -2,26 +2,13 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:label t:name="label" />
<t:link t:name="link" />
<t:code t:name="code" mode="mode" />
<t:farkup t:name="farkup" />
<t:inspector t:name="inspector" />
<t:html t:name="html" />
<t:field t:name="field" t:size="13" />
<t:password t:name="password" t:size="10" />
<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
<t:choice t:name="choice" t:choices="choices" />
<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
<table>
<t:bind-each t:name="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:bind-each>
</table>
</t:chloe>

10
extra/html/templates/chloe/test/test9.xml
View File

@ -1,11 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<ul>
<t:each t:values="numbers">
<li><t:label t:name="value"/></li>
</t:each>
</ul>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>

25
extra/html/templates/templates.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html.elements io.streams.string quotations ;
arrays strings html.elements io.streams.string
quotations xml.data xml.writer ;
IN: html.templates
MIXIN: template
@ -13,6 +14,8 @@ M: string call-template* write ;
M: callable call-template* call ;
M: xml call-template* write-xml ;
M: object call-template* output-stream get stream-copy ;
ERROR: template-error template error ;
@ -43,17 +46,17 @@ SYMBOL: style
: write-style ( -- )
style get >string write ;
SYMBOL: atom-feed
SYMBOL: atom-feeds
: set-atom-feed ( title url -- )
2array atom-feed get >box ;
: add-atom-feed ( title url -- )
2array atom-feeds get push ;
: write-atom-feed ( -- )
atom-feed get value>> [
: write-atom-feeds ( -- )
atom-feeds get [
<link "alternate" =rel "application/atom+xml" =type
[ first =title ] [ second =href ] bi
first2 [ =title ] [ =href ] bi*
link/>
] when* ;
] each ;
SYMBOL: nested-template?
@ -66,9 +69,9 @@ M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
atom-feed get [ <box> atom-feed set ] unless
style get [ SBUF" " clone style set ] unless
title [ <box> or ] change
style [ SBUF" " clone or ] change
atom-feeds [ V{ } like ] change
[
[

24
extra/http/client/client-tests.factor
View File

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
tuple-syntax namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
@ -10,36 +10,26 @@ tuple-syntax namespaces ;
[
TUPLE{ request
protocol: http
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
method: "GET"
host: "www.apple.com"
port: 80
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[
"http://www.apple.com/index.html"
<get-request>
] with-scope
"http://www.apple.com/index.html"
<get-request>
] unit-test
[
TUPLE{ request
protocol: https
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
method: "GET"
host: "www.amazon.com"
port: 443
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[
"https://www.amazon.com/index.html"
<get-request>
] with-scope
"https://www.amazon.com/index.html"
<get-request>
] unit-test

16
extra/http/client/client.factor
View File

@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary io.streams.duplex
fry debugger inspector ascii ;
fry debugger inspector ascii urls ;
IN: http.client
: max-redirects 10 ;
@ -21,14 +21,16 @@ DEFER: http-request
SYMBOL: redirects
: redirect-url ( request url -- request )
'[ , >url derive-url ensure-port ] change-url ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
redirects inc
redirects get max-redirects < [
request get
swap "location" header dup absolute-url?
[ request-with-url ] [ request-with-path ] if
swap "location" header redirect-url
"GET" >>method http-request
] [
too-many-redirects
@ -51,7 +53,7 @@ PRIVATE>
: http-request ( request -- response data )
dup request [
dup request-addr latin1 [
dup url>> url-addr latin1 [
1 minutes timeouts
write-request
read-response
@ -62,8 +64,8 @@ PRIVATE>
: <get-request> ( url -- request )
<request>
swap request-with-url
"GET" >>method ;
"GET" >>method
swap >url ensure-port >>url ;
: http-get* ( url -- response data )
<get-request> http-request ;
@ -101,7 +103,7 @@ M: download-failed error.
: <post-request> ( content-type content url -- request )
<request>
"POST" >>method
swap request-with-url
swap >url ensure-port >>url
swap >>post-data
swap >>post-data-type ;

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

@ -1,37 +1,8 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations ;
assocs io.sockets db db.sqlite continuations urls ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ "/" ] [ "http://foo.com" url>path ] unit-test
[ "/" ] [ "http://foo.com/" url>path ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
@ -45,11 +16,8 @@ blah
[
TUPLE{ request
protocol: http
port: 80
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
method: "GET"
path: "/bar"
query: H{ }
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah"
@ -85,14 +53,10 @@ Host: www.sex.com
[
TUPLE{ request
protocol: http
port: 80
url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
method: "HEAD"
path: "/bar"
query: H{ }
version: "1.1"
header: H{ { "host" "www.sex.com" } }
host: "www.sex.com"
cookies: V{ }
}
] [
@ -101,6 +65,15 @@ Host: www.sex.com
] with-string-reader
] unit-test
STRING: read-request-test-3
GET nested HTTP/1.0
;
[ read-request-test-3 [ read-request ] with-string-reader ]
[ "Bad request: URL" = ]
must-fail-with
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8
@ -145,14 +118,16 @@ read-response-test-1' 1array [
] unit-test
! Live-fire exercise
USING: http.server http.server.static http.server.sessions
http.server.actions http.server.auth.login http.server.db http.client
USING: http.server http.server.static furnace.sessions
furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads ;
accessors namespaces threads
http.server.responses http.server.redirection
http.server.dispatchers ;
: add-quit-action
<action>
[ stop-server [ "Goodbye" write ] <html-content> ] >>display
[ stop-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
@ -171,7 +146,7 @@ test-db [
"resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
[ "redirect-loop" f <standard-redirect> ] >>display
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
@ -186,16 +161,6 @@ test-db [
"http://localhost:1237/nested/foo.html" http-get =
] unit-test
! Try with a slightly malformed request
[ t ] [
"localhost" 1237 <inet> ascii [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
read-crlf drop
read-header
] with-client "location" swap at "/" head?
] unit-test
[ "http://localhost:1237/redirect-loop" http-get ]
[ too-many-redirects? ] must-fail-with
@ -237,7 +202,7 @@ test-db [
[ ] [
[
<dispatcher>
<action> [ [ "Hi" write ] <text-content> ] >>display
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
<sessions>
"" add-responder

239
extra/http/http.factor
View File

@ -6,90 +6,16 @@ assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets.secure
io io.server io.sockets.secure
unicode.case unicode.categories qualified
html.templates ;
urls html.templates ;
EXCLUDE: fry => , ;
IN: http
SINGLETON: http
SINGLETON: https
GENERIC: http-port ( protocol -- port )
M: http http-port drop 80 ;
M: https http-port drop 443 ;
GENERIC: protocol>string ( protocol -- string )
M: http protocol>string drop "http" ;
M: https protocol>string drop "https" ;
: string>protocol ( string -- protocol )
{
{ "http" [ http ] }
{ "https" [ https ] }
[ "Unknown protocol: " swap append throw ]
} case ;
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
: crlf "\r\n" write ;
: add-header ( value key assoc -- )
@ -130,6 +56,7 @@ M: https protocol>string drop "https" ;
{
{ [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
{ [ dup url? ] [ url>string ] }
{ [ dup string? ] [ ] }
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
} cond ;
@ -145,42 +72,6 @@ M: https protocol>string drop "https" ;
header-value>string check-header-string write crlf
] assoc-each crlf ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
[
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
{
{ [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
[ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ;
: <cookie> ( value name -- cookie )
@ -236,12 +127,8 @@ TUPLE: cookie name value path domain expires max-age http-only ;
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
protocol
host
port
method
path
query
url
version
header
post-data
@ -254,51 +141,30 @@ cookies ;
: <request>
request new
"1.1" >>version
http >>protocol
<url>
"http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
pick query>> set-at ;
: chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
: url>path ( url -- path )
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
url-decode
dup { "http://" "https://" } [ head? ] with contains?
[ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
: read-query ( request -- request )
" " read-until
[ "Bad request: query params" throw ] unless
query>assoc >>query ;
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
: read-url ( request -- request )
" ?" read-until {
{ CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
{ CHAR: ? [ url>path >>path read-query ] }
[ "Bad request: URL" throw ]
} case ;
" " read-until [
dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
] [ "Bad request: URL" throw ] if ;
: parse-version ( string -- version )
"HTTP/" ?head [ "Bad version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
"HTTP/" ?head [ "Bad request: version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
: read-request-version ( request -- request )
read-crlf [ CHAR: \s = ] left-trim
@ -325,13 +191,11 @@ SYMBOL: max-post-request
: read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ;
: parse-host ( string -- host port )
"." ?tail drop ":" split1
dup [ string>number ] when ;
: extract-host ( request -- request )
dup [ "host" header parse-host ] keep protocol>> http-port or
[ >>host ] [ >>port ] bi* ;
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
ensure-port
drop ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
@ -349,6 +213,9 @@ SYMBOL: max-post-request
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: detect-protocol ( request -- request )
dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
: read-request ( -- request )
<request>
read-method
@ -356,6 +223,7 @@ SYMBOL: max-post-request
read-request-version
read-request-header
read-post-data
detect-protocol
extract-host
extract-post-data-type
parse-post-data
@ -364,15 +232,8 @@ SYMBOL: max-post-request
: write-method ( request -- request )
dup method>> write bl ;
: (link>string) ( url query -- url' )
[ url-encode ] [ assoc>query ] bi*
dup empty? [ drop ] [ "?" swap 3append ] if ;
: write-url ( request -- )
[ path>> ] [ query>> ] bi (link>string) write ;
: write-request-url ( request -- request )
dup write-url bl ;
dup url>> relative-url url>string write bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
@ -383,24 +244,13 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type
] if ;
GENERIC: protocol-addr ( request protocol -- addr )
M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <secure> ;
: request-addr ( request -- addr )
dup protocol>> protocol-addr ;
: request-host ( request -- string )
[ host>> ] [ port>> ] bi dup http http-port =
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ over request-host "host" pick set-at ] when
over url>> host>> [ over url>> url-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@ -419,39 +269,6 @@ M: https protocol-addr
flush
drop ;
: request-with-path ( request path -- request )
[ "/" prepend ] [ "/" ] if*
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
: request-with-url ( request url -- request )
":" split1
[ string>protocol >>protocol ]
[
"//" ?head [ "Invalid URL" throw ] unless
"/" split1
[
parse-host [ >>host ] [ >>port ] bi*
dup protocol>> http-port '[ , or ] change-port
]
[ request-with-path ]
bi*
] bi* ;
: request-url ( request -- url )
[
[
dup host>> [
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
[ write-url ]
tri
] with-string-writer ;
GENERIC: write-response ( response -- )
GENERIC: write-full-response ( request response -- )
@ -556,7 +373,7 @@ body ;
: <raw-response> ( -- response )
raw-response new
"1.1" >>version ;
"1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version

35
extra/http/mime/mime.factor
View File

@ -1,35 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io assocs kernel sequences math namespaces splitting ;
IN: http.mime
: file-extension ( filename -- extension )
"." split dup length 1 <= [ drop f ] [ peek ] if ;
: mime-type ( filename -- mime-type )
file-extension "mime-types" get at "application/octet-stream" or ;
H{
{ "html" "text/html" }
{ "txt" "text/plain" }
{ "xml" "text/xml" }
{ "css" "text/css" }
{ "gif" "image/gif" }
{ "png" "image/png" }
{ "jpg" "image/jpeg" }
{ "jpeg" "image/jpeg" }
{ "jar" "application/octet-stream" }
{ "zip" "application/octet-stream" }
{ "tgz" "application/octet-stream" }
{ "tar.gz" "application/octet-stream" }
{ "gz" "application/octet-stream" }
{ "pdf" "application/pdf" }
{ "factor" "text/plain" }
{ "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global

9
extra/http/server/cgi/cgi.factor
View File

@ -14,13 +14,12 @@ IN: http.server.cgi
"HTTP/" request get version>> append "SERVER_PROTOCOL" set
"Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" set
[ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi
request get path>> "SCRIPT_NAME" set
request get url>> path>> "SCRIPT_NAME" set
request get host>> "SERVER_NAME" set
request get port>> number>string "SERVER_PORT" set
request get url>> host>> "SERVER_NAME" set
request get url>> port>> number>string "SERVER_PORT" set
"" "PATH_INFO" set
"" "REMOTE_HOST" set
"" "REMOTE_ADDR" set

4
extra/http/server/db/db-tests.factor
View File

@ -1,4 +0,0 @@
IN: http.server.db.tests
USING: tools.test http.server.db ;
\ <db-persistence> must-infer

63
extra/http/server/server-tests.factor → extra/http/server/dispatchers/dispatchers-tests.factor Executable file → Normal file
View File

@ -1,28 +1,10 @@
USING: http.server tools.test kernel namespaces accessors
io http math sequences assocs arrays classes words ;
IN: http.server.tests
USING: http.server http.server.dispatchers http.server.responses
tools.test kernel namespaces accessors io http math sequences
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
[
<request>
http >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
request set
[ ] link-hook set
[ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
[ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
[ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
] with-scope
\ http-error. must-infer
TUPLE: mock-responder path ;
@ -31,10 +13,10 @@ C: <mock-responder> mock-responder
M: mock-responder call-responder*
nip
path>> on
[ ] <text-content> ;
[ ] "text/plain" <content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
V{ } clone responder-nesting set
over off
split-path
main-responder get call-responder
@ -84,10 +66,10 @@ C: <path-check-responder> path-check-responder
M: path-check-responder call-responder*
drop
>array <text-content> ;
>array "text/plain" <content> ;
[ { "c" } ] [
H{ } clone base-paths set
V{ } clone responder-nesting set
{ "b" "c" }
<dispatcher>
@ -113,30 +95,3 @@ M: path-check-responder call-responder*
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "baz" "xxx" check-dispatch ] unit-test
] unit-test
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;
C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
<text-content> ;
[ ] [
<dispatcher>
<dispatcher>
<funny-dispatcher>
<base-path-check-responder> "c" add-responder
"b" add-responder
"a" add-responder
main-responder set
] unit-test
[ "/a/b/" ] [
"a/b/c" split-path main-responder get call-responder body>>
] unit-test

47
extra/http/server/dispatchers/dispatchers.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences assocs accessors
http http.server http.server.responses ;
IN: http.server.dispatchers
TUPLE: dispatcher default responders ;
: new-dispatcher ( class -- dispatcher )
new
<404> <trivial-responder> >>default
H{ } clone >>responders ; inline
: <dispatcher> ( -- dispatcher )
dispatcher new-dispatcher ;
: find-responder ( path dispatcher -- path responder )
over empty? [
"" over responders>> at*
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
[ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
vhost-dispatcher new-dispatcher ;
: find-vhost ( dispatcher -- responder )
request get url>> host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder drop ]
[ drop "" add-responder drop ]
[ 2drop ] 3tri ;

9
extra/http/server/filters/filters.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.server accessors ;
IN: http.server.filters
TUPLE: filter-responder responder ;
M: filter-responder call-responder*
responder>> call-responder ;

48
extra/http/server/redirection/redirection-tests.factor Normal file
View File

@ -0,0 +1,48 @@
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test ;
\ relative-to-request must-infer
[
<request>
<url>
"http" >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
>>url
request set
[ "http://www.apple.com:80/xxx/bar" ] [
<url> relative-to-request url>string
] unit-test
[ "http://www.apple.com:80/xxx/baz" ] [
<url> "baz" >>path relative-to-request url>string
] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
<url> { { "c" "d" } } >>query relative-to-request url>string
] unit-test
[ "http://www.apple.com:80/flip" ] [
<url> "/flip" >>path relative-to-request url>string
] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
] unit-test
[ "http://www.jedit.org:80/" ] [
"http://www.jedit.org" >url relative-to-request url>string
] unit-test
[ "http://www.jedit.org:80/?a=b" ] [
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
] unit-test
] with-scope

24
extra/http/server/redirection/redirection.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces
logging urls http http.server http.server.responses ;
IN: http.server.redirection
: relative-to-request ( url -- url' )
request get url>>
clone
f >>query
swap derive-url ensure-port ;
: <custom-redirect> ( url code message -- response )
<trivial-response>
swap dup url? [ relative-to-request ] when
"location" set-header ;
\ <custom-redirect> DEBUG add-input-logging
: <permanent-redirect> ( url -- response )
301 "Moved Permanently" <custom-redirect> ;
: <temporary-redirect> ( url -- response )
307 "Temporary Redirect" <custom-redirect> ;

37
extra/http/server/responses/responses.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements math.parser http accessors kernel
io io.streams.string ;
IN: http.server.responses
: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap >>content-type
swap >>body ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
: <trivial-response> ( code message -- response )
2dup [ trivial-response-body ] with-string-writer
"text/html" <content>
swap >>message
swap >>code ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
: <404> ( -- response )
404 "Not found" <trivial-response> ;

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

@ -1,276 +1,73 @@
! 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 sequences prettyprint io.server logging calendar http
html.streams html.elements accessors math.parser
combinators.lib tools.vocabs debugger continuations random
combinators destructors io.encodings.8-bit fry classes words
math rss json.writer ;
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader http http.server.responses logging calendar
destructors html.elements html.streams io.server
io.encodings.8-bit io.timeouts io assocs debugger continuations
fry tools.vocabs math ;
IN: http.server
SYMBOL: responder-nesting
SYMBOL: main-responder
SYMBOL: development-mode
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> ] }
} case ;
: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap >>content-type
swap >>body ;
: <text-content> ( body -- response )
"text/plain" <content> ;
: <html-content> ( body -- response )
"text/html" <content> ;
: <xml-content> ( body -- response )
"text/xml" <content> ;
: <feed-content> ( feed -- response )
'[ , feed>xml ] "text/xml" <content> ;
: <json-content> ( obj -- response )
'[ , >json ] "application/json" <content> ;
TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder
M: trivial-responder call-responder* nip response>> call ;
M: trivial-responder call-responder* nip response>> clone ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
: <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ] <html-content>
swap >>message
swap >>code ;
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
: <404> ( -- response )
404 "Not Found" <trivial-response> ;
SYMBOL: 404-responder
[ <404> ] <trivial-responder> 404-responder set-global
SYMBOL: base-paths
main-responder global [ <404> <trivial-responder> get-global or ] change-at
: invert-slice ( slice -- slice' )
dup slice? [
[ seq>> ] [ from>> ] bi head-slice
] [
drop { }
] if ;
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
: add-base-path ( path dispatcher -- )
[ invert-slice ] [ class word-name ] bi*
base-paths get set-at ;
: add-responder-nesting ( path responder -- )
[ invert-slice ] dip 2array responder-nesting get push ;
: call-responder ( path responder -- response )
[ add-base-path ] [ call-responder* ] 2bi ;
SYMBOL: link-hook
: add-link-hook ( quot -- )
link-hook [ compose ] change ; inline
: modify-query ( query -- query )
link-hook get call ;
: base-path ( string -- path )
dup base-paths get at
[ ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: link>string ( url query -- url' )
[ resolve-base-path ] [ modify-query ] bi* (link>string) ;
: write-link ( url query -- )
link>string write ;
SYMBOL: form-hook
: add-form-hook ( quot -- )
form-hook [ compose ] change ;
: hidden-form-field ( -- )
form-hook get call ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
swap url-encode >>path
[ modify-query ] change-query
request-url ;
: replace-last-component ( path with -- path' )
[ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
[ modify-query ] change-query
request-url ;
: derive-url ( to query -- url )
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
<trivial-response> -rot derive-url "location" set-header ;
\ <redirect> DEBUG add-input-logging
: <permanent-redirect> ( to query -- response )
301 "Moved Permanently" <redirect> ;
: <temporary-redirect> ( to query -- response )
307 "Temporary Redirect" <redirect> ;
: <standard-redirect> ( to query -- response )
request get method>> "POST" =
[ <permanent-redirect> ] [ <temporary-redirect> ] if ;
TUPLE: dispatcher default responders ;
: new-dispatcher ( class -- dispatcher )
new
404-responder get >>default
H{ } clone >>responders ; inline
: <dispatcher> ( -- dispatcher )
dispatcher new-dispatcher ;
: find-responder ( path dispatcher -- path responder )
over empty? [
"" over responders>> at*
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
[ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder drop ]
[ drop "" add-responder drop ]
[ 2drop ] 3tri ;
TUPLE: filter-responder responder ;
M: filter-responder call-responder*
responder>> call-responder ;
SYMBOL: main-responder
main-responder global
[ drop 404-responder get-global ] cache
drop
SYMBOL: development-mode
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
"Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
[ print-error nl :c ] with-html-stream
] simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap '[ , http-error. ] >>body ;
development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
[ drop ] [
'[
, write-response-body
] [
http-error.
] recover
] if ;
[ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
: split-path ( string -- path )
"/" split harvest ;
: init-request ( -- )
H{ } clone base-paths set
[ ] link-hook set
[ ] form-hook set ;
: init-request ( request -- )
request set
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
: do-request ( request -- response )
[
init-request
[ request set ]
[ init-request ]
[ log-request ]
[ path>> split-path main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover ;
[ dispatch-request ] tri
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
development-mode get-global
@ -287,8 +84,7 @@ SYMBOL: exit-continuation
: httpd ( port -- )
dup integer? [ internet-server ] when
"http.server" latin1
[ handle-client ] with-server ;
"http.server" latin1 [ handle-client ] with-server ;
: httpd-main ( -- )
8888 httpd ;

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

@ -1,10 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors
io.encodings.binary fry xml.entities destructors ;
math.parser namespaces parser sequences strings
assocs hashtables debugger mime-types sorting logging
calendar.format accessors
io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml
http
http.server
http.server.responses
http.server.redirection ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
@ -17,12 +22,6 @@ TUPLE: file-responder root hook special allow-listings ;
2drop t
] if ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <file-responder> ( root hook -- responder )
file-responder new
swap >>hook
@ -71,7 +70,7 @@ TUPLE: file-responder root hook special allow-listings ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
'[ , directory. ] <html-content>
'[ , directory. ] "text/html" <content>
] [
drop <403>
] if ;
@ -85,7 +84,7 @@ TUPLE: file-responder root hook special allow-listings ;
find-index [ serve-file ] [ list-directory ] ?if
] [
drop
request get path>> "/" append f <standard-redirect>
request get url>> clone [ "/" append ] change-path <permanent-redirect>
] if ;
: serve-object ( filename -- response )
@ -101,6 +100,6 @@ M: file-responder call-responder* ( path responder -- response )
! file responder integration
: enable-fhtml ( responder -- responder )
[ <fhtml> <html-content> ]
[ <fhtml> "text/html" <content> ]
"application/x-factor-server-page"
pick special>> set-at ;

20
extra/io/pools/pools.factor
View File

@ -1,13 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
destructors io.sockets ;
destructors io.sockets alien alien.syntax ;
IN: io.pools
TUPLE: pool connections disposed ;
TUPLE: pool connections disposed expired ;
: check-pool ( pool -- )
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
connections>> [ delete-all ] [ dispose-each ] bi
] [ drop ] if ;
: <pool> ( class -- pool )
new V{ } clone >>connections ; inline
new V{ } clone
>>connections
dup check-pool ; inline
M: pool dispose* connections>> dispose-each ;
@ -17,15 +26,14 @@ M: pool dispose* connections>> dispose-each ;
TUPLE: return-connection conn pool ;
: return-connection ( conn pool -- )
dup check-disposed connections>> push ;
dup check-pool connections>> push ;
GENERIC: make-connection ( pool -- conn )
: new-connection ( pool -- )
[ make-connection ] keep return-connection ;
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
dup check-disposed
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;

2
extra/lcs/diff2html/diff2html.factor
View File

@ -38,7 +38,7 @@ M: delete diff-line
</tr> ;
: htmlize-diff ( diff -- )
<table "comparison" =class table>
<table "100%" =width "comparison" =class table>
<tr> <th> "Old" write </th> <th> "New" write </th> </tr>
[ diff-line ] each
</table> ;

0
extra/http/mime/authors.txt → extra/mime-types/authors.txt
View File

6
extra/mime-types/mime-types-tests.factor Normal file
View File

@ -0,0 +1,6 @@
IN: mime-types.tests
USING: mime-types tools.test ;
[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
[ "text/plain" ] [ "foo.factor" mime-type ] unit-test

23
extra/mime-types/mime-types.factor Executable file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii assocs sequences splitting
kernel namespaces fry memoize ;
IN: mime-types
MEMO: mime-db ( -- seq )
"resource:extra/mime-types/mime.types" ascii file-lines
[ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
: nonstandard-mime-types ( -- assoc )
H{
{ "factor" "text/plain" }
{ "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" }
} ;
MEMO: mime-types ( -- assoc )
[ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc
nonstandard-mime-types assoc-union ;
: mime-type ( filename -- mime-type )
file-extension mime-types at "application/octet-stream" or ;

988
extra/mime-types/mime.types Normal file
View File

@ -0,0 +1,988 @@
# This is a comment. I love comments.
# This file controls what Internet media types are sent to the client for
# given file extension(s). Sending the correct media type to the client
# is important so they know how to handle the content of the file.
# Extra types can either be added here or by using an AddType directive
# in your config files. For more information about Internet media types,
# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
# registry is at <http://www.iana.org/assignments/media-types/>.
# MIME type Extensions
application/activemessage
application/andrew-inset ez
application/applefile
application/atom+xml atom
application/atomcat+xml atomcat
application/atomicmail
application/atomsvc+xml atomsvc
application/auth-policy+xml
application/batch-smtp
application/beep+xml
application/cals-1840
application/ccxml+xml ccxml
application/cellml+xml
application/cnrp+xml
application/commonground
application/conference-info+xml
application/cpl+xml
application/csta+xml
application/cstadata+xml
application/cybercash
application/davmount+xml davmount
application/dca-rft
application/dec-dx
application/dialog-info+xml
application/dicom
application/dns
application/dvcs
application/ecmascript ecma
application/edi-consent
application/edi-x12
application/edifact
application/epp+xml
application/eshop
application/fastinfoset
application/fastsoap
application/fits
application/font-tdpfr pfr
application/h224
application/http
application/hyperstudio stk
application/iges
application/im-iscomposing+xml
application/index
application/index.cmd
application/index.obj
application/index.response
application/index.vnd
application/iotp
application/ipp
application/isup
application/javascript js
application/json json
application/kpml-request+xml
application/kpml-response+xml
application/mac-binhex40 hqx
application/mac-compactpro cpt
application/macwriteii
application/marc mrc
application/mathematica ma nb mb
application/mathml+xml mathml
application/mbms-associated-procedure-description+xml
application/mbms-deregister+xml
application/mbms-envelope+xml
application/mbms-msk+xml
application/mbms-msk-response+xml
application/mbms-protection-description+xml
application/mbms-reception-report+xml
application/mbms-register+xml
application/mbms-register-response+xml
application/mbms-user-service-description+xml
application/mbox mbox
application/mediaservercontrol+xml mscml
application/mikey
application/mp4 mp4s
application/mpeg4-generic
application/mpeg4-iod
application/mpeg4-iod-xmt
application/msword doc dot
application/mxf mxf
application/nasdata
application/news-message-id
application/news-transmission
application/nss
application/ocsp-request
application/ocsp-response
application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
application/oda oda
application/oebps-package+xml
application/ogg ogg
application/parityfec
application/pdf pdf
application/pgp-encrypted pgp
application/pgp-keys
application/pgp-signature asc sig
application/pics-rules prf
application/pidf+xml
application/pkcs10 p10
application/pkcs7-mime p7m p7c
application/pkcs7-signature p7s
application/pkix-cert cer
application/pkix-crl crl
application/pkix-pkipath pkipath
application/pkixcmp pki
application/pls+xml pls
application/poc-settings+xml
application/postscript ai eps ps
application/prs.alvestrand.titrax-sheet
application/prs.cww cww
application/prs.nprend
application/prs.plucker
application/qsig
application/rdf+xml rdf
application/reginfo+xml rif
application/relax-ng-compact-syntax rnc
application/remote-printing
application/resource-lists+xml rl
application/riscos
application/rlmi+xml
application/rls-services+xml rs
application/rsd+xml rsd
application/rss+xml rss
application/rtf rtf
application/rtx
application/samlassertion+xml
application/samlmetadata+xml
application/sbml+xml sbml
application/sdp sdp
application/set-payment
application/set-payment-initiation setpay
application/set-registration
application/set-registration-initiation setreg
application/sgml
application/sgml-open-catalog
application/shf+xml shf
application/sieve
application/simple-filter+xml
application/simple-message-summary
application/simplesymbolcontainer
application/slate
application/smil
application/smil+xml smi smil
application/soap+fastinfoset
application/soap+xml
application/spirits-event+xml
application/srgs gram
application/srgs+xml grxml
application/ssml+xml ssml
application/timestamp-query
application/timestamp-reply
application/tve-trigger
application/vemmi
application/vividence.scriptfile
application/vnd.3gpp.bsf+xml
application/vnd.3gpp.pic-bw-large plb
application/vnd.3gpp.pic-bw-small psb
application/vnd.3gpp.pic-bw-var pvb
application/vnd.3gpp.sms
application/vnd.3gpp2.bcmcsinfo+xml
application/vnd.3gpp2.sms
application/vnd.3m.post-it-notes pwn
application/vnd.accpac.simply.aso aso
application/vnd.accpac.simply.imp imp
application/vnd.acucobol acu
application/vnd.acucorp atc acutc
application/vnd.adobe.xdp+xml xdp
application/vnd.adobe.xfdf xfdf
application/vnd.aether.imp
application/vnd.amiga.ami ami
application/vnd.anser-web-certificate-issue-initiation cii
application/vnd.anser-web-funds-transfer-initiation fti
application/vnd.antix.game-component atx
application/vnd.apple.installer+xml mpkg
application/vnd.audiograph aep
application/vnd.autopackage
application/vnd.avistar+xml
application/vnd.blueice.multipass mpm
application/vnd.bmi bmi
application/vnd.businessobjects rep
application/vnd.cab-jscript
application/vnd.canon-cpdl
application/vnd.canon-lips
application/vnd.cendio.thinlinc.clientconf
application/vnd.chemdraw+xml cdxml
application/vnd.chipnuts.karaoke-mmd mmd
application/vnd.cinderella cdy
application/vnd.cirpack.isdn-ext
application/vnd.claymore cla
application/vnd.clonk.c4group c4g c4d c4f c4p c4u
application/vnd.commerce-battelle
application/vnd.commonspace csp cst
application/vnd.contact.cmsg cdbcmsg
application/vnd.cosmocaller cmc
application/vnd.crick.clicker clkx
application/vnd.crick.clicker.keyboard clkk
application/vnd.crick.clicker.palette clkp
application/vnd.crick.clicker.template clkt
application/vnd.crick.clicker.wordbank clkw
application/vnd.criticaltools.wbs+xml wbs
application/vnd.ctc-posml pml
application/vnd.cups-pdf
application/vnd.cups-postscript
application/vnd.cups-ppd ppd
application/vnd.cups-raster
application/vnd.cups-raw
application/vnd.curl curl
application/vnd.cybank
application/vnd.data-vision.rdz rdz
application/vnd.denovo.fcselayout-link fe_launch
application/vnd.dna dna
application/vnd.dolby.mlp mlp
application/vnd.dpgraph dpg
application/vnd.dreamfactory dfac
application/vnd.dvb.esgcontainer
application/vnd.dvb.ipdcesgaccess
application/vnd.dxr
application/vnd.ecdis-update
application/vnd.ecowin.chart mag
application/vnd.ecowin.filerequest
application/vnd.ecowin.fileupdate
application/vnd.ecowin.series
application/vnd.ecowin.seriesrequest
application/vnd.ecowin.seriesupdate
application/vnd.enliven nml
application/vnd.epson.esf esf
application/vnd.epson.msf msf
application/vnd.epson.quickanime qam
application/vnd.epson.salt slt
application/vnd.epson.ssf ssf
application/vnd.ericsson.quickcall
application/vnd.eszigno3+xml es3 et3
application/vnd.eudora.data
application/vnd.ezpix-album ez2
application/vnd.ezpix-package ez3
application/vnd.fdf fdf
application/vnd.ffsns
application/vnd.fints
application/vnd.flographit gph
application/vnd.fluxtime.clip ftc
application/vnd.framemaker fm frame maker
application/vnd.frogans.fnc fnc
application/vnd.frogans.ltf ltf
application/vnd.fsc.weblaunch fsc
application/vnd.fujitsu.oasys oas
application/vnd.fujitsu.oasys2 oa2
application/vnd.fujitsu.oasys3 oa3
application/vnd.fujitsu.oasysgp fg5
application/vnd.fujitsu.oasysprs bh2
application/vnd.fujixerox.art-ex
application/vnd.fujixerox.art4
application/vnd.fujixerox.hbpl
application/vnd.fujixerox.ddd ddd
application/vnd.fujixerox.docuworks xdw
application/vnd.fujixerox.docuworks.binder xbd
application/vnd.fut-misnet
application/vnd.fuzzysheet fzs
application/vnd.genomatix.tuxedo txd
application/vnd.google-earth.kml+xml kml
application/vnd.google-earth.kmz kmz
application/vnd.grafeq gqf gqs
application/vnd.gridmp
application/vnd.groove-account gac
application/vnd.groove-help ghf
application/vnd.groove-identity-message gim
application/vnd.groove-injector grv
application/vnd.groove-tool-message gtm
application/vnd.groove-tool-template tpl
application/vnd.groove-vcard vcg
application/vnd.handheld-entertainment+xml zmm
application/vnd.hbci hbci
application/vnd.hcl-bireports
application/vnd.hhe.lesson-player les
application/vnd.hp-hpgl hpgl
application/vnd.hp-hpid hpid
application/vnd.hp-hps hps
application/vnd.hp-jlyt jlt
application/vnd.hp-pcl pcl
application/vnd.hp-pclxl pclxl
application/vnd.httphone
application/vnd.hzn-3d-crossword x3d
application/vnd.ibm.afplinedata
application/vnd.ibm.electronic-media
application/vnd.ibm.minipay mpy
application/vnd.ibm.modcap afp listafp list3820
application/vnd.ibm.rights-management irm
application/vnd.ibm.secure-container sc
application/vnd.igloader igl
application/vnd.immervision-ivp ivp
application/vnd.immervision-ivu ivu
application/vnd.informedcontrol.rms+xml
application/vnd.intercon.formnet xpw xpx
application/vnd.intertrust.digibox
application/vnd.intertrust.nncp
application/vnd.intu.qbo qbo
application/vnd.intu.qfx qfx
application/vnd.ipunplugged.rcprofile rcprofile
application/vnd.irepository.package+xml irp
application/vnd.is-xpr xpr
application/vnd.jam jam
application/vnd.japannet-directory-service
application/vnd.japannet-jpnstore-wakeup
application/vnd.japannet-payment-wakeup
application/vnd.japannet-registration
application/vnd.japannet-registration-wakeup
application/vnd.japannet-setstore-wakeup
application/vnd.japannet-verification
application/vnd.japannet-verification-wakeup
application/vnd.jcp.javame.midlet-rms rms
application/vnd.jisp jisp
application/vnd.kahootz ktz ktr
application/vnd.kde.karbon karbon
application/vnd.kde.kchart chrt
application/vnd.kde.kformula kfo
application/vnd.kde.kivio flw
application/vnd.kde.kontour kon
application/vnd.kde.kpresenter kpr kpt
application/vnd.kde.kspread ksp
application/vnd.kde.kword kwd kwt
application/vnd.kenameaapp htke
application/vnd.kidspiration kia
application/vnd.kinar kne knp
application/vnd.koan skp skd skt skm
application/vnd.liberty-request+xml
application/vnd.llamagraphics.life-balance.desktop lbd
application/vnd.llamagraphics.life-balance.exchange+xml lbe
application/vnd.lotus-1-2-3 123
application/vnd.lotus-approach apr
application/vnd.lotus-freelance pre
application/vnd.lotus-notes nsf
application/vnd.lotus-organizer org
application/vnd.lotus-screencam scm
application/vnd.lotus-wordpro lwp
application/vnd.macports.portpkg portpkg
application/vnd.marlin.drm.actiontoken+xml
application/vnd.marlin.drm.conftoken+xml
application/vnd.marlin.drm.mdcf
application/vnd.mcd mcd
application/vnd.medcalcdata mc1
application/vnd.mediastation.cdkey cdkey
application/vnd.meridian-slingshot
application/vnd.mfer mwf
application/vnd.mfmp mfm
application/vnd.micrografx.flo flo
application/vnd.micrografx.igx igx
application/vnd.mif mif
application/vnd.minisoft-hp3000-save
application/vnd.mitsubishi.misty-guard.trustweb
application/vnd.mobius.daf daf
application/vnd.mobius.dis dis
application/vnd.mobius.mbk mbk
application/vnd.mobius.mqy mqy
application/vnd.mobius.msl msl
application/vnd.mobius.plc plc
application/vnd.mobius.txf txf
application/vnd.mophun.application mpn
application/vnd.mophun.certificate mpc
application/vnd.motorola.flexsuite
application/vnd.motorola.flexsuite.adsi
application/vnd.motorola.flexsuite.fis
application/vnd.motorola.flexsuite.gotap
application/vnd.motorola.flexsuite.kmr
application/vnd.motorola.flexsuite.ttc
application/vnd.motorola.flexsuite.wem
application/vnd.mozilla.xul+xml xul
application/vnd.ms-artgalry cil
application/vnd.ms-asf asf
application/vnd.ms-cab-compressed cab
application/vnd.ms-excel xls xlm xla xlc xlt xlw
application/vnd.ms-fontobject eot
application/vnd.ms-htmlhelp chm
application/vnd.ms-ims ims
application/vnd.ms-lrm lrm
application/vnd.ms-playready.initiator+xml
application/vnd.ms-powerpoint ppt pps pot
application/vnd.ms-project mpp mpt
application/vnd.ms-tnef
application/vnd.ms-wmdrm.lic-chlg-req
application/vnd.ms-wmdrm.lic-resp
application/vnd.ms-wmdrm.meter-chlg-req
application/vnd.ms-wmdrm.meter-resp
application/vnd.ms-works wps wks wcm wdb
application/vnd.ms-wpl wpl
application/vnd.ms-xpsdocument xps
application/vnd.mseq mseq
application/vnd.msign
application/vnd.music-niff
application/vnd.musician mus
application/vnd.ncd.control
application/vnd.nervana
application/vnd.netfpx
application/vnd.neurolanguage.nlu nlu
application/vnd.noblenet-directory nnd
application/vnd.noblenet-sealer nns
application/vnd.noblenet-web nnw
application/vnd.nokia.catalogs
application/vnd.nokia.conml+wbxml
application/vnd.nokia.conml+xml
application/vnd.nokia.isds-radio-presets
application/vnd.nokia.iptv.config+xml
application/vnd.nokia.landmark+wbxml
application/vnd.nokia.landmark+xml
application/vnd.nokia.landmarkcollection+xml
application/vnd.nokia.n-gage.ac+xml
application/vnd.nokia.n-gage.data ngdat
application/vnd.nokia.n-gage.symbian.install n-gage
application/vnd.nokia.ncd
application/vnd.nokia.pcd+wbxml
application/vnd.nokia.pcd+xml
application/vnd.nokia.radio-preset rpst
application/vnd.nokia.radio-presets rpss
application/vnd.novadigm.edm edm
application/vnd.novadigm.edx edx
application/vnd.novadigm.ext ext
application/vnd.oasis.opendocument.chart odc
application/vnd.oasis.opendocument.chart-template otc
application/vnd.oasis.opendocument.formula odf
application/vnd.oasis.opendocument.formula-template otf
application/vnd.oasis.opendocument.graphics odg
application/vnd.oasis.opendocument.graphics-template otg
application/vnd.oasis.opendocument.image odi
application/vnd.oasis.opendocument.image-template oti
application/vnd.oasis.opendocument.presentation odp
application/vnd.oasis.opendocument.presentation-template otp
application/vnd.oasis.opendocument.spreadsheet ods
application/vnd.oasis.opendocument.spreadsheet-template ots
application/vnd.oasis.opendocument.text odt
application/vnd.oasis.opendocument.text-master otm
application/vnd.oasis.opendocument.text-template ott
application/vnd.oasis.opendocument.text-web oth
application/vnd.obn
application/vnd.olpc-sugar xo
application/vnd.oma-scws-config
application/vnd.oma-scws-http-request
application/vnd.oma-scws-http-response
application/vnd.oma.bcast.associated-procedure-parameter+xml
application/vnd.oma.bcast.drm-trigger+xml
application/vnd.oma.bcast.imd+xml
application/vnd.oma.bcast.notification+xml
application/vnd.oma.bcast.sgboot
application/vnd.oma.bcast.sgdd+xml
application/vnd.oma.bcast.sgdu
application/vnd.oma.bcast.simple-symbol-container
application/vnd.oma.bcast.smartcard-trigger+xml
application/vnd.oma.bcast.sprov+xml
application/vnd.oma.dd2+xml dd2
application/vnd.oma.drm.risd+xml
application/vnd.oma.group-usage-list+xml
application/vnd.oma.poc.groups+xml
application/vnd.oma.xcap-directory+xml
application/vnd.omads-email+xml
application/vnd.omads-file+xml
application/vnd.omads-folder+xml
application/vnd.omaloc-supl-init
application/vnd.openofficeorg.extension oxt
application/vnd.osa.netdeploy
application/vnd.osgi.dp dp
application/vnd.otps.ct-kip+xml
application/vnd.palm prc pdb pqa oprc
application/vnd.paos.xml
application/vnd.pg.format str
application/vnd.pg.osasli ei6
application/vnd.piaccess.application-licence
application/vnd.picsel efif
application/vnd.poc.group-advertisement+xml
application/vnd.pocketlearn plf
application/vnd.powerbuilder6 pbd
application/vnd.powerbuilder6-s
application/vnd.powerbuilder7
application/vnd.powerbuilder7-s
application/vnd.powerbuilder75
application/vnd.powerbuilder75-s
application/vnd.preminet
application/vnd.previewsystems.box box
application/vnd.proteus.magazine mgz
application/vnd.publishare-delta-tree qps
application/vnd.pvi.ptid1 ptid
application/vnd.pwg-multiplexed
application/vnd.pwg-xhtml-print+xml
application/vnd.qualcomm.brew-app-res
application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
application/vnd.rapid
application/vnd.recordare.musicxml mxl
application/vnd.recordare.musicxml+xml
application/vnd.renlearn.rlprint
application/vnd.rn-realmedia rm
application/vnd.ruckus.download
application/vnd.s3sms
application/vnd.scribus
application/vnd.sealed.3df
application/vnd.sealed.csf
application/vnd.sealed.doc
application/vnd.sealed.eml
application/vnd.sealed.mht
application/vnd.sealed.net
application/vnd.sealed.ppt
application/vnd.sealed.tiff
application/vnd.sealed.xls
application/vnd.sealedmedia.softseal.html
application/vnd.sealedmedia.softseal.pdf
application/vnd.seemail see
application/vnd.sema sema
application/vnd.semd semd
application/vnd.semf semf
application/vnd.shana.informed.formdata ifm
application/vnd.shana.informed.formtemplate itp
application/vnd.shana.informed.interchange iif
application/vnd.shana.informed.package ipk
application/vnd.simtech-mindmapper twd twds
application/vnd.smaf mmf
application/vnd.solent.sdkm+xml sdkm sdkd
application/vnd.spotfire.dxp dxp
application/vnd.spotfire.sfs sfs
application/vnd.sss-cod
application/vnd.sss-dtf
application/vnd.sss-ntf
application/vnd.street-stream
application/vnd.sun.wadl+xml
application/vnd.sus-calendar sus susp
application/vnd.svd svd
application/vnd.swiftview-ics
application/vnd.syncml+xml xsm
application/vnd.syncml.dm+wbxml bdm
application/vnd.syncml.dm+xml xdm
application/vnd.syncml.ds.notification
application/vnd.tao.intent-module-archive tao
application/vnd.tmobile-livetv tmo
application/vnd.trid.tpt tpt
application/vnd.triscape.mxs mxs
application/vnd.trueapp tra
application/vnd.truedoc
application/vnd.ufdl ufd ufdl
application/vnd.uiq.theme utz
application/vnd.umajin umj
application/vnd.unity unityweb
application/vnd.uoml+xml uoml
application/vnd.uplanet.alert
application/vnd.uplanet.alert-wbxml
application/vnd.uplanet.bearer-choice
application/vnd.uplanet.bearer-choice-wbxml
application/vnd.uplanet.cacheop
application/vnd.uplanet.cacheop-wbxml
application/vnd.uplanet.channel
application/vnd.uplanet.channel-wbxml
application/vnd.uplanet.list
application/vnd.uplanet.list-wbxml
application/vnd.uplanet.listcmd
application/vnd.uplanet.listcmd-wbxml
application/vnd.uplanet.signal
application/vnd.vcx vcx
application/vnd.vd-study
application/vnd.vectorworks
application/vnd.vidsoft.vidconference
application/vnd.visio vsd vst vss vsw
application/vnd.visionary vis
application/vnd.vividence.scriptfile
application/vnd.vsf vsf
application/vnd.wap.sic
application/vnd.wap.slc
application/vnd.wap.wbxml wbxml
application/vnd.wap.wmlc wmlc
application/vnd.wap.wmlscriptc wmlsc
application/vnd.webturbo wtb
application/vnd.wfa.wsc
application/vnd.wordperfect wpd
application/vnd.wqd wqd
application/vnd.wrq-hp3000-labelled
application/vnd.wt.stf stf
application/vnd.wv.csp+wbxml
application/vnd.wv.csp+xml
application/vnd.wv.ssp+xml
application/vnd.xara xar
application/vnd.xfdl xfdl
application/vnd.xmpie.cpkg
application/vnd.xmpie.dpkg
application/vnd.xmpie.plan
application/vnd.xmpie.ppkg
application/vnd.xmpie.xlim
application/vnd.yamaha.hv-dic hvd
application/vnd.yamaha.hv-script hvs
application/vnd.yamaha.hv-voice hvp
application/vnd.yamaha.smaf-audio saf
application/vnd.yamaha.smaf-phrase spf
application/vnd.yellowriver-custom-menu cmp
application/vnd.zzazz.deck+xml zaz
application/voicexml+xml vxml
application/watcherinfo+xml
application/whoispp-query
application/whoispp-response
application/winhlp hlp
application/wita
application/wordperfect5.1
application/wsdl+xml wsdl
application/wspolicy+xml wspolicy
application/x-ace-compressed ace
application/x-bcpio bcpio
application/x-bittorrent torrent
application/x-bzip bz
application/x-bzip2 bz2 boz
application/x-cdlink vcd
application/x-chat chat
application/x-chess-pgn pgn
application/x-compress
application/x-cpio cpio
application/x-csh csh
application/x-director dcr dir dxr fgd
application/x-dvi dvi
application/x-futuresplash spl
application/x-gtar gtar
application/x-gzip
application/x-hdf hdf
application/x-java-jnlp-file jnlp
application/x-latex latex
application/x-ms-wmd wmd
application/x-ms-wmz wmz
application/x-msaccess mdb
application/x-msbinder obd
application/x-mscardfile crd
application/x-msclip clp
application/x-msdownload exe dll com bat msi
application/x-msmediaview mvb m13 m14
application/x-msmetafile wmf
application/x-msmoney mny
application/x-mspublisher pub
application/x-msschedule scd
application/x-msterminal trm
application/x-mswrite wri
application/x-netcdf nc cdf
application/x-pkcs12 p12 pfx
application/x-pkcs7-certificates p7b spc
application/x-pkcs7-certreqresp p7r
application/x-rar-compressed rar
application/x-sh sh
application/x-shar shar
application/x-shockwave-flash swf
application/x-stuffit sit
application/x-stuffitx sitx
application/x-sv4cpio sv4cpio
application/x-sv4crc sv4crc
application/x-tar tar
application/x-tcl tcl
application/x-tex tex
application/x-texinfo texinfo texi
application/x-ustar ustar
application/x-wais-source src
application/x-x509-ca-cert der crt
application/x400-bp
application/xcap-att+xml
application/xcap-caps+xml
application/xcap-el+xml
application/xcap-error+xml
application/xcap-ns+xml
application/xenc+xml xenc
application/xhtml+xml xhtml xht
application/xml xml xsl
application/xml-dtd dtd
application/xml-external-parsed-entity
application/xmpp+xml
application/xop+xml xop
application/xslt+xml xslt
application/xspf+xml xspf
application/xv+xml mxml xhvml xvml xvm
application/zip zip
audio/32kadpcm
audio/3gpp
audio/3gpp2
audio/ac3
audio/amr
audio/amr-wb
audio/amr-wb+
audio/asc
audio/basic au snd
audio/bv16
audio/bv32
audio/clearmode
audio/cn
audio/dat12
audio/dls
audio/dsr-es201108
audio/dsr-es202050
audio/dsr-es202211
audio/dsr-es202212
audio/dvi4
audio/eac3
audio/evrc
audio/evrc-qcp
audio/evrc0
audio/evrc1
audio/evrcb
audio/evrcb0
audio/evrcb1
audio/g722
audio/g7221
audio/g723
audio/g726-16
audio/g726-24
audio/g726-32
audio/g726-40
audio/g728
audio/g729
audio/g7291
audio/g729d
audio/g729e
audio/gsm
audio/gsm-efr
audio/ilbc
audio/l16
audio/l20
audio/l24
audio/l8
audio/lpc
audio/midi mid midi kar rmi
audio/mobile-xmf
audio/mp4 mp4a
audio/mp4a-latm m4a m4p
audio/mpa
audio/mpa-robust
audio/mpeg mpga mp2 mp2a mp3 m2a m3a
audio/mpeg4-generic
audio/parityfec
audio/pcma
audio/pcmu
audio/prs.sid
audio/qcelp
audio/red
audio/rtp-enc-aescm128
audio/rtp-midi
audio/rtx
audio/smv
audio/smv0
audio/smv-qcp
audio/sp-midi
audio/t140c
audio/t38
audio/telephone-event
audio/tone
audio/vdvi
audio/vmr-wb
audio/vnd.3gpp.iufp
audio/vnd.4sb
audio/vnd.audiokoz
audio/vnd.celp
audio/vnd.cisco.nse
audio/vnd.cmles.radio-events
audio/vnd.cns.anp1
audio/vnd.cns.inf1
audio/vnd.digital-winds eol
audio/vnd.dlna.adts
audio/vnd.dolby.mlp
audio/vnd.everad.plj
audio/vnd.hns.audio
audio/vnd.lucent.voice lvp
audio/vnd.nokia.mobile-xmf
audio/vnd.nortel.vbk
audio/vnd.nuera.ecelp4800 ecelp4800
audio/vnd.nuera.ecelp7470 ecelp7470
audio/vnd.nuera.ecelp9600 ecelp9600
audio/vnd.octel.sbc
audio/vnd.qcelp
audio/vnd.rhetorex.32kadpcm
audio/vnd.sealedmedia.softseal.mpeg
audio/vnd.vmx.cvsd
audio/wav wav
audio/x-aiff aif aiff aifc
audio/x-mpegurl m3u
audio/x-ms-wax wax
audio/x-ms-wma wma
audio/x-pn-realaudio ram ra
audio/x-pn-realaudio-plugin rmp
audio/x-wav wav
chemical/x-cdx cdx
chemical/x-cif cif
chemical/x-cmdf cmdf
chemical/x-cml cml
chemical/x-csml csml
chemical/x-pdb pdb
chemical/x-xyz xyz
image/bmp bmp
image/cgm cgm
image/fits
image/g3fax g3
image/gif gif
image/ief ief
image/jp2 jp2
image/jpeg jpeg jpg jpe
image/jpm
image/jpx
image/naplps
image/pict pict pic pct
image/png png
image/prs.btif btif
image/prs.pti
image/svg+xml svg svgz
image/t38
image/tiff tiff tif
image/tiff-fx
image/vnd.adobe.photoshop psd
image/vnd.cns.inf2
image/vnd.djvu djvu djv
image/vnd.dwg dwg
image/vnd.dxf dxf
image/vnd.fastbidsheet fbs
image/vnd.fpx fpx
image/vnd.fst fst
image/vnd.fujixerox.edmics-mmr mmr
image/vnd.fujixerox.edmics-rlc rlc
image/vnd.globalgraphics.pgb
image/vnd.microsoft.icon ico
image/vnd.mix
image/vnd.ms-modi mdi
image/vnd.net-fpx npx
image/vnd.sealed.png
image/vnd.sealedmedia.softseal.gif
image/vnd.sealedmedia.softseal.jpg
image/vnd.svf
image/vnd.wap.wbmp wbmp
image/vnd.xiff xif
image/x-cmu-raster ras
image/x-cmx cmx
image/x-icon
image/x-macpaint pntg pnt mac
image/x-pcx pcx
image/x-pict pic pct
image/x-portable-anymap pnm
image/x-portable-bitmap pbm
image/x-portable-graymap pgm
image/x-portable-pixmap ppm
image/x-quicktime qtif qti
image/x-rgb rgb
image/x-xbitmap xbm
image/x-xpixmap xpm
image/x-xwindowdump xwd
message/cpim
message/delivery-status
message/disposition-notification
message/external-body
message/http
message/news
message/partial
message/rfc822 eml mime
message/s-http
message/sip
message/sipfrag
message/tracking-status
model/iges igs iges
model/mesh msh mesh silo
model/vnd.dwf dwf
model/vnd.flatland.3dml
model/vnd.gdl gdl
model/vnd.gs.gdl
model/vnd.gtw gtw
model/vnd.moml+xml
model/vnd.mts mts
model/vnd.parasolid.transmit.binary
model/vnd.parasolid.transmit.text
model/vnd.vtu vtu
model/vrml wrl vrml
multipart/alternative
multipart/appledouble
multipart/byteranges
multipart/digest
multipart/encrypted
multipart/form-data
multipart/header-set
multipart/mixed
multipart/parallel
multipart/related
multipart/report
multipart/signed
multipart/voice-message
text/calendar ics ifb
text/css css
text/csv csv
text/directory
text/dns
text/enriched
text/html html htm
text/parityfec
text/plain txt text conf def list log in
text/prs.fallenstein.rst
text/prs.lines.tag dsc
text/red
text/rfc822-headers
text/richtext rtx
text/rtf
text/rtp-enc-aescm128
text/rtx
text/sgml sgml sgm
text/t140
text/tab-separated-values tsv
text/troff t tr roff man me ms
text/uri-list uri uris urls
text/vnd.abc
text/vnd.curl
text/vnd.dmclientscript
text/vnd.esmertec.theme-descriptor
text/vnd.fly fly
text/vnd.fmi.flexstor flx
text/vnd.in3d.3dml 3dml
text/vnd.in3d.spot spot
text/vnd.iptc.newsml
text/vnd.iptc.nitf
text/vnd.latex-z
text/vnd.motorola.reflex
text/vnd.ms-mediapackage
text/vnd.net2phone.commcenter.command
text/vnd.sun.j2me.app-descriptor jad
text/vnd.trolltech.linguist
text/vnd.wap.si
text/vnd.wap.sl
text/vnd.wap.wml wml
text/vnd.wap.wmlscript wmls
text/x-asm s asm
text/x-c c cc cxx cpp h hh dic
text/x-fortran f for f77 f90
text/x-pascal p pas
text/x-java-source java
text/x-setext etx
text/x-uuencode uu
text/x-vcalendar vcs
text/x-vcard vcf
text/xml
text/xml-external-parsed-entity
video/3gpp 3gp
video/3gpp-tt
video/3gpp2 3g2
video/bmpeg
video/bt656
video/celb
video/dv
video/h261 h261
video/h263 h263
video/h263-1998
video/h263-2000
video/h264 h264
video/jpeg jpgv
video/jpm jpm jpgm
video/mj2 mj2 mjp2
video/mp1s
video/mp2p
video/mp2t
video/mp4 mp4 mp4v mpg4 m4v
video/mp4v-es
video/mpeg mpeg mpg mpe m1v m2v
video/mpeg4-generic
video/mpv
video/nv
video/parityfec
video/pointer
video/quicktime qt mov
video/raw
video/rtp-enc-aescm128
video/rtx
video/smpte292m
video/vc1
video/vnd.dlna.mpeg-tts
video/vnd.fvt fvt
video/vnd.hns.video
video/vnd.motorola.video
video/vnd.motorola.videop
video/vnd.mpegurl mxu m4u
video/vnd.nokia.interleaved-multimedia
video/vnd.nokia.videovoip
video/vnd.objectvideo
video/vnd.sealed.mpeg1
video/vnd.sealed.mpeg4
video/vnd.sealed.swf
video/vnd.sealedmedia.softseal.mov
video/vnd.vivo viv
video/x-dv dv dif
video/x-fli fli
video/x-ms-asf asf asx
video/x-ms-wm wm
video/x-ms-wmv wmv
video/x-ms-wmx wmx
video/x-ms-wvx wvx
video/x-msvideo avi
video/x-sgi-movie movie
x-conference/x-cooltalk ice

8
extra/namespaces/lib/lib.factor
View File

@ -2,7 +2,7 @@
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
assocs.lib math.parser math sequences.lib locals ;
assocs.lib math.parser math sequences.lib locals mirrors ;
IN: namespaces.lib
@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
] with-scope
]
] ;
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline
: with-object ( object quot -- )
[ <mirror> ] dip bind ; inline

19
extra/rss/rss.factor
View File

@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
http.client namespaces xml.generator hashtables
calendar.format accessors continuations ;
calendar.format accessors continuations urls ;
IN: rss
: any-tag-named ( tag names -- tag-inside )
@ -103,18 +103,15 @@ C: <entry> entry
: entry, ( entry -- )
"entry" [
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
dup title>> "title" { { "type" "html" } } simple-tag*,
"link" over link>> dup url? [ url>string ] when "href" associate contained*,
dup pub-date>> timestamp>rfc3339 "published" simple-tag,
description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
: feed>xml ( feed -- xml )
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
dup feed-title "title" simple-tag,
"link" over feed-link "href" associate contained*,
feed-entries [ entry, ] each
dup title>> "title" simple-tag,
"link" over link>> dup url? [ url>string ] when "href" associate contained*,
entries>> [ entry, ] each
] make-xml* ;
: write-feed ( feed -- )
feed>xml write-xml ;

12
extra/tangle/tangle.factor
View File

@ -1,6 +1,10 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
USING: accessors assocs db db.sqlite db.postgresql
http http.server http.server.dispatchers http.server.responses
http.server.static furnace.actions furnace.json
io io.files json.writer kernel math.parser namespaces
semantic-db sequences strings tangle.path ;
IN: tangle
GENERIC: render* ( content templater -- output )
@ -20,7 +24,7 @@ C: <tangle> tangle
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
: node-response ( id -- response )
load-node [ node-content <text-content> ] [ <404> ] if* ;
load-node [ node-content "text/plain" <content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
@ -36,7 +40,7 @@ C: <tangle> tangle
: submit-node ( params -- response )
[
"node_content" swap at* [
create-node id>> number>string <text-content>
create-node id>> number>string "text/plain" <content>
] [
drop <400>
] if
@ -52,7 +56,7 @@ TUPLE: path-responder ;
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
drop path>file [ node-content <text-content> ] [ <404> ] if* ;
drop path>file [ node-content "text/plain" <content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;

116
extra/urls/urls-tests.factor
View File

@ -77,16 +77,54 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ;
}
"a/relative/path"
}
{
TUPLE{ url
path: "bar"
query: H{ { "a" "b" } }
}
"bar?a=b"
}
{
TUPLE{ url
protocol: "ftp"
host: "ftp.kernel.org"
username: "slava"
path: "/"
}
"ftp://slava@ftp.kernel.org/"
}
{
TUPLE{ url
protocol: "ftp"
host: "ftp.kernel.org"
username: "slava"
password: "secret"
path: "/"
}
"ftp://slava:secret@ftp.kernel.org/"
}
} ;
urls [
[ 1array ] [ [ string>url ] curry ] bi* unit-test
[ 1array ] [ [ >url ] curry ] bi* unit-test
] assoc-each
urls [
swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
] assoc-each
[ "b" ] [ "a" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
[ "/b" ] [ "a" "/b" url-append-path ] unit-test
[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
[
TUPLE{ url
protocol: "http"
@ -95,10 +133,6 @@ urls [
path: "/a/path"
}
] [
TUPLE{ url
path: "/a/path"
}
TUPLE{ url
protocol: "http"
host: "www.apple.com"
@ -106,29 +140,7 @@ urls [
path: "/foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
}
@ -145,12 +157,32 @@ urls [
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
@ -158,5 +190,35 @@ urls [
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/baz"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/bar"
}
TUPLE{ url
path: "baz"
}
derive-url
] unit-test
[ "a" ] [
<url> "a" "b" set-query-param "b" query-param
] unit-test

143
extra/urls/urls.factor
View File

@ -1,7 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel unicode.categories combinators sequences splitting
fry namespaces assocs arrays strings mirrors
io.encodings.string io.encodings.utf8
math math.parser accessors namespaces.lib ;
fry namespaces assocs arrays strings io.sockets
io.sockets.secure io.encodings.string io.encodings.utf8
math math.parser accessors mirrors parser
prettyprint.backend hashtables ;
IN: urls
: url-quotable? ( ch -- ? )
@ -87,57 +90,113 @@ IN: urls
] assoc-each
] { } make "&" join ;
TUPLE: url protocol host port path query anchor ;
TUPLE: url protocol username password host port path query anchor ;
: parse-host-part ( protocol rest -- string' )
[ "protocol" set ] [
: <url> ( -- url ) url new ;
: query-param ( url key -- value )
swap query>> at ;
: set-query-param ( url value key -- url )
'[ , , _ ?set-at ] change-query ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when
] bi* ;
: parse-host-part ( url protocol rest -- url string' )
[ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless
"@" split1 [
[
":" split1 [ >>username ] [ >>password ] bi*
] dip
] when*
"/" split1 [
":" split1
[ url-decode "host" set ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when "port" set
] bi*
parse-host [ >>host ] [ >>port ] bi*
] [ "/" prepend ] bi*
] bi* ;
: string>url ( string -- url )
[
":" split1 [ parse-host-part ] when*
"#" split1 [
"?" split1 [ query>assoc "query" set ] when*
url-decode "path" set
] [
url-decode "anchor" set
] bi*
] url make-object ;
GENERIC: >url ( obj -- url )
: unparse-host-part ( protocol -- )
M: url >url ;
M: string >url
<url> swap
":" split1 [ parse-host-part ] when*
"#" split1 [
"?" split1
[ url-decode >>path ]
[ [ query>assoc >>query ] when* ] bi*
]
[ url-decode >>anchor ] bi* ;
: unparse-username-password ( url -- )
dup username>> dup [
% password>> [ ":" % % ] when* "@" %
] [ 2drop ] if ;
: unparse-host-part ( url protocol -- )
%
"://" %
"host" get url-encode %
"port" get [ ":" % # ] when*
"path" get "/" head? [ "Invalid URL" throw ] unless ;
{
[ unparse-username-password ]
[ host>> url-encode % ]
[ port>> [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
: url>string ( url -- string )
[
<mirror> [
"protocol" get [ unparse-host-part ] when*
"path" get url-encode %
"query" get [ "?" % assoc>query % ] when*
"anchor" get [ "#" % url-encode % ] when*
] bind
{
[ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
[ path>> url-encode % ]
[ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
[ anchor>> [ "#" % url-encode % ] when* ]
} cleave
] "" make ;
: fix-relative-path ( url base -- url base )
over path>> '[
"/" ?tail drop "/" , 3append
] change-path
[ f >>path ] dip ; inline
: url-append-path ( path1 path2 -- path )
{
{ [ dup "/" head? ] [ nip ] }
{ [ dup empty? ] [ drop ] }
{ [ over "/" tail? ] [ append ] }
{ [ "/" pick start not ] [ nip ] }
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
: derive-url ( url base -- url' )
clone
over path>> "/" head? [ fix-relative-path ] unless
[ <mirror> swap <mirror> [ nip ] assoc-filter update ] keep ;
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
[ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
>>path ;
: relative-url ( url -- url' )
clone f >>protocol f >>host f >>port ;
! Half-baked stuff follows
: secure-protocol? ( protocol -- ? )
"https" = ;
: url-addr ( url -- addr )
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
secure-protocol? [ <secure> ] when ;
: protocol-port ( protocol -- port )
{
{ "http" [ 80 ] }
{ "https" [ 443 ] }
{ "ftp" [ 21 ] }
} case ;
: ensure-port ( url -- url' )
dup protocol>> '[ , protocol-port or ] change-port ;
! Literal syntax
: URL" lexer get skip-blank parse-string >url parsed ; parsing
M: url pprint* dup url>string "URL\" " "\"" pprint-string ;

17
extra/webapps/counter/counter.factor
View File

@ -1,6 +1,7 @@
USING: math kernel accessors html.components
http.server http.server.actions
http.server.sessions html.templates.chloe fry ;
USING: math kernel accessors http.server http.server.dispatchers
furnace.actions furnace.sessions
html.components html.templates.chloe
fry urls ;
IN: webapps.counter
SYMBOL: count
@ -11,15 +12,15 @@ M: counter-app init-session* drop 0 count sset ;
: <counter-action> ( quot -- action )
<action>
swap '[ count , schange "" f <standard-redirect> ] >>submit ;
: counter-template ( -- template )
"resource:extra/webapps/counter/counter.xml" <chloe> ;
swap '[
count , schange
URL" $counter-app" <redirect>
] >>submit ;
: <display-action> ( -- action )
<page-action>
[ count sget "counter" set-value ] >>init
counter-template >>template ;
{ counter-app "counter" } >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher

23
extra/webapps/factor-website/factor-website.factor
View File

@ -4,13 +4,13 @@ USING: accessors kernel sequences assocs io.files io.sockets
io.server
namespaces db db.sqlite smtp
http.server
http.server.db
http.server.flows
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.boilerplate
html.templates.chloe
http.server.dispatchers
furnace.db
furnace.flows
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
furnace.boilerplate
webapps.pastebin
webapps.planet
webapps.todo
@ -20,9 +20,6 @@ IN: webapps.factor-website
: test-db "resource:test.db" sqlite-db ;
: factor-template ( path -- template )
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
: init-factor-db ( -- )
test-db [
init-users-table
@ -40,8 +37,10 @@ IN: webapps.factor-website
init-revisions-table
] with-db ;
TUPLE: factor-website < dispatcher ;
: <factor-website> ( -- responder )
<dispatcher>
factor-website new-dispatcher
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
@ -53,7 +52,7 @@ IN: webapps.factor-website
allow-password-recovery
allow-edit-profile
<boilerplate>
"page" factor-template >>template
{ factor-website "page" } >>template
<flows>
<sessions>
test-db <db-persistence> ;

2
extra/webapps/factor-website/page.xml
View File

@ -15,6 +15,8 @@
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:write-style />
<t:write-atom />
</head>
<body>

16
extra/webapps/pastebin/paste.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
<t:atom t:title="This paste" t:href="$pastebin/paste.atom" t:query="id" />
<t:title>Paste: <t:label t:name="summary" /></t:title>
@ -12,15 +12,13 @@
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
<pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
<pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
<t:each-tuple t:values="annotations">
<t:bind-each t:name="annotations">
<h2>Annotation: <t:label t:name="summary" /></h2>
<a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
<table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
@ -32,9 +30,9 @@
<t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
</t:each-tuple>
</t:bind-each>
<t:bind-assoc t:name="new-annotation">
<t:bind t:name="new-annotation">
<h2>New Annotation</h2>
@ -55,6 +53,6 @@
<input type="SUBMIT" value="Done" />
</t:form>
</t:bind-assoc>
</t:bind>
</t:chloe>

6
extra/webapps/pastebin/pastebin-common.xml
View File

@ -2,6 +2,8 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:title="Pastebin" t:href="$pastebin/list.atom" />
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar">
@ -9,9 +11,9 @@
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
<t:if t:code="http.server.sessions:uid">
<t:if t:code="furnace.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>

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

@ -2,15 +2,23 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser rss xml.writer
xmode.catalog validators html.components html.templates.chloe
calendar calendar.format math.parser rss urls xml.writer
xmode.catalog validators
html.components
html.templates.chloe
http.server
http.server.actions
http.server.auth
http.server.auth.login
http.server.boilerplate ;
http.server.dispatchers
http.server.redirection
furnace
furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate
furnace.rss ;
IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
! ! !
! DOMAIN MODEL
! ! !
@ -58,28 +66,31 @@ annotation "ANNOTATIONS"
: paste ( id -- paste )
<paste> select-tuple fetch-annotations ;
: <id-redirect> ( id next -- response )
swap "id" associate <standard-redirect> ;
! ! !
! LINKS, ETC
! ! !
: pastebin-link ( -- url )
"$pastebin/list" f link>string ;
URL" $pastebin/list" ;
GENERIC: entity-link ( entity -- url )
: paste-link ( id -- url )
<url>
"$pastebin/paste" >>path
swap "id" set-query-param ;
M: paste entity-link
id>> "id" associate "$pastebin/paste" swap link>string ;
id>> paste-link ;
: annotation-link ( parent id -- url )
<url>
"$pastebin/paste" >>path
swap number>string >>anchor
swap "id" set-query-param ;
M: annotation entity-link
[ parent>> "parent" associate "$pastebin/paste" swap link>string ]
[ id>> number>string "#" prepend ] bi
append ;
: pastebin-template ( name -- template )
"resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
[ parent>> ] [ id>> ] bi annotation-link ;
! ! !
! PASTE LIST
@ -88,7 +99,7 @@ M: annotation entity-link
: <pastebin-action> ( -- action )
<page-action>
[ pastes "pastes" set-value ] >>init
"pastebin" pastebin-template >>template ;
{ pastebin "pastebin" } >>template ;
: pastebin-feed-entries ( seq -- entries )
<reversed> 20 short head [
@ -96,7 +107,7 @@ M: annotation entity-link
swap
[ summary>> >>title ]
[ date>> >>pub-date ]
[ entity-link >>link ]
[ entity-link adjust-url relative-to-request >>link ]
tri
] map ;
@ -117,7 +128,7 @@ M: annotation entity-link
<page-action>
[
validate-integer-id
"id" value paste from-tuple
"id" value paste from-object
"id" value
"new-annotation" [
@ -127,7 +138,7 @@ M: annotation entity-link
] nest-values
] >>init
"paste" pastebin-template >>template ;
{ pastebin "paste" } >>template ;
: paste-feed-entries ( paste -- entries )
fetch-annotations annotations>> pastebin-feed-entries ;
@ -135,15 +146,15 @@ M: annotation entity-link
: paste-feed ( paste -- feed )
feed new
swap
[ "Paste #" swap id>> number>string append >>title ]
[ entity-link >>link ]
[ "Paste " swap id>> number>string append >>title ]
[ entity-link adjust-url relative-to-request >>link ]
[ paste-feed-entries >>entries ]
tri ;
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
[ "id" value paste annotations>> paste-feed ] >>feed ;
[ "id" value paste paste-feed ] >>feed ;
: validate-entity ( -- )
{
@ -165,7 +176,9 @@ M: annotation entity-link
mode-names "modes" set-value
] >>init
"new-paste" pastebin-template >>template
{ pastebin "new-paste" } >>template
[ mode-names "modes" set-value ] >>validate
[
validate-entity
@ -173,7 +186,7 @@ M: annotation entity-link
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
[ id>> "$pastebin/paste" <id-redirect> ]
[ id>> paste-link <redirect> ]
tri
] >>submit ;
@ -184,7 +197,7 @@ M: annotation entity-link
[
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
"$pastebin/list" f <permanent-redirect>
URL" $pastebin/list" <redirect>
] >>submit ;
! ! !
@ -192,10 +205,10 @@ M: annotation entity-link
! ! !
: <new-annotation-action> ( -- action )
<page-action>
<action>
[
{ { "id" [ v-integer ] } } validate-params
"id" value "$pastebin/paste" <id-redirect>
"id" value paste-link <redirect>
] >>display
[
@ -207,10 +220,7 @@ M: annotation entity-link
"id" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
[
! Add anchor here
parent>> "$pastebin/paste" <id-redirect>
]
[ entity-link <redirect> ]
tri
] >>submit ;
@ -221,12 +231,10 @@ M: annotation entity-link
[
f "id" value <annotation> select-tuple
[ delete-tuples ]
[ parent>> "$pastebin/paste" <id-redirect> ]
[ parent>> paste-link <redirect> ]
bi
] >>submit ;
TUPLE: pastebin < dispatcher ;
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
@ -242,7 +250,7 @@ can-delete-pastes? define-capability
<new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
"pastebin-common" pastebin-template >>template ;
{ pastebin "pastebin-common" } >>template ;
: init-pastes-table \ paste ensure-table ;

6
extra/webapps/pastebin/pastebin.xml
View File

@ -2,8 +2,6 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
<t:title>Pastebin</t:title>
<table width="100%">
@ -11,13 +9,13 @@
<th align="left" width="100">Paste by:</th>
<th align="left" width="200">Date:</th>
<t:each-tuple t:values="pastes">
<t:bind-each t:name="pastes">
<tr>
<td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
<td><t:label t:name="author" /></td>
<td><t:label t:name="date" /></td>
</tr>
</t:each-tuple>
</t:bind-each>
</table>
</t:chloe>

4
extra/webapps/planet/admin.xml
View File

@ -5,13 +5,13 @@
<t:title>Planet Factor Administration</t:title>
<ul>
<t:each-tuple t:values="blogroll">
<t:bind-each t:name="blogroll">
<li>
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
<t:label t:name="name" />
</t:a>
</li>
</t:each-tuple>
</t:bind-each>
</ul>
<p>

2
extra/webapps/planet/entry-summary.xml
View File

@ -4,7 +4,7 @@
<p class="news">
<strong><t:view t:component="title" /></strong> <br/>
<t:a value="link" t:session="none" class="more">Read More...</t:a>
<t:a value="link" class="more">Read More...</t:a>
</p>
</t:chloe>

4
extra/webapps/planet/entry.xml
View File

@ -3,7 +3,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title">
<t:a t:value="link" t:session="none"><t:view t:component="title" /></t:a>
<t:a t:value="link"><t:view t:component="title" /></t:a>
</h2>
<p class="posting-body">
@ -11,7 +11,7 @@
</p>
<p class="posting-date">
<t:a t:value="link" t:session="none"><t:view t:component="pub-date" /></t:a>
<t:a t:value="link"><t:view t:component="pub-date" /></t:a>
</p>
</t:chloe>

6
extra/webapps/planet/mini-planet.xml
View File

@ -2,13 +2,13 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:each-tuple t:values="postings">
<t:bind-each t:name="postings">
<p class="news">
<strong><t:view t:component="title" /></strong> <br/>
<t:a value="link" t:session="none" class="more">Read More...</t:a>
<t:a value="link" class="more">Read More...</t:a>
</p>
</t:each-tuple>
</t:bind-each>
</t:chloe>

4
extra/webapps/planet/planet-common.xml
View File

@ -9,8 +9,8 @@
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
<t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>

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

@ -3,18 +3,22 @@
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
html.components html.templates.chloe
rss xml.writer
html.components
rss urls xml.writer
validators
http.server
http.server.actions
http.server.boilerplate
http.server.auth.login
http.server.auth ;
http.server.dispatchers
furnace
furnace.actions
furnace.boilerplate
furnace.auth.login
furnace.auth
furnace.rss ;
IN: webapps.planet
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
TUPLE: planet-factor < dispatcher ;
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
@ -61,7 +65,7 @@ posting "POSTINGS"
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
"admin" planet-template >>template ;
{ planet-factor "admin" } >>template ;
: <planet-action> ( -- action )
<page-action>
@ -70,7 +74,7 @@ posting "POSTINGS"
postings "postings" set-value
] >>init
"planet" planet-template >>template ;
{ planet-factor "planet" } >>template ;
: planet-feed ( -- feed )
feed new
@ -110,7 +114,7 @@ posting "POSTINGS"
<action>
[
update-cached-postings
"" f <permanent-redirect>
URL" $planet-factor/admin" <redirect>
] >>submit ;
: <delete-blog-action> ( -- action )
@ -119,7 +123,7 @@ posting "POSTINGS"
[
"id" value <blog> delete-tuples
"$planet-factor/admin" f <standard-redirect>
URL" $planet-factor/admin" <redirect>
] >>submit ;
: validate-blog ( -- )
@ -129,15 +133,12 @@ posting "POSTINGS"
{ "feed-url" [ v-url ] }
} validate-params ;
: <id-redirect> ( id next -- response )
swap "id" associate <standard-redirect> ;
: deposit-blog-slots ( blog -- )
{ "name" "www-url" "feed-url" } deposit-slots ;
: <new-blog-action> ( -- action )
<page-action>
"new-blog" planet-template >>template
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
@ -145,7 +146,12 @@ posting "POSTINGS"
f <blog>
[ deposit-blog-slots ]
[ insert-tuple ]
[ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
[
<url>
"$planet-factor/admin/edit-blog" >>path
swap id>> "id" set-query-param
<redirect>
]
tri
] >>submit ;
@ -153,10 +159,10 @@ posting "POSTINGS"
<page-action>
[
validate-integer-id
"id" value <blog> select-tuple from-tuple
"id" value <blog> select-tuple from-object
] >>init
"edit-blog" planet-template >>template
{ planet-factor "edit-blog" } >>template
[
validate-integer-id
@ -167,12 +173,15 @@ posting "POSTINGS"
f <blog>
[ deposit-blog-slots ]
[ update-tuple ]
[ id>> "$planet-factor/admin" <id-redirect> ]
[
<url>
"$planet-factor/admin" >>path
swap id>> "id" set-query-param
<redirect>
]
tri
] >>submit ;
TUPLE: planet-factor-admin < dispatcher ;
: <planet-factor-admin> ( -- responder )
planet-factor-admin new-dispatcher
<edit-blogroll-action> "blogroll" add-main-responder
@ -185,15 +194,13 @@ SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
TUPLE: planet-factor < dispatcher ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
"planet-common" planet-template >>template ;
{ planet-factor "planet-common" } >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;

10
extra/webapps/planet/planet.xml
View File

@ -8,10 +8,10 @@
<tr>
<td>
<t:each-tuple t:values="postings">
<t:bind-each t:name="postings">
<h2 class="posting-title">
<t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
<t:a t:value="link"><t:label t:name="title" /></t:a>
</h2>
<p class="posting-body">
@ -19,10 +19,10 @@
</p>
<p class="posting-date">
<t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
<t:a t:value="link"><t:label t:name="pub-date" /></t:a>
</p>
</t:each-tuple>
</t:bind-each>
</td>
@ -31,7 +31,7 @@
<h2>Blogroll</h2>
<ul>
<t:each t:values="blogroll">
<t:each t:name="blogroll">
<li>
<t:link t:name="value"/>
</li>

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

@ -14,12 +14,8 @@
<input type="SUBMIT" value="Done" />
</t:form>
<t:if t:value="id">
<t:a t:href="$todo-list/view" t:query="id">View</t:a>
|
<t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:if>
<t:a t:href="$todo-list/view" t:query="id">View</t:a>
|
<t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>

17
extra/webapps/todo/new-todo.xml Normal file
View File

@ -0,0 +1,17 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New Item</t:title>
<t:form t:action="$todo-list/new">
<table>
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
</t:chloe>

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

@ -13,7 +13,7 @@
<th>Edit</th>
</tr>
<t:each-tuple t:values="items">
<t:bind-each t:name="items">
<tr>
<td>
@ -30,7 +30,7 @@
</td>
</tr>
</t:each-tuple>
</t:bind-each>
</table>

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

@ -1,18 +1,22 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
db db.types db.tuples validators hashtables
db db.types db.tuples validators hashtables urls
html.components
html.templates.chloe
http.server.sessions
http.server.boilerplate
http.server.auth
http.server.actions
http.server.db
http.server.auth.login
http.server ;
http.server
http.server.dispatchers
furnace
furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
furnace.db
furnace.auth.login ;
IN: webapps.todo
TUPLE: todo-list < dispatcher ;
TUPLE: todo uid id priority summary description ;
todo "TODO"
@ -31,20 +35,14 @@ todo "TODO"
swap >>id
uid >>uid ;
: todo-template ( name -- template )
"resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
: <view-action> ( -- action )
<page-action>
[
validate-integer-id
"id" value <todo> select-tuple from-tuple
"id" value <todo> select-tuple from-object
] >>init
"view-todo" todo-template >>template ;
: <id-redirect> ( id next -- response )
swap "id" associate <standard-redirect> ;
{ todo-list "view-todo" } >>template ;
: validate-todo ( -- )
{
@ -57,15 +55,20 @@ todo "TODO"
<page-action>
[ 0 "priority" set-value ] >>init
"edit-todo" todo-template >>template
{ todo-list "new-todo" } >>template
[ validate-todo ] >>validate
[
f <todo>
dup { "summary" "description" } deposit-slots
dup { "summary" "priority" "description" } deposit-slots
[ insert-tuple ]
[ id>> "$todo-list/view" <id-redirect> ]
[
<url>
"$todo-list/view" >>path
swap id>> "id" set-query-param
<redirect>
]
bi
] >>submit ;
@ -73,10 +76,10 @@ todo "TODO"
<page-action>
[
validate-integer-id
"id" value <todo> select-tuple from-tuple
"id" value <todo> select-tuple from-object
] >>init
"edit-todo" todo-template >>template
{ todo-list "edit-todo" } >>template
[
validate-integer-id
@ -87,7 +90,12 @@ todo "TODO"
f <todo>
dup { "id" "summary" "priority" "description" } deposit-slots
[ update-tuple ]
[ id>> "$todo-list/view" <id-redirect> ]
[
<url>
"$todo-list/view" >>path
swap id>> "id" set-query-param
<redirect>
]
bi
] >>submit ;
@ -97,15 +105,13 @@ todo "TODO"
[
"id" get <todo> delete-tuples
"$todo-list/list" f <standard-redirect>
URL" $todo-list/list" <redirect>
] >>submit ;
: <list-action> ( -- action )
<page-action>
[ f <todo> select-tuples "items" set-value ] >>init
"todo-list" todo-template >>template ;
TUPLE: todo-list < dispatcher ;
{ todo-list "todo-list" } >>template ;
: <todo-list> ( -- responder )
todo-list new-dispatcher
@ -115,5 +121,5 @@ TUPLE: todo-list < dispatcher ;
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<boilerplate>
"todo" todo-template >>template
{ todo-list "todo" } >>template
f <protected> ;

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

@ -6,9 +6,9 @@
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$todo-list/edit">Add Item</t:a>
| <t:a t:href="$todo-list/new">Add Item</t:a>
<t:if t:code="http.server.auth.login:allow-edit-profile?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>

6
extra/webapps/user-admin/edit-user.xml
View File

@ -35,7 +35,11 @@
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
<td>
<t:each t:name="capabilities">
<t:checkbox t:name="@value" t:label="@value" /><br/>
</t:each>
</td>
</tr>
<tr>

6
extra/webapps/user-admin/new-user.xml
View File

@ -35,7 +35,11 @@
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
<td>
<t:each t:name="capabilities">
<li><t:checkbox t:name="@value" t:label="@value" /><br/>
</t:each>
</td>
</tr>
</table>

79
extra/webapps/user-admin/user-admin.factor
View File

@ -1,45 +1,59 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators
assocs db.tuples arrays splitting strings validators urls
html.elements
html.components
html.templates.chloe
http.server.boilerplate
http.server.auth.providers
http.server.auth.providers.db
http.server.auth.login
http.server.auth
http.server.sessions
http.server.actions
http.server ;
furnace
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db
furnace.auth.login
furnace.auth
furnace.sessions
furnace.actions
http.server
http.server.dispatchers ;
IN: webapps.user-admin
: admin-template ( name -- template )
"resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
TUPLE: user-admin < dispatcher ;
: word>string ( word -- string )
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: words>strings ( seq -- seq' )
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
[ word>string ] map ;
: string>word ( string -- word )
":" split1 swap lookup ;
: strings>words ( seq -- seq' )
[ ":" split1 swap lookup ] map ;
[ string>word ] map ;
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
"user-list" admin-template >>template ;
{ user-admin "user-list" } >>template ;
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
: selected-capabilities ( -- seq )
"capabilities" value
[ param empty? not ] filter
[ string>word ] map ;
: <new-user-action> ( -- action )
<page-action>
[
"username" param <user> from-tuple
capabilities get words>strings "all-capabilities" set-value
"username" param <user> from-object
init-capabilities
] >>init
"new-user" admin-template >>template
{ user-admin "new-user" } >>template
[
capabilities get words>strings "all-capabilities" set-value
init-capabilities
{
{ "username" [ v-username ] }
@ -62,10 +76,11 @@ IN: webapps.user-admin
"email" value >>email
"new-password" value >>encoded-password
H{ } clone >>profile
selected-capabilities >>capabilities
insert-tuple
"$user-admin" f <standard-redirect>
URL" $user-admin" <redirect>
] >>submit ;
: validate-username ( -- )
@ -77,15 +92,16 @@ IN: webapps.user-admin
validate-username
"username" value <user> select-tuple
[ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
[ from-object ]
[ capabilities>> [ "true" swap word>string set-value ] each ] bi
capabilities get words>strings "all-capabilities" set-value
capabilities get words>strings "capabilities" set-value
] >>init
"edit-user" admin-template >>template
{ user-admin "edit-user" } >>template
[
capabilities get words>strings "all-capabilities" set-value
init-capabilities
{
{ "username" [ v-username ] }
@ -93,7 +109,6 @@ IN: webapps.user-admin
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
{ "capabilities" [ ] }
} validate-params
"new-password" "verify-password"
@ -106,19 +121,15 @@ IN: webapps.user-admin
"username" value <user> select-tuple
"realname" value >>realname
"email" value >>email
selected-capabilities >>capabilities
"new-password" value empty? [
"new-password" value >>encoded-password
] unless
"capabilities" value {
{ [ dup string? ] [ 1array ] }
{ [ dup array? ] [ ] }
} cond strings>words >>capabilities
update-tuple
"$user-admin" f <standard-redirect>
URL" $user-admin" <redirect>
] >>submit ;
: <delete-user-action> ( -- action )
@ -130,11 +141,9 @@ IN: webapps.user-admin
[ logout-all-sessions ]
bi
"$user-admin" f <standard-redirect>
URL" $user-admin" <redirect>
] >>submit ;
TUPLE: user-admin < dispatcher ;
SYMBOL: can-administer-users?
can-administer-users? define-capability
@ -146,7 +155,7 @@ can-administer-users? define-capability
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<boilerplate>
"user-admin" admin-template >>template
{ user-admin "user-admin" } >>template
{ can-administer-users? } <protected> ;
: make-admin ( username -- )

2
extra/webapps/user-admin/user-admin.xml
View File

@ -6,7 +6,7 @@
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
<t:if t:code="http.server.auth.login:allow-edit-profile?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>

4
extra/webapps/user-admin/user-list.xml
View File

@ -6,13 +6,13 @@
<ul>
<t:each-tuple t:values="users">
<t:bind-each t:name="users">
<li>
<t:a t:href="$user-admin/edit" t:query="username">
<t:label t:name="username" />
</t:a>
</li>
</t:each-tuple>
</t:bind-each>
</ul>

4
extra/webapps/wiki/articles.xml
View File

@ -5,11 +5,11 @@
<t:title>All Articles</t:title>
<ul>
<t:each-tuple t:values="articles">
<t:bind-each t:name="articles">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
</li>
</t:each-tuple>
</t:bind-each>
</ul>
</t:chloe>

Some files were not shown because too many files have changed in this diff Show More