Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
c605dff3e8
core/io/files
extra
cairo/gadgets
furnace
boilerplate
flows
json
rss
html
components
elements
parser/analyzer
http
mime
server
cgi
dispatchers
filters
redirection
responses
static
io/pools
lcs/diff2html
opengl/gadgets
openssl
pango/cairo
rss
tangle
unicode/collation
webapps
counter
factor-website
user-admin
|
|
@ -147,6 +147,9 @@ PRIVATE>
|
|||
] if
|
||||
] unless ;
|
||||
|
||||
: file-extension ( filename -- extension )
|
||||
"." last-split1 nip ;
|
||||
|
||||
! File info
|
||||
TUPLE: file-info type size permissions modified ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences math opengl.gadgets kernel
|
||||
byte-arrays cairo.ffi cairo io.backend
|
||||
opengl.gl arrays ;
|
||||
ui.gadgets accessors opengl.gl
|
||||
arrays ;
|
||||
|
||||
IN: cairo.gadgets
|
||||
|
||||
|
|
@ -14,9 +15,19 @@ IN: cairo.gadgets
|
|||
[ cairo_image_surface_create_for_data ] 3bi
|
||||
r> with-cairo-from-surface ;
|
||||
|
||||
: <cairo-gadget> ( dim quot -- )
|
||||
over 2^-bounds swap copy-cairo
|
||||
GL_BGRA rot <texture-gadget> ;
|
||||
TUPLE: cairo-gadget < texture-gadget quot ;
|
||||
|
||||
: <cairo-gadget> ( dim quot -- gadget )
|
||||
cairo-gadget construct-gadget
|
||||
swap >>quot
|
||||
swap >>dim ;
|
||||
|
||||
M: cairo-gadget format>> drop GL_BGRA ;
|
||||
|
||||
M: cairo-gadget render* ( gadget -- )
|
||||
dup
|
||||
[ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
|
||||
>>bytes call-next-method ;
|
||||
|
||||
! maybe also texture>png
|
||||
! : cairo>png ( gadget path -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (c) 2007 Chris Double.
|
||||
! 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
|
||||
http sequences ;
|
||||
IN: http.server.auth.basic
|
||||
base64 html.elements io combinators sequences
|
||||
http http.server.filters http.server.responses http.server
|
||||
furnace.auth.providers furnace.auth.login ;
|
||||
IN: furnace.auth.basic
|
||||
|
||||
TUPLE: basic-auth < filter-responder realm provider ;
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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? ;
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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"
|
||||
{
|
||||
|
|
@ -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,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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.db.tests
|
||||
USING: tools.test furnace.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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> ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
[
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
IN: html.components.tests
|
||||
USING: tools.test kernel io.streams.string
|
||||
io.streams.null accessors inspector html.streams
|
||||
html.components namespaces ;
|
||||
html.elements html.components namespaces ;
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs html.parser kernel math sequences strings ascii
|
||||
arrays shuffle unicode.case namespaces splitting http
|
||||
sequences.lib accessors io combinators http.client ;
|
||||
sequences.lib accessors io combinators http.client urls ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
TUPLE: link attributes clickable ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: html.templates html.templates.chloe
|
||||
tools.test io.streams.string kernel sequences ascii boxes
|
||||
namespaces xml html.components
|
||||
splitting unicode.categories ;
|
||||
splitting unicode.categories furnace ;
|
||||
IN: html.templates.chloe.tests
|
||||
|
||||
[ f ] [ f parse-query-attr ] unit-test
|
||||
|
|
@ -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" ] [
|
||||
[
|
||||
|
|
@ -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
|
||||
"test8" test-template call-template
|
||||
] run-template [ blank? not ] filter
|
||||
] unit-test
|
||||
|
||||
[ ] [ 1 "id" set-value ] unit-test
|
||||
|
||||
[ "<a name=\"1\">Hello</a>" ] [
|
||||
[
|
||||
"test9" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ensure-port 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 ;
|
||||
|
|
@ -98,12 +100,11 @@ M: download-failed error.
|
|||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: <post-request> ( content-type content url -- request )
|
||||
: <post-request> ( post-data url -- request )
|
||||
<request>
|
||||
"POST" >>method
|
||||
swap request-with-url
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
swap >url ensure-port >>url
|
||||
swap >>post-data ;
|
||||
|
||||
: http-post ( content-type content url -- response data )
|
||||
: http-post ( post-data url -- response data )
|
||||
<post-request> http-request ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs io.files io.streams.duplex
|
||||
combinators arrays io.launcher io http.server.static http.server
|
||||
http accessors sequences strings math.parser fry ;
|
||||
http accessors sequences strings math.parser fry urls ;
|
||||
IN: http.server.cgi
|
||||
|
||||
: post? request get method>> "POST" = ;
|
||||
|
|
@ -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
|
||||
|
|
@ -29,7 +28,7 @@ IN: http.server.cgi
|
|||
"" "REMOTE_IDENT" set
|
||||
|
||||
request get method>> "REQUEST_METHOD" set
|
||||
request get query>> assoc>query "QUERY_STRING" set
|
||||
request get url>> query>> assoc>query "QUERY_STRING" set
|
||||
request get "cookie" header "HTTP_COOKIE" set
|
||||
|
||||
request get "user-agent" header "HTTP_USER_AGENT" set
|
||||
|
|
|
|||
|
|
@ -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
63
extra/http/server/server-tests.factor → extra/http/server/dispatchers/dispatchers-tests.factor
Executable file → Normal 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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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> ;
|
||||
|
|
@ -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> ;
|
||||
|
|
@ -1,276 +1,74 @@
|
|||
! 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> 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 +85,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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -19,7 +19,9 @@ TUPLE: texture-gadget bytes format dim tex ;
|
|||
swap >>format
|
||||
swap >>bytes ;
|
||||
|
||||
:: render ( gadget -- )
|
||||
GENERIC: render* ( texture-gadget -- )
|
||||
|
||||
M:: texture-gadget render* ( gadget -- )
|
||||
GL_ENABLE_BIT [
|
||||
GL_TEXTURE_2D glEnable
|
||||
GL_TEXTURE_2D gadget tex>> glBindTexture
|
||||
|
|
@ -63,8 +65,8 @@ M: texture-gadget draw-gadget* ( gadget -- )
|
|||
] with-translation ;
|
||||
|
||||
M: texture-gadget graft* ( gadget -- )
|
||||
gen-texture >>tex [ render ]
|
||||
[ f >>bytes f >>format drop ] bi ;
|
||||
gen-texture >>tex [ render* ]
|
||||
[ f >>bytes drop ] bi ;
|
||||
|
||||
M: texture-gadget ungraft* ( gadget -- )
|
||||
tex>> delete-texture ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors debugger inspector
|
||||
continuations destructors debugger inspector splitting
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
|
||||
|
|
@ -188,8 +188,12 @@ M: ssl-handle dispose*
|
|||
[ 256 X509_NAME_get_text_by_NID ] keep
|
||||
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
|
||||
|
||||
: common-names-match? ( expected actual -- ? )
|
||||
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
|
||||
|
||||
: check-common-name ( host ssl-handle -- )
|
||||
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
|
||||
SSL_get_peer_certificate common-name
|
||||
2dup common-names-match?
|
||||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
! pangocairo bindings, from pango/pangocairo.h
|
||||
USING: cairo.ffi alien.c-types math
|
||||
alien.syntax system combinators alien
|
||||
memoize
|
||||
arrays pango pango.fonts ;
|
||||
IN: pango.cairo
|
||||
|
||||
|
|
@ -111,9 +112,11 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
|
|||
0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
|
||||
[ *int ] bi@ ;
|
||||
|
||||
MEMO: dummy-cairo ( -- cr )
|
||||
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
|
||||
|
||||
: dummy-pango ( quot -- )
|
||||
>r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
|
||||
r> [ with-pango ] curry with-cairo-from-surface ; inline
|
||||
>r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline
|
||||
|
||||
: layout-size ( quot -- dim )
|
||||
[ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
|
||||
|
|
@ -127,5 +130,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
|
|||
: layout-text ( str -- )
|
||||
layout swap -1 pango_layout_set_text ;
|
||||
|
||||
: show-layout ( -- )
|
||||
cr layout pango_cairo_show_layout ;
|
||||
|
||||
: families ( -- families )
|
||||
pango_cairo_font_map_get_default list-families ;
|
||||
|
|
|
|||
|
|
@ -1,30 +1,64 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: pango.cairo cairo cairo.ffi cairo.gadgets
|
||||
USING: pango.cairo cairo cairo.ffi
|
||||
cairo.gadgets namespaces arrays
|
||||
fry accessors ui.gadgets assocs
|
||||
sequences shuffle opengl opengl.gadgets
|
||||
alien.c-types kernel math ;
|
||||
IN: pango.cairo.gadgets
|
||||
|
||||
: (pango-gadget) ( setup show -- gadget )
|
||||
[ drop layout-size ]
|
||||
[ compose [ with-pango ] curry <cairo-gadget> ] 2bi ;
|
||||
SYMBOL: textures
|
||||
SYMBOL: dims
|
||||
SYMBOL: refcounts
|
||||
|
||||
: <pango-gadget> ( quot -- gadget )
|
||||
[ cr layout pango_cairo_show_layout ] (pango-gadget) ;
|
||||
: init-cache ( symbol -- )
|
||||
dup get [ drop ] [ H{ } clone swap set-global ] if ;
|
||||
|
||||
USING: prettyprint sequences ui.gadgets.panes
|
||||
threads io.backend io.encodings.utf8 io.files ;
|
||||
: hello-pango ( -- )
|
||||
50 [ 6 + ] map [
|
||||
"Sans " swap unparse append
|
||||
[
|
||||
cr 0 1 0.2 0.6 cairo_set_source_rgba
|
||||
layout-font "今日は、 Pango!" layout-text
|
||||
] curry
|
||||
<pango-gadget> gadget. yield
|
||||
] each
|
||||
[
|
||||
"resource:extra/pango/cairo/gadgets/gadgets.factor"
|
||||
normalize-path utf8 file-contents layout-text
|
||||
] <pango-gadget> gadget. ;
|
||||
textures init-cache
|
||||
dims init-cache
|
||||
refcounts init-cache
|
||||
|
||||
MAIN: hello-pango
|
||||
TUPLE: pango-gadget < cairo-gadget text font ;
|
||||
|
||||
: cache-key ( gadget -- key )
|
||||
[ font>> ] [ text>> ] bi 2array ;
|
||||
|
||||
: refcount-change ( gadget quot -- )
|
||||
>r cache-key refcounts get
|
||||
[ [ 0 ] unless* ] r> compose change-at ;
|
||||
|
||||
: <pango-gadget> ( font text -- gadget )
|
||||
pango-gadget construct-gadget
|
||||
swap >>text
|
||||
swap >>font ;
|
||||
|
||||
: setup-layout ( {font,text} -- quot )
|
||||
first2 '[ , layout-font , layout-text ] ;
|
||||
|
||||
M: pango-gadget quot>> ( gadget -- quot )
|
||||
cache-key setup-layout [ show-layout ] compose
|
||||
[ with-pango ] curry ;
|
||||
|
||||
M: pango-gadget dim>> ( gadget -- dim )
|
||||
cache-key dims get [ setup-layout layout-size ] cache ;
|
||||
|
||||
M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
|
||||
|
||||
: release-texture ( gadget -- )
|
||||
cache-key textures get delete-at* [ delete-texture ] [ drop ] if ;
|
||||
|
||||
M: pango-gadget ungraft* ( gadget -- )
|
||||
dup [ 1- ] refcount-change
|
||||
dup cache-key refcounts get at
|
||||
zero? [ release-texture ] [ drop ] if ;
|
||||
|
||||
M: pango-gadget render* ( gadget -- )
|
||||
[ gen-texture ] [ cache-key textures get set-at ] bi
|
||||
call-next-method ;
|
||||
|
||||
M: pango-gadget tex>> ( gadget -- texture )
|
||||
dup cache-key textures get at
|
||||
[ nip ] [ dup render* tex>> ] if* ;
|
||||
|
||||
USE: ui.gadgets.panes
|
||||
: hello "Sans 50" "hello" <pango-gadget> gadget. ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
! Copyright (C) 2008 Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: prettyprint sequences ui.gadgets.panes
|
||||
pango.cairo.gadgets math kernel cairo cairo.ffi
|
||||
pango.cairo tools.time namespaces assocs
|
||||
threads io.backend io.encodings.utf8 io.files ;
|
||||
|
||||
IN: pango.cairo.samples
|
||||
|
||||
: hello-pango ( -- )
|
||||
"monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
|
||||
normalize-path utf8 file-contents
|
||||
<pango-gadget> gadget. ;
|
||||
|
||||
: time-pango ( -- )
|
||||
[ hello-pango ] time ;
|
||||
|
||||
! clear the caches, for testing.
|
||||
: clear-pango ( -- )
|
||||
dims get clear-assoc
|
||||
textures get clear-assoc ;
|
||||
|
||||
MAIN: time-pango
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,42 @@
|
|||
USING: help.syntax help.markup ;
|
||||
USING: help.syntax help.markup strings byte-arrays ;
|
||||
IN: unicode.collation
|
||||
|
||||
ABOUT: "unicode.collation"
|
||||
|
||||
ARTICLE: "unicode.collation" "Unicode collation algorithm"
|
||||
"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode." ;
|
||||
"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
{ $subsection sort-strings }
|
||||
{ $subsection collation-key }
|
||||
{ $subsection string<=> }
|
||||
{ $subsection primary= }
|
||||
{ $subsection secondary= }
|
||||
{ $subsection tertiary= }
|
||||
{ $subsection quaternary= } ;
|
||||
|
||||
HELP: sort-strings
|
||||
{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
|
||||
{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
|
||||
|
||||
HELP: collation-key
|
||||
{ $values { "string" string } { "key" byte-array } }
|
||||
{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ;
|
||||
|
||||
HELP: string<=>
|
||||
{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } }
|
||||
{ $description "This word takes two strings and compares them using the UCA with the DUCET, using code point order as a tie-breaker." } ;
|
||||
|
||||
HELP: primary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ;
|
||||
|
||||
HELP: secondary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ;
|
||||
|
||||
HELP: tertiary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "Along the same lines as secondary=, but case is significant." } ;
|
||||
|
||||
HELP: quaternary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
|
||||
|
|
|
|||
|
|
@ -24,6 +24,9 @@ IN: unicode.collation.tests
|
|||
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
|
||||
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
|
||||
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test
|
||||
[ { "good bye" "goodbye" "hello" "HELLO" } ]
|
||||
[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ]
|
||||
unit-test
|
||||
|
||||
parse-test 2 <clumps>
|
||||
[ [ test-two ] assoc-each ] with-null-writer
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ unicode.syntax macros sequences.deep words unicode.breaks
|
|||
quotations ;
|
||||
IN: unicode.collation
|
||||
|
||||
<PRIVATE
|
||||
VALUE: ducet
|
||||
|
||||
TUPLE: weight primary secondary tertiary ignorable? ;
|
||||
|
|
@ -115,6 +116,7 @@ ducet insert-helpers
|
|||
[ [ variable-weight ] each ]
|
||||
} cleave
|
||||
] { } make ;
|
||||
PRIVATE>
|
||||
|
||||
: completely-ignorable? ( weight -- ? )
|
||||
[ primary>> ] [ secondary>> ] [ tertiary>> ] tri
|
||||
|
|
@ -131,11 +133,13 @@ ducet insert-helpers
|
|||
nfd string>graphemes graphemes>weights
|
||||
filter-ignorable weights>bytes ;
|
||||
|
||||
<PRIVATE
|
||||
: insensitive= ( str1 str2 levels-removed -- ? )
|
||||
[
|
||||
swap collation-key swap
|
||||
[ [ 0 = not ] right-trim but-last ] times
|
||||
] curry bi@ = ;
|
||||
PRIVATE>
|
||||
|
||||
: primary= ( str1 str2 -- ? )
|
||||
3 insensitive= ;
|
||||
|
|
@ -149,17 +153,14 @@ ducet insert-helpers
|
|||
: quaternary= ( str1 str2 -- ? )
|
||||
0 insensitive= ;
|
||||
|
||||
: compare-collation ( {str1,key} {str2,key} -- <=> )
|
||||
2dup [ second ] bi@ <=> dup +eq+ =
|
||||
[ drop <=> ] [ 2nip ] if ;
|
||||
|
||||
<PRIVATE
|
||||
: w/collation-key ( str -- {str,key} )
|
||||
dup collation-key 2array ;
|
||||
[ collation-key ] keep 2array ;
|
||||
PRIVATE>
|
||||
|
||||
: sort-strings ( strings -- sorted )
|
||||
[ w/collation-key ] map
|
||||
[ compare-collation ] sort
|
||||
keys ;
|
||||
natural-sort values ;
|
||||
|
||||
: string<=> ( str1 str2 -- <=> )
|
||||
[ w/collation-key ] bi@ compare-collation ;
|
||||
[ w/collation-key ] compare ;
|
||||
|
|
|
|||
|
|
@ -77,10 +77,36 @@ 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 [
|
||||
|
|
@ -192,3 +218,7 @@ urls [
|
|||
|
||||
derive-url
|
||||
] unit-test
|
||||
|
||||
[ "a" ] [
|
||||
<url> "a" "b" set-query-param "b" query-param
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +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 -- ? )
|
||||
|
|
@ -89,13 +90,15 @@ IN: urls
|
|||
] assoc-each
|
||||
] { } make "&" join ;
|
||||
|
||||
TUPLE: url protocol host port path query anchor ;
|
||||
TUPLE: url protocol username password host port path query anchor ;
|
||||
|
||||
: query-param ( request key -- value )
|
||||
: <url> ( -- url ) url new ;
|
||||
|
||||
: query-param ( url key -- value )
|
||||
swap query>> at ;
|
||||
|
||||
: set-query-param ( request value key -- request )
|
||||
pick query>> set-at ;
|
||||
: set-query-param ( url value key -- url )
|
||||
'[ , , _ ?set-at ] change-query ;
|
||||
|
||||
: parse-host ( string -- host port )
|
||||
":" split1 [ url-decode ] [
|
||||
|
|
@ -105,40 +108,56 @@ TUPLE: url protocol host port path query anchor ;
|
|||
] when
|
||||
] bi* ;
|
||||
|
||||
: parse-host-part ( protocol rest -- string' )
|
||||
[ "protocol" set ] [
|
||||
: parse-host-part ( url protocol rest -- url string' )
|
||||
[ >>protocol ] [
|
||||
"//" ?head [ "Invalid URL" throw ] unless
|
||||
"@" split1 [
|
||||
[
|
||||
":" split1 [ >>username ] [ >>password ] bi*
|
||||
] dip
|
||||
] when*
|
||||
"/" split1 [
|
||||
parse-host [ "host" set ] [ "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 ;
|
||||
|
||||
: url-append-path ( path1 path2 -- path )
|
||||
|
|
@ -158,3 +177,26 @@ TUPLE: url protocol host port path query anchor ;
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -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 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
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
|
||||
|
||||
<t:write-style />
|
||||
|
||||
<t:write-atom />
|
||||
</head>
|
||||
|
||||
<body>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue