Web framework refactoring work in progress
Slava Pestov
parent
7eca88cdb5
commit
c5c65a4ce4
|
|
@ -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
|
||||
|
|
@ -2,8 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences kernel assocs combinators http.server
|
||||
validators http hashtables namespaces fry continuations locals
|
||||
boxes xml.entities html.elements html.components io arrays math ;
|
||||
IN: http.server.actions
|
||||
boxes xml.entities html.elements html.components
|
||||
html.templates.chloe io arrays math ;
|
||||
IN: furnace.actions
|
||||
|
||||
SYMBOL: params
|
||||
|
||||
|
|
@ -17,6 +18,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 +78,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 +86,15 @@ 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 ;
|
||||
dup '[ , template>> <chloe-content> ] >>display ;
|
||||
|
||||
TUPLE: feed-action < action feed ;
|
||||
|
||||
: <feed-action> ( -- feed )
|
||||
feed-action new
|
||||
feed-action new-action
|
||||
dup '[ , feed>> call <feed-content> ] >>display ;
|
||||
|
|
@ -2,9 +2,9 @@
|
|||
! 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
|
||||
furnace.sessions
|
||||
furnace.auth.providers ;
|
||||
IN: furnace.auth
|
||||
|
||||
SYMBOL: logged-in-user
|
||||
|
||||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors quotations assocs kernel splitting
|
||||
base64 html.elements io combinators http.server
|
||||
http.server.auth.providers http.server.auth.login
|
||||
furnace.auth.providers furnace.auth.login
|
||||
http sequences ;
|
||||
IN: http.server.auth.basic
|
||||
IN: furnace.auth.basic
|
||||
|
||||
TUPLE: basic-auth < filter-responder realm provider ;
|
||||
|
||||
|
|
@ -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,18 @@ 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 ;
|
||||
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,10 +58,6 @@ 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 ;
|
||||
|
|
@ -72,8 +67,8 @@ M: user-saver dispose
|
|||
validation-failed ;
|
||||
|
||||
: <login-action> ( -- action )
|
||||
<action>
|
||||
[ "login" login-template <html-content> ] >>display
|
||||
<page-action>
|
||||
"$login/login" >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -102,7 +97,7 @@ M: user-saver dispose
|
|||
|
||||
: <register-action> ( -- action )
|
||||
<page-action>
|
||||
"register" login-template >>template
|
||||
"$login/register" >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -134,7 +129,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 +138,7 @@ M: user-saver dispose
|
|||
tri
|
||||
] >>init
|
||||
|
||||
[ "edit-profile" login-template <html-content> ] >>display
|
||||
"$login/edit-profile" >>template
|
||||
|
||||
[
|
||||
uid "username" set-value
|
||||
|
|
@ -186,10 +181,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 +218,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 +235,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 +251,7 @@ SYMBOL: lost-password-from
|
|||
} validate-params
|
||||
] >>init
|
||||
|
||||
[ "recover-3" login-template <html-content> ] >>display
|
||||
"$login/recover-3" >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -272,12 +271,16 @@ SYMBOL: lost-password-from
|
|||
"new-password" value >>encoded-password
|
||||
users update-user
|
||||
|
||||
"recover-4" login-template <html-content>
|
||||
URL" $login/recover-4" <redirect>
|
||||
] [
|
||||
<400>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-4> ( -- action )
|
||||
<page-action>
|
||||
"$login/recover-4" >>template ;
|
||||
|
||||
! ! ! Logout
|
||||
: <logout-action> ( -- action )
|
||||
<action>
|
||||
|
|
@ -294,7 +297,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 +320,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 +343,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? ;
|
||||
|
|
@ -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,8 @@
|
|||
! 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
|
||||
html.templates.chloe locals ;
|
||||
IN: furnace.boilerplate
|
||||
|
||||
TUPLE: boilerplate < filter-responder template ;
|
||||
|
||||
|
|
@ -12,6 +12,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 ;
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
IN: http.server.callbacks
|
||||
USING: http.server.actions http.server.callbacks accessors
|
||||
IN: furnace.callbacks
|
||||
USING: furnace.actions furnace.callbacks accessors
|
||||
http.server http tools.test namespaces io fry sequences
|
||||
splitting kernel hashtables continuations ;
|
||||
|
||||
|
|
@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
|
|||
<action> [
|
||||
[
|
||||
"hello" print
|
||||
'[ , write ] <html-content>
|
||||
"text/html" <content>
|
||||
] show-page
|
||||
"byebye" print
|
||||
[ 123 ] show-final
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
USING: http http.server io kernel math namespaces
|
||||
continuations calendar sequences assocs hashtables
|
||||
accessors arrays alarms quotations combinators fry assocs.lib ;
|
||||
IN: http.server.callbacks
|
||||
IN: furnace.callbacks
|
||||
|
||||
SYMBOL: responder
|
||||
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.db.tests
|
||||
USING: tools.test furnace.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
USING: db db.pools io.pools http.server furnace.sessions
|
||||
kernel accessors continuations namespaces destructors ;
|
||||
IN: http.server.db
|
||||
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
|
||||
html.elements http http.server furnace.sessions
|
||||
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,136 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: furnace
|
||||
|
||||
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 ;
|
||||
|
||||
: <feed-content> ( body -- response )
|
||||
feed>xml "application/atom+xml" <content> ;
|
||||
|
||||
: <json-content> ( obj -- response )
|
||||
>json "application/json" <content> ;
|
||||
|
||||
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
|
||||
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 =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 ;
|
||||
|
||||
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 ;
|
||||
|
||||
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 -- ? )
|
||||
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 ;
|
||||
|
||||
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
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 math namespaces kernel accessors
|
||||
prettyprint io.streams.string io.files splitting destructors
|
||||
sequences db db.sqlite continuations ;
|
||||
sequences db db.sqlite continuations urls ;
|
||||
|
||||
: with-session
|
||||
[
|
||||
|
|
@ -18,15 +18,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 +37,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 +113,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 +132,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,8 @@ 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 html.elements html.templates.chloe ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session id expires uid namespace changed? ;
|
||||
|
||||
|
|
@ -136,7 +136,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,10 +145,17 @@ 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 ;
|
||||
|
||||
: logout-all-sessions ( uid -- )
|
||||
session new swap >>uid delete-tuples ;
|
||||
|
||||
M: sessions link-attr
|
||||
drop
|
||||
"session" optional-attr {
|
||||
{ "none" [ session off flow-id off ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
|
@ -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
|
||||
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -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" ] [
|
||||
[
|
||||
|
|
@ -156,6 +155,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
|
||||
"test10" test-template call-template
|
||||
] run-template [ blank? not ] filter
|
||||
] unit-test
|
||||
|
||||
[ ] [ 1 "id" set-value ] unit-test
|
||||
|
||||
[ "<a name=\"1\">Hello</a>" ] [
|
||||
[
|
||||
"test11" test-template call-template
|
||||
] run-template
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,16 +3,12 @@
|
|||
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
|
||||
|
|
@ -23,8 +19,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 +32,22 @@ 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
|
||||
[ <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 +57,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,83 +70,36 @@ 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: 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 tags get at
|
||||
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
|
||||
|
||||
: process-tag ( tag -- )
|
||||
{
|
||||
|
|
@ -310,7 +110,15 @@ STRING: button-tag-markup
|
|||
[ drop tags 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 ] }
|
||||
|
|
@ -334,6 +142,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,58 @@
|
|||
! 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 -- ) tags get set-at ;
|
||||
|
||||
: CHLOE:
|
||||
scan parse-definition swap 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 dup '[ , singleton-component-tag ] 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 dup '[ , tuple-component-tag ] define-chloe-tag ;
|
||||
parsing
|
||||
|
|
@ -3,12 +3,12 @@
|
|||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<table>
|
||||
<t:each-tuple t:values="people">
|
||||
<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:each-tuple>
|
||||
</t:bind-each>
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -1,14 +1,3 @@
|
|||
<?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>
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<ul>
|
||||
<t:each t:values="numbers">
|
||||
<t:each t:name="numbers">
|
||||
<li><t:label t:name="value"/></li>
|
||||
</t:each>
|
||||
</ul>
|
||||
|
|
|
|||
|
|
@ -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,11 +10,8 @@ tuple-syntax namespaces ;
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: http
|
||||
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" query: H{ } }
|
||||
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" } }
|
||||
|
|
@ -28,11 +25,8 @@ tuple-syntax namespaces ;
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: https
|
||||
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" query: H{ } }
|
||||
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" } }
|
||||
|
|
|
|||
|
|
@ -27,8 +27,7 @@ SYMBOL: redirects
|
|||
redirects inc
|
||||
redirects get max-redirects < [
|
||||
request get
|
||||
swap "location" header dup absolute-url?
|
||||
[ request-with-url ] [ request-with-path ] if
|
||||
swap "location" header request-with-url
|
||||
"GET" >>method http-request
|
||||
] [
|
||||
too-many-redirects
|
||||
|
|
@ -51,7 +50,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
|
||||
|
|
|
|||
|
|
@ -1,37 +1,13 @@
|
|||
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 +21,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 +58,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 +70,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 +123,14 @@ 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 ;
|
||||
|
||||
: 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 +149,7 @@ test-db [
|
|||
"resource:extra/http/test" <static> >>default
|
||||
"nested" add-responder
|
||||
<action>
|
||||
[ "redirect-loop" f <standard-redirect> ] >>display
|
||||
[ URL" redirect-loop" <redirect> ] >>display
|
||||
"redirect-loop" add-responder
|
||||
main-responder set
|
||||
|
||||
|
|
@ -186,16 +164,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 +205,7 @@ test-db [
|
|||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action> [ [ "Hi" write ] <text-content> ] >>display
|
||||
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
|
||||
<login>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
|
|
|
|||
|
|
@ -7,88 +7,31 @@ 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.sockets io.sockets.secure io.server
|
||||
|
||||
unicode.case unicode.categories qualified
|
||||
|
||||
html.templates ;
|
||||
urls html.templates ;
|
||||
|
||||
EXCLUDE: fry => , ;
|
||||
|
||||
IN: http
|
||||
|
||||
SINGLETON: http
|
||||
: secure-protocol? ( protocol -- ? )
|
||||
"https" = ;
|
||||
|
||||
SINGLETON: https
|
||||
: url-addr ( url -- addr )
|
||||
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
|
||||
secure-protocol? [ <secure> ] when ;
|
||||
|
||||
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 )
|
||||
: protocol-port ( protocol -- port )
|
||||
{
|
||||
{ "http" [ http ] }
|
||||
{ "https" [ https ] }
|
||||
[ "Unknown protocol: " swap append throw ]
|
||||
{ "http" [ 80 ] }
|
||||
{ "https" [ 443 ] }
|
||||
} 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 ;
|
||||
: ensure-port ( url -- url' )
|
||||
dup protocol>> '[ , protocol-port or ] change-port ;
|
||||
|
||||
: crlf "\r\n" write ;
|
||||
|
||||
|
|
@ -130,6 +73,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 +89,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 +144,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,19 +158,15 @@ 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
|
||||
|
|
@ -284,21 +184,17 @@ cookies ;
|
|||
" " 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 +221,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 +243,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 +253,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 +262,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 +274,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,38 +299,8 @@ 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 ;
|
||||
'[ , >url derive-url ensure-port ] change-url ;
|
||||
|
||||
GENERIC: write-response ( response -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
IN: http.server.db.tests
|
||||
USING: tools.test http.server.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
||||
|
|
@ -1,27 +1,52 @@
|
|||
USING: http.server tools.test kernel namespaces accessors
|
||||
io http math sequences assocs arrays classes words ;
|
||||
io http math sequences assocs arrays classes words urls ;
|
||||
IN: http.server.tests
|
||||
|
||||
\ find-responder must-infer
|
||||
|
||||
[
|
||||
<request>
|
||||
http >>protocol
|
||||
"www.apple.com" >>host
|
||||
"/xxx/bar" >>path
|
||||
{ { "a" "b" } } >>query
|
||||
<url>
|
||||
"http" >>protocol
|
||||
"www.apple.com" >>host
|
||||
"/xxx/bar" >>path
|
||||
{ { "a" "b" } } >>query
|
||||
>>url
|
||||
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
|
||||
[ "http://www.apple.com:80/xxx/bar" ] [
|
||||
<url> adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz" ] [
|
||||
<url> "baz" >>path adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
|
||||
<url> "baz" >>path { { "c" "d" } } >>query adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
|
||||
<url> { { "c" "d" } } >>query adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip" ] [
|
||||
<url> "/flip" >>path adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip?c=d" ] [
|
||||
<url> "/flip" >>path { { "c" "d" } } >>query adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/" ] [
|
||||
"http://www.jedit.org" >url adjust-url url>string
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/?a=b" ] [
|
||||
"http://www.jedit.org" >url { { "a" "b" } } >>query adjust-url url>string
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
||||
TUPLE: mock-responder path ;
|
||||
|
|
@ -31,7 +56,7 @@ 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
|
||||
|
|
@ -84,7 +109,7 @@ 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
|
||||
|
|
@ -125,7 +150,7 @@ C: <base-path-check-responder> base-path-check-responder
|
|||
M: base-path-check-responder call-responder*
|
||||
2drop
|
||||
"$funny-dispatcher" resolve-base-path
|
||||
<text-content> ;
|
||||
"text/plain" <content> ;
|
||||
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
|
|
|
|||
|
|
@ -2,23 +2,16 @@
|
|||
! 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 ;
|
||||
html.streams html.components html.elements html.templates
|
||||
accessors math.parser combinators.lib tools.vocabs debugger
|
||||
continuations random combinators destructors io.streams.string
|
||||
io.encodings.8-bit fry classes words math urls
|
||||
arrays vocabs.loader ;
|
||||
IN: http.server
|
||||
|
||||
! 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
|
||||
|
|
@ -26,21 +19,6 @@ GENERIC: call-responder* ( path responder -- response )
|
|||
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
|
||||
|
|
@ -55,7 +33,8 @@ M: trivial-responder call-responder* nip response>> call ;
|
|||
</html> ;
|
||||
|
||||
: <trivial-response> ( code message -- response )
|
||||
2dup '[ , , trivial-response-body ] <html-content>
|
||||
2dup [ trivial-response-body ] with-string-writer
|
||||
"text/html" <content>
|
||||
swap >>message
|
||||
swap >>code ;
|
||||
|
||||
|
|
@ -69,7 +48,7 @@ SYMBOL: 404-responder
|
|||
|
||||
[ <404> ] <trivial-responder> 404-responder set-global
|
||||
|
||||
SYMBOL: base-paths
|
||||
SYMBOL: responder-nesting
|
||||
|
||||
: invert-slice ( slice -- slice' )
|
||||
dup slice? [
|
||||
|
|
@ -78,86 +57,81 @@ SYMBOL: base-paths
|
|||
drop { }
|
||||
] if ;
|
||||
|
||||
: add-base-path ( path dispatcher -- )
|
||||
[ invert-slice ] [ class word-name ] bi*
|
||||
base-paths get set-at ;
|
||||
: vocab-path ( vocab -- path )
|
||||
dup vocab-dir vocab-append-path ;
|
||||
|
||||
: vocab-path-of ( dispatcher -- path )
|
||||
class word-vocabulary vocab-path ;
|
||||
|
||||
: add-responder-path ( path dispatcher -- )
|
||||
[ [ invert-slice ] [ [ vocab-path-of ] keep ] bi* 3array ]
|
||||
[ nip class word-name ] 2bi
|
||||
responder-nesting get set-at ;
|
||||
|
||||
: call-responder ( path responder -- response )
|
||||
[ add-base-path ] [ call-responder* ] 2bi ;
|
||||
[ add-responder-path ] [ call-responder* ] 2bi ;
|
||||
|
||||
SYMBOL: link-hook
|
||||
: nested-responders ( -- seq )
|
||||
responder-nesting get assocs:values [ third ] map ;
|
||||
|
||||
: add-link-hook ( quot -- )
|
||||
link-hook [ compose ] change ; inline
|
||||
: each-responder ( quot -- )
|
||||
nested-responders swap each ; inline
|
||||
|
||||
: modify-query ( query -- query )
|
||||
link-hook get call ;
|
||||
|
||||
: base-path ( string -- path )
|
||||
dup base-paths get at
|
||||
: responder-path ( string -- pair )
|
||||
dup responder-nesting get at
|
||||
[ ] [ "No such responder: " swap append throw ] ?if ;
|
||||
|
||||
: resolve-base-path ( string -- string' )
|
||||
"$" ?head [
|
||||
: base-path ( string -- path )
|
||||
responder-path first ;
|
||||
|
||||
: template-path ( string -- path )
|
||||
responder-path second ;
|
||||
|
||||
: resolve-responder-path ( string quot -- string' )
|
||||
[ "$" ?head ] dip '[
|
||||
[
|
||||
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
|
||||
"/" split1 [ @ [ "/" % % ] each "/" % ] dip %
|
||||
] "" make
|
||||
] when ;
|
||||
] when ; inline
|
||||
|
||||
: link>string ( url query -- url' )
|
||||
[ resolve-base-path ] [ modify-query ] bi* (link>string) ;
|
||||
: resolve-base-path ( string -- string' )
|
||||
[ base-path ] resolve-responder-path ;
|
||||
|
||||
: write-link ( url query -- )
|
||||
link>string write ;
|
||||
: resolve-template-path ( string -- string' )
|
||||
[ template-path ] resolve-responder-path ;
|
||||
|
||||
SYMBOL: form-hook
|
||||
GENERIC: modify-query ( query responder -- query' )
|
||||
|
||||
: add-form-hook ( quot -- )
|
||||
form-hook [ compose ] change ;
|
||||
M: object modify-query drop ;
|
||||
|
||||
: hidden-form-field ( -- )
|
||||
form-hook get call ;
|
||||
: adjust-url ( url -- url' )
|
||||
clone
|
||||
[ dup [ modify-query ] each-responder ] change-query
|
||||
[ resolve-base-path ] change-path
|
||||
request get url>>
|
||||
clone
|
||||
f >>query
|
||||
swap derive-url ensure-port ;
|
||||
|
||||
: absolute-redirect ( to query -- url )
|
||||
#! Same host.
|
||||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap url-encode >>path
|
||||
[ modify-query ] change-query
|
||||
request-url ;
|
||||
: <custom-redirect> ( url code message -- response )
|
||||
<trivial-response>
|
||||
swap dup url? [ adjust-url ] when
|
||||
"location" set-header ;
|
||||
|
||||
: 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
|
||||
\ <custom-redirect> DEBUG add-input-logging
|
||||
|
||||
: <permanent-redirect> ( to query -- response )
|
||||
301 "Moved Permanently" <redirect> ;
|
||||
301 "Moved Permanently" <custom-redirect> ;
|
||||
|
||||
: <temporary-redirect> ( to query -- response )
|
||||
307 "Temporary Redirect" <redirect> ;
|
||||
307 "Temporary Redirect" <custom-redirect> ;
|
||||
|
||||
: <standard-redirect> ( to query -- response )
|
||||
request get method>> "POST" =
|
||||
[ <permanent-redirect> ] [ <temporary-redirect> ] if ;
|
||||
: <redirect> ( to query -- response )
|
||||
request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
{ "HEAD" [ <temporary-redirect> ] }
|
||||
{ "POST" [ <permanent-redirect> ] }
|
||||
} case ;
|
||||
|
||||
TUPLE: dispatcher default responders ;
|
||||
|
||||
|
|
@ -187,7 +161,7 @@ TUPLE: vhost-dispatcher default responders ;
|
|||
404-responder get H{ } clone vhost-dispatcher boa ;
|
||||
|
||||
: find-vhost ( dispatcher -- responder )
|
||||
request get host>> over responders>> at*
|
||||
request get url>> host>> over responders>> at*
|
||||
[ nip ] [ drop default>> ] if ;
|
||||
|
||||
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
|
||||
|
|
@ -242,35 +216,28 @@ SYMBOL: development-mode
|
|||
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
|
||||
: init-request ( request -- )
|
||||
request set
|
||||
H{ } clone responder-nesting set
|
||||
[ ] link-hook set
|
||||
[ ] form-hook 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
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ 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 ;
|
||||
io.encodings.binary fry xml.entities destructors urls ;
|
||||
IN: http.server.static
|
||||
|
||||
! special maps mime types to quots with effect ( path -- )
|
||||
|
|
@ -71,7 +71,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 +85,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 <redirect>
|
||||
] if ;
|
||||
|
||||
: serve-object ( filename -- response )
|
||||
|
|
@ -101,6 +101,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> ;
|
||||
|
|
|
|||
|
|
@ -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,6 @@
|
|||
! 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 furnace.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
|
||||
IN: tangle
|
||||
|
||||
GENERIC: render* ( content templater -- output )
|
||||
|
|
@ -20,7 +20,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 +36,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 +52,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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -77,10 +77,17 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ;
|
|||
}
|
||||
"a/relative/path"
|
||||
}
|
||||
{
|
||||
TUPLE{ url
|
||||
path: "bar"
|
||||
query: H{ { "a" "b" } }
|
||||
}
|
||||
"bar?a=b"
|
||||
}
|
||||
} ;
|
||||
|
||||
urls [
|
||||
[ 1array ] [ [ string>url ] curry ] bi* unit-test
|
||||
[ 1array ] [ [ >url ] curry ] bi* unit-test
|
||||
] assoc-each
|
||||
|
||||
urls [
|
||||
|
|
@ -192,3 +199,7 @@ urls [
|
|||
|
||||
derive-url
|
||||
] unit-test
|
||||
|
||||
[ "a" ] [
|
||||
<url> "a" "b" set-query-param "b" query-param
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! 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.encodings.string
|
||||
io.encodings.utf8 math math.parser accessors mirrors parser
|
||||
prettyprint.backend hashtables ;
|
||||
IN: urls
|
||||
|
||||
: url-quotable? ( ch -- ? )
|
||||
|
|
@ -91,11 +91,13 @@ IN: urls
|
|||
|
||||
TUPLE: url protocol host port path query anchor ;
|
||||
|
||||
: <url> ( -- url ) url new ;
|
||||
|
||||
: query-param ( request key -- value )
|
||||
swap query>> at ;
|
||||
|
||||
: set-query-param ( request value key -- request )
|
||||
pick query>> set-at ;
|
||||
'[ , , _ ?set-at ] change-query ;
|
||||
|
||||
: parse-host ( string -- host port )
|
||||
":" split1 [ url-decode ] [
|
||||
|
|
@ -105,40 +107,44 @@ 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 [
|
||||
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-host-part ( url protocol -- )
|
||||
%
|
||||
"://" %
|
||||
"host" get url-encode %
|
||||
"port" get [ ":" % # ] when*
|
||||
"path" get "/" head? [ "Invalid URL" throw ] unless ;
|
||||
[ host>> url-encode % ]
|
||||
[ port>> [ ":" % # ] when* ]
|
||||
[ path>> "/" head? [ "/" % ] unless ]
|
||||
tri ;
|
||||
|
||||
: 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 +164,7 @@ TUPLE: url protocol host port path query anchor ;
|
|||
|
||||
: relative-url ( url -- url' )
|
||||
clone f >>protocol f >>host f >>port ;
|
||||
|
||||
: URL" lexer get skip-blank parse-string >url parsed ; parsing
|
||||
|
||||
M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: math kernel accessors html.components
|
||||
http.server http.server.actions
|
||||
http.server.sessions html.templates.chloe fry ;
|
||||
USING: math kernel accessors html.components http.server
|
||||
furnace.actions furnace.sessions html.templates.chloe
|
||||
fry urls ;
|
||||
IN: webapps.counter
|
||||
|
||||
SYMBOL: count
|
||||
|
|
@ -11,15 +11,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,12 @@ 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
|
||||
furnace.db
|
||||
furnace.flows
|
||||
furnace.sessions
|
||||
furnace.auth.login
|
||||
furnace.auth.providers.db
|
||||
furnace.boilerplate
|
||||
webapps.pastebin
|
||||
webapps.planet
|
||||
webapps.todo
|
||||
|
|
@ -20,9 +19,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 +36,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 +51,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">
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@
|
|||
! 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
|
||||
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 ;
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
furnace.boilerplate ;
|
||||
IN: webapps.pastebin
|
||||
|
||||
! ! !
|
||||
|
|
@ -58,28 +58,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 +91,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 +99,7 @@ M: annotation entity-link
|
|||
swap
|
||||
[ summary>> >>title ]
|
||||
[ date>> >>pub-date ]
|
||||
[ entity-link >>link ]
|
||||
[ entity-link adjust-url >>link ]
|
||||
tri
|
||||
] map ;
|
||||
|
||||
|
|
@ -117,7 +120,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 +130,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 +138,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 >>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 +168,7 @@ M: annotation entity-link
|
|||
mode-names "modes" set-value
|
||||
] >>init
|
||||
|
||||
"new-paste" pastebin-template >>template
|
||||
"$pastebin/new-paste" >>template
|
||||
|
||||
[
|
||||
validate-entity
|
||||
|
|
@ -173,7 +176,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 +187,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 +195,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 +210,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,7 +221,7 @@ M: annotation entity-link
|
|||
[
|
||||
f "id" value <annotation> select-tuple
|
||||
[ delete-tuples ]
|
||||
[ parent>> "$pastebin/paste" <id-redirect> ]
|
||||
[ parent>> paste-link <redirect> ]
|
||||
bi
|
||||
] >>submit ;
|
||||
|
||||
|
|
@ -242,7 +242,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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
</p>
|
||||
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -3,19 +3,16 @@
|
|||
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 ;
|
||||
furnace.actions
|
||||
furnace.boilerplate
|
||||
furnace.auth.login
|
||||
furnace.auth ;
|
||||
IN: webapps.planet
|
||||
|
||||
: planet-template ( name -- template )
|
||||
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
TUPLE: blog id name www-url feed-url ;
|
||||
|
||||
M: blog link-title name>> ;
|
||||
|
|
@ -61,7 +58,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 +67,7 @@ posting "POSTINGS"
|
|||
postings "postings" set-value
|
||||
] >>init
|
||||
|
||||
"planet" planet-template >>template ;
|
||||
"$planet-factor/planet" >>template ;
|
||||
|
||||
: planet-feed ( -- feed )
|
||||
feed new
|
||||
|
|
@ -110,7 +107,7 @@ posting "POSTINGS"
|
|||
<action>
|
||||
[
|
||||
update-cached-postings
|
||||
"" f <permanent-redirect>
|
||||
URL" $planet-factor/admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <delete-blog-action> ( -- action )
|
||||
|
|
@ -119,7 +116,7 @@ posting "POSTINGS"
|
|||
|
||||
[
|
||||
"id" value <blog> delete-tuples
|
||||
"$planet-factor/admin" f <standard-redirect>
|
||||
URL" $planet-factor/admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: validate-blog ( -- )
|
||||
|
|
@ -129,15 +126,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 +139,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 +152,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,7 +166,12 @@ 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 ;
|
||||
|
||||
|
|
@ -193,7 +197,7 @@ TUPLE: planet-factor < dispatcher ;
|
|||
<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,7 +8,7 @@
|
|||
<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>
|
||||
|
|
@ -22,7 +22,7 @@
|
|||
<t:a t:value="link" t:session="none"><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,15 +1,15 @@
|
|||
! 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
|
||||
furnace.sessions
|
||||
furnace.boilerplate
|
||||
furnace.auth
|
||||
furnace.actions
|
||||
furnace.db
|
||||
furnace.auth.login
|
||||
http.server ;
|
||||
IN: webapps.todo
|
||||
|
||||
|
|
@ -31,20 +31,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 +51,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 +72,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 +86,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,13 +101,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 ;
|
||||
"$todo-list/todo-list" >>template ;
|
||||
|
||||
TUPLE: todo-list < dispatcher ;
|
||||
|
||||
|
|
@ -115,5 +119,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,7 +6,7 @@
|
|||
|
||||
<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:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -35,7 +35,11 @@
|
|||
|
||||
<tr>
|
||||
<th class="field-label big-field-label">Capabilities:</th>
|
||||
<td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
|
||||
<td>
|
||||
<t:each t:name="capabilities">
|
||||
<li><t:checkbox t:name="@value" t:label="@value" /><br/>
|
||||
</t:each>
|
||||
</td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
|
|||
|
|
@ -1,45 +1,55 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors namespaces combinators words
|
||||
assocs db.tuples arrays splitting strings validators
|
||||
assocs db.tuples arrays splitting strings validators urls
|
||||
html.elements
|
||||
html.components
|
||||
html.templates.chloe
|
||||
http.server.boilerplate
|
||||
http.server.auth.providers
|
||||
http.server.auth.providers.db
|
||||
http.server.auth.login
|
||||
http.server.auth
|
||||
http.server.sessions
|
||||
http.server.actions
|
||||
furnace.boilerplate
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db
|
||||
furnace.auth.login
|
||||
furnace.auth
|
||||
furnace.sessions
|
||||
furnace.actions
|
||||
http.server ;
|
||||
IN: webapps.user-admin
|
||||
|
||||
: admin-template ( name -- template )
|
||||
"resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
|
||||
: word>string ( word -- string )
|
||||
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
|
||||
[ word>string ] map ;
|
||||
|
||||
: string>word ( string -- word )
|
||||
":" split1 swap lookup ;
|
||||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ ":" split1 swap lookup ] map ;
|
||||
[ string>word ] map ;
|
||||
|
||||
: <user-list-action> ( -- action )
|
||||
<page-action>
|
||||
[ f <user> select-tuples "users" set-value ] >>init
|
||||
"user-list" admin-template >>template ;
|
||||
"$user-admin/user-list" >>template ;
|
||||
|
||||
: init-capabilities ( -- )
|
||||
capabilities get words>strings "capabilities" set-value ;
|
||||
|
||||
: selected-capabilities ( -- seq )
|
||||
"capabilities" value
|
||||
[ param empty? not ] filter
|
||||
[ string>word ] map ;
|
||||
|
||||
: <new-user-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
"username" param <user> from-tuple
|
||||
capabilities get words>strings "all-capabilities" set-value
|
||||
"username" param <user> from-object
|
||||
init-capabilities
|
||||
] >>init
|
||||
|
||||
"new-user" admin-template >>template
|
||||
"$user-admin/new-user" >>template
|
||||
|
||||
[
|
||||
capabilities get words>strings "all-capabilities" set-value
|
||||
init-capabilities
|
||||
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
|
|
@ -62,10 +72,11 @@ IN: webapps.user-admin
|
|||
"email" value >>email
|
||||
"new-password" value >>encoded-password
|
||||
H{ } clone >>profile
|
||||
selected-capabilities >>capabilities
|
||||
|
||||
insert-tuple
|
||||
|
||||
"$user-admin" f <standard-redirect>
|
||||
URL" $user-admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: validate-username ( -- )
|
||||
|
|
@ -77,15 +88,16 @@ IN: webapps.user-admin
|
|||
validate-username
|
||||
|
||||
"username" value <user> select-tuple
|
||||
[ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
|
||||
[ from-object ]
|
||||
[ capabilities>> [ "true" swap word>string set-value ] each ] bi
|
||||
|
||||
capabilities get words>strings "all-capabilities" set-value
|
||||
capabilities get words>strings "capabilities" set-value
|
||||
] >>init
|
||||
|
||||
"edit-user" admin-template >>template
|
||||
"$user-admin/edit-user" >>template
|
||||
|
||||
[
|
||||
capabilities get words>strings "all-capabilities" set-value
|
||||
init-capabilities
|
||||
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
|
|
@ -93,7 +105,6 @@ IN: webapps.user-admin
|
|||
{ "new-password" [ [ v-password ] v-optional ] }
|
||||
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
{ "capabilities" [ ] }
|
||||
} validate-params
|
||||
|
||||
"new-password" "verify-password"
|
||||
|
|
@ -106,19 +117,15 @@ IN: webapps.user-admin
|
|||
"username" value <user> select-tuple
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
selected-capabilities >>capabilities
|
||||
|
||||
"new-password" value empty? [
|
||||
"new-password" value >>encoded-password
|
||||
] unless
|
||||
|
||||
"capabilities" value {
|
||||
{ [ dup string? ] [ 1array ] }
|
||||
{ [ dup array? ] [ ] }
|
||||
} cond strings>words >>capabilities
|
||||
|
||||
update-tuple
|
||||
|
||||
"$user-admin" f <standard-redirect>
|
||||
URL" $user-admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <delete-user-action> ( -- action )
|
||||
|
|
@ -130,7 +137,7 @@ IN: webapps.user-admin
|
|||
[ logout-all-sessions ]
|
||||
bi
|
||||
|
||||
"$user-admin" f <standard-redirect>
|
||||
URL" $user-admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: user-admin < dispatcher ;
|
||||
|
|
@ -146,7 +153,7 @@ can-administer-users? define-capability
|
|||
<edit-user-action> "edit" add-responder
|
||||
<delete-user-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"user-admin" admin-template >>template
|
||||
"$user-admin/user-admin" >>template
|
||||
{ can-administer-users? } <protected> ;
|
||||
|
||||
: make-admin ( username -- )
|
||||
|
|
|
|||
|
|
@ -6,13 +6,13 @@
|
|||
|
||||
<ul>
|
||||
|
||||
<t:each-tuple t:values="users">
|
||||
<t:bind-each t:name="users">
|
||||
<li>
|
||||
<t:a t:href="$user-admin/edit" t:query="username">
|
||||
<t:label t:name="username" />
|
||||
</t:a>
|
||||
</li>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
|
||||
</ul>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@
|
|||
<t:title>All Articles</t:title>
|
||||
|
||||
<ul>
|
||||
<t:each-tuple t:values="articles">
|
||||
<t:bind-each t:name="articles">
|
||||
<li>
|
||||
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
|
||||
</li>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
<t:title>Recent Changes</t:title>
|
||||
|
||||
<ul>
|
||||
<t:each-tuple t:values="changes">
|
||||
<t:bind-each t:name="changes">
|
||||
<li>
|
||||
<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
|
||||
on
|
||||
|
|
@ -13,7 +13,7 @@
|
|||
by
|
||||
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
|
||||
</li>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -2,34 +2,34 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:bind-tuple t:name="old">
|
||||
<t:bind t:name="old">
|
||||
<t:title>Diff: <t:label t:name="title" /></t:title>
|
||||
</t:bind-tuple>
|
||||
</t:bind>
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th class="field-label">Old revision:</th>
|
||||
<t:bind-tuple t:name="old">
|
||||
<t:bind t:name="old">
|
||||
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
|
||||
</t:bind-tuple>
|
||||
</t:bind>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">New revision:</th>
|
||||
<t:bind-tuple t:name="old">
|
||||
<t:bind t:name="old">
|
||||
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
|
||||
</t:bind-tuple>
|
||||
</t:bind>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<t:comparison t:name="diff" />
|
||||
|
||||
<t:bind-tuple t:name="old">
|
||||
<t:bind t:name="old">
|
||||
<div class="navbar">
|
||||
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
|
||||
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
|
||||
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
|
||||
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
|
||||
</div>
|
||||
</t:bind-tuple>
|
||||
</t:bind>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,15 +4,23 @@
|
|||
|
||||
<t:title>Revisions of <t:label t:name="title" /></t:title>
|
||||
|
||||
<ul>
|
||||
<t:each-tuple t:values="revisions">
|
||||
<li>
|
||||
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
|
||||
by
|
||||
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
|
||||
</li>
|
||||
</t:each-tuple>
|
||||
</ul>
|
||||
<div class="revisions">
|
||||
<table>
|
||||
<tr>
|
||||
<th>Revision</th>
|
||||
<th>Author</th>
|
||||
<th>Rollback</th>
|
||||
</tr>
|
||||
|
||||
<t:bind-each t:name="revisions">
|
||||
<tr>
|
||||
<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
|
||||
<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
|
||||
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
|
||||
</tr>
|
||||
</t:bind-each>
|
||||
</table>
|
||||
</div>
|
||||
|
||||
<h2>View Differences</h2>
|
||||
|
||||
|
|
@ -23,9 +31,9 @@
|
|||
|
||||
<td>
|
||||
<select name="old-id">
|
||||
<t:each-tuple t:values="revisions">
|
||||
<t:bind-each t:name="revisions">
|
||||
<option> <t:label t:name="id" /> </option>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
</select>
|
||||
</td>
|
||||
</tr>
|
||||
|
|
@ -34,9 +42,9 @@
|
|||
|
||||
<td>
|
||||
<select name="new-id">
|
||||
<t:each-tuple t:values="revisions">
|
||||
<t:bind-each t:name="revisions">
|
||||
<option> <t:label t:name="id" /> </option>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
</select>
|
||||
</td>
|
||||
</tr>
|
||||
|
|
@ -45,4 +53,13 @@
|
|||
<input type="submit" value="View" />
|
||||
</form>
|
||||
|
||||
<br/>
|
||||
|
||||
<div class="navbar">
|
||||
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
|
||||
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
|
||||
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
|
||||
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
|
||||
</div>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -5,13 +5,13 @@
|
|||
<t:title>Edits by <t:label t:name="author" /></t:title>
|
||||
|
||||
<ul>
|
||||
<t:each-tuple t:values="user-edits">
|
||||
<t:bind-each t:name="user-edits">
|
||||
<li>
|
||||
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
|
||||
on
|
||||
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
|
||||
</li>
|
||||
</t:each-tuple>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -1,8 +1,3 @@
|
|||
.comparison table, {
|
||||
border-color: #666;
|
||||
border-style: solid;
|
||||
}
|
||||
|
||||
.comparison th {
|
||||
border-width: 1px;
|
||||
border-color: #666;
|
||||
|
|
@ -10,12 +5,13 @@
|
|||
}
|
||||
|
||||
.comparison table {
|
||||
border-color: #666;
|
||||
border-style: solid;
|
||||
border-width: 1px;
|
||||
border-spacing: 0;
|
||||
border-collapse: collapse;
|
||||
}
|
||||
|
||||
|
||||
.insert {
|
||||
background-color: #9f9;
|
||||
}
|
||||
|
|
@ -23,3 +19,21 @@
|
|||
.delete {
|
||||
background-color: #f99;
|
||||
}
|
||||
|
||||
.revisions table, .revisions td, .revisions th {
|
||||
border-color: #666;
|
||||
border-style: solid;
|
||||
}
|
||||
|
||||
.revisions table {
|
||||
border-width: 0 0 1px 1px;
|
||||
border-spacing: 0;
|
||||
border-collapse: collapse;
|
||||
}
|
||||
|
||||
.revisions td, .revisions th {
|
||||
margin: 0;
|
||||
padding: 4px;
|
||||
border-width: 1px 1px 0 0;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,14 +3,13 @@
|
|||
USING: accessors kernel hashtables calendar
|
||||
namespaces splitting sequences sorting math.order
|
||||
html.components
|
||||
html.templates.chloe
|
||||
http.server
|
||||
http.server.actions
|
||||
http.server.auth
|
||||
http.server.auth.login
|
||||
http.server.boilerplate
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
furnace.boilerplate
|
||||
validators
|
||||
db.types db.tuples lcs farkup ;
|
||||
db.types db.tuples lcs farkup urls ;
|
||||
IN: webapps.wiki
|
||||
|
||||
TUPLE: article title revision ;
|
||||
|
|
@ -41,18 +40,17 @@ revision "REVISIONS" {
|
|||
|
||||
: init-revisions-table revision ensure-table ;
|
||||
|
||||
: wiki-template ( name -- template )
|
||||
"resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
: <title-redirect> ( title next -- response )
|
||||
swap "title" associate <standard-redirect> ;
|
||||
|
||||
: validate-title ( -- )
|
||||
{ { "title" [ v-one-line ] } } validate-params ;
|
||||
|
||||
: <main-article-action> ( -- action )
|
||||
<action>
|
||||
[ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
|
||||
[
|
||||
<url>
|
||||
"$wiki/view" >>path
|
||||
"Front Page" "title" set-query-param
|
||||
<redirect>
|
||||
] >>display ;
|
||||
|
||||
: <view-article-action> ( -- action )
|
||||
<action>
|
||||
|
|
@ -65,10 +63,13 @@ revision "REVISIONS" {
|
|||
|
||||
[
|
||||
"title" value dup <article> select-tuple [
|
||||
revision>> <revision> select-tuple from-tuple
|
||||
"view" wiki-template <html-content>
|
||||
revision>> <revision> select-tuple from-object
|
||||
"$wiki/view" <chloe-content>
|
||||
] [
|
||||
"$wiki/edit" <title-redirect>
|
||||
<url>
|
||||
"$wiki/edit" >>path
|
||||
swap "title" set-query-param
|
||||
<redirect>
|
||||
] ?if
|
||||
] >>display ;
|
||||
|
||||
|
|
@ -77,10 +78,10 @@ revision "REVISIONS" {
|
|||
[
|
||||
{ { "id" [ v-integer ] } } validate-params
|
||||
"id" value <revision>
|
||||
select-tuple from-tuple
|
||||
select-tuple from-object
|
||||
] >>init
|
||||
|
||||
"view" wiki-template >>template ;
|
||||
"$wiki/view" >>template ;
|
||||
|
||||
: add-revision ( revision -- )
|
||||
[ insert-tuple ]
|
||||
|
|
@ -97,11 +98,11 @@ revision "REVISIONS" {
|
|||
[
|
||||
validate-title
|
||||
"title" value <article> select-tuple [
|
||||
revision>> <revision> select-tuple from-tuple
|
||||
revision>> <revision> select-tuple from-object
|
||||
] when*
|
||||
] >>init
|
||||
|
||||
"edit" wiki-template >>template
|
||||
"$wiki/edit" >>template
|
||||
|
||||
[
|
||||
validate-title
|
||||
|
|
@ -113,7 +114,12 @@ revision "REVISIONS" {
|
|||
logged-in-user get username>> >>author
|
||||
"content" value >>content
|
||||
[ add-revision ]
|
||||
[ title>> "$wiki/view" <title-redirect> ] bi
|
||||
[
|
||||
<url>
|
||||
"$wiki/view" >>path
|
||||
swap title>> "title" set-query-param
|
||||
<redirect>
|
||||
] bi
|
||||
] >>submit ;
|
||||
|
||||
: <list-revisions-action> ( -- action )
|
||||
|
|
@ -125,7 +131,24 @@ revision "REVISIONS" {
|
|||
"revisions" set-value
|
||||
] >>init
|
||||
|
||||
"revisions" wiki-template >>template ;
|
||||
"$wiki/revisions" >>template ;
|
||||
|
||||
: <rollback-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
{ { "id" [ v-integer ] } } validate-params
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"id" value <revision> select-tuple clone f >>id
|
||||
[ add-revision ]
|
||||
[
|
||||
<url>
|
||||
"$wiki/view" >>path
|
||||
swap title>> "title" set-query-param
|
||||
<redirect>
|
||||
] bi
|
||||
] >>submit ;
|
||||
|
||||
: <list-changes-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -135,7 +158,7 @@ revision "REVISIONS" {
|
|||
"changes" set-value
|
||||
] >>init
|
||||
|
||||
"changes" wiki-template >>template ;
|
||||
"$wiki/changes" >>template ;
|
||||
|
||||
: <delete-action> ( -- action )
|
||||
<action>
|
||||
|
|
@ -144,7 +167,7 @@ revision "REVISIONS" {
|
|||
[
|
||||
"title" value <article> delete-tuples
|
||||
f <revision> "title" value >>title delete-tuples
|
||||
"" f <standard-redirect>
|
||||
URL" $wiki" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <diff-action> ( -- action )
|
||||
|
|
@ -162,7 +185,7 @@ revision "REVISIONS" {
|
|||
2bi
|
||||
] >>init
|
||||
|
||||
"diff" wiki-template >>template ;
|
||||
"$wiki/diff" >>template ;
|
||||
|
||||
: <list-articles-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -172,7 +195,7 @@ revision "REVISIONS" {
|
|||
"articles" set-value
|
||||
] >>init
|
||||
|
||||
"articles" wiki-template >>template ;
|
||||
"$wiki/articles" >>template ;
|
||||
|
||||
: <user-edits-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -182,7 +205,7 @@ revision "REVISIONS" {
|
|||
select-tuples "user-edits" set-value
|
||||
] >>init
|
||||
|
||||
"user-edits" wiki-template >>template ;
|
||||
"$wiki/user-edits" >>template ;
|
||||
|
||||
TUPLE: wiki < dispatcher ;
|
||||
|
||||
|
|
@ -192,6 +215,7 @@ TUPLE: wiki < dispatcher ;
|
|||
<view-article-action> "view" add-responder
|
||||
<view-revision-action> "revision" add-responder
|
||||
<list-revisions-action> "revisions" add-responder
|
||||
<rollback-action> "rollback" add-responder
|
||||
<user-edits-action> "user-edits" add-responder
|
||||
<diff-action> "diff" add-responder
|
||||
<list-articles-action> "articles" add-responder
|
||||
|
|
@ -199,4 +223,4 @@ TUPLE: wiki < dispatcher ;
|
|||
<edit-article-action> { } <protected> "edit" add-responder
|
||||
<delete-action> { } <protected> "delete" add-responder
|
||||
<boilerplate>
|
||||
"wiki-common" wiki-template >>template ;
|
||||
"$wiki/wiki-common" >>template ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
USING: xmode.tokens xmode.marker xmode.catalog kernel
|
||||
html.elements io io.files sequences words io.encodings.utf8
|
||||
namespaces xml.entities ;
|
||||
namespaces xml.entities accessors ;
|
||||
IN: xmode.code2html
|
||||
|
||||
: htmlize-tokens ( tokens -- )
|
||||
[
|
||||
dup token-str swap token-id [
|
||||
[ str>> ] [ id>> ] bi [
|
||||
<span word-name =class span> escape-string write </span>
|
||||
] [
|
||||
write
|
||||
escape-string write
|
||||
] if*
|
||||
] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,5 +12,5 @@ IN: xmode.code2html.responder
|
|||
, utf8 [
|
||||
, file-name input-stream get htmlize-stream
|
||||
] with-file-reader
|
||||
] <html-content>
|
||||
] "text/html" <content>
|
||||
] <file-responder> ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue