Web framework refactoring work in progress

db4
Slava Pestov 2008-06-01 17:22:39 -05:00
parent 7eca88cdb5
commit c5c65a4ce4
84 changed files with 1027 additions and 1079 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -15,19 +15,18 @@ checksums.sha2
validators validators
html.components html.components
html.elements html.elements
html.templates urls
html.templates.chloe
http http
http.server http.server
http.server.auth furnace.auth
http.server.auth.providers furnace.auth.providers
http.server.auth.providers.db furnace.auth.providers.db
http.server.actions furnace.actions
http.server.flows furnace.flows
http.server.sessions furnace.sessions
http.server.boilerplate ; furnace.boilerplate ;
QUALIFIED: smtp QUALIFIED: smtp
IN: http.server.auth.login IN: furnace.auth.login
TUPLE: login < dispatcher users checksum ; TUPLE: login < dispatcher users checksum ;
@ -59,10 +58,6 @@ M: user-saver dispose
: save-user-after ( user -- ) : save-user-after ( user -- )
<user-saver> &dispose drop ; <user-saver> &dispose drop ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"
3append <chloe> ;
! ! ! Login ! ! ! Login
: successful-login ( user -- response ) : successful-login ( user -- response )
username>> set-uid "$login" end-flow ; username>> set-uid "$login" end-flow ;
@ -72,8 +67,8 @@ M: user-saver dispose
validation-failed ; validation-failed ;
: <login-action> ( -- action ) : <login-action> ( -- action )
<action> <page-action>
[ "login" login-template <html-content> ] >>display "$login/login" >>template
[ [
{ {
@ -102,7 +97,7 @@ M: user-saver dispose
: <register-action> ( -- action ) : <register-action> ( -- action )
<page-action> <page-action>
"register" login-template >>template "$login/register" >>template
[ [
{ {
@ -134,7 +129,7 @@ M: user-saver dispose
! ! ! Editing user profile ! ! ! Editing user profile
: <edit-profile-action> ( -- action ) : <edit-profile-action> ( -- action )
<action> <page-action>
[ [
logged-in-user get logged-in-user get
[ username>> "username" set-value ] [ username>> "username" set-value ]
@ -143,7 +138,7 @@ M: user-saver dispose
tri tri
] >>init ] >>init
[ "edit-profile" login-template <html-content> ] >>display "$login/edit-profile" >>template
[ [
uid "username" set-value uid "username" set-value
@ -186,10 +181,10 @@ M: user-saver dispose
SYMBOL: lost-password-from SYMBOL: lost-password-from
: current-host ( -- string ) : current-host ( -- string )
request get host>> host-name or ; request get url>> host>> host-name or ;
: new-password-url ( user -- url ) : new-password-url ( user -- url )
"new-password" "recover-3"
swap [ swap [
[ username>> "username" set ] [ username>> "username" set ]
[ ticket>> "ticket" set ] [ ticket>> "ticket" set ]
@ -223,8 +218,8 @@ SYMBOL: lost-password-from
"E-mail send thread" spawn drop ; "E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action ) : <recover-action-1> ( -- action )
<action> <page-action>
[ "recover-1" login-template <html-content> ] >>display "$login/recover-1" >>template
[ [
{ {
@ -240,11 +235,15 @@ SYMBOL: lost-password-from
send-password-email send-password-email
] when* ] when*
"recover-2" login-template <html-content> URL" $login/recover-2" <redirect>
] >>submit ; ] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
"$login/recover-2" >>template ;
: <recover-action-3> ( -- action ) : <recover-action-3> ( -- action )
<action> <page-action>
[ [
{ {
{ "username" [ v-username ] } { "username" [ v-username ] }
@ -252,7 +251,7 @@ SYMBOL: lost-password-from
} validate-params } validate-params
] >>init ] >>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 "new-password" value >>encoded-password
users update-user users update-user
"recover-4" login-template <html-content> URL" $login/recover-4" <redirect>
] [ ] [
<400> <400>
] if* ] if*
] >>submit ; ] >>submit ;
: <recover-action-4> ( -- action )
<page-action>
"$login/recover-4" >>template ;
! ! ! Logout ! ! ! Logout
: <logout-action> ( -- action ) : <logout-action> ( -- action )
<action> <action>
@ -294,7 +297,7 @@ C: <protected> protected
: show-login-page ( -- response ) : show-login-page ( -- response )
begin-flow begin-flow
"$login/login" f <standard-redirect> ; URL" $login/login" <redirect> ;
: check-capabilities ( responder user -- ? ) : check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ; [ capabilities>> ] bi@ subset? ;
@ -317,7 +320,7 @@ M: login call-responder* ( path responder -- response )
: <login-boilerplate> ( responder -- responder' ) : <login-boilerplate> ( responder -- responder' )
<boilerplate> <boilerplate>
"boilerplate" login-template >>template ; "$login/boilerplate" >>template ;
: <login> ( responder -- auth ) : <login> ( responder -- auth )
login new-dispatcher login new-dispatcher
@ -340,8 +343,12 @@ M: login call-responder* ( path responder -- response )
: allow-password-recovery ( login -- login ) : allow-password-recovery ( login -- login )
<recover-action-1> <login-boilerplate> <recover-action-1> <login-boilerplate>
"recover-password" add-responder "recover-password" add-responder
<recover-action-2> <login-boilerplate>
"recover-2" add-responder
<recover-action-3> <login-boilerplate> <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? ( -- ? ) : allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ; login get responders>> "edit-profile" swap key? ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -1,5 +1,5 @@
IN: http.server.callbacks IN: furnace.callbacks
USING: http.server.actions http.server.callbacks accessors USING: furnace.actions furnace.callbacks accessors
http.server http tools.test namespaces io fry sequences http.server http tools.test namespaces io fry sequences
splitting kernel hashtables continuations ; splitting kernel hashtables continuations ;
@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
<action> [ <action> [
[ [
"hello" print "hello" print
'[ , write ] <html-content> "text/html" <content>
] show-page ] show-page
"byebye" print "byebye" print
[ 123 ] show-final [ 123 ] show-final

View File

@ -4,7 +4,7 @@
USING: http http.server io kernel math namespaces USING: http http.server io kernel math namespaces
continuations calendar sequences assocs hashtables continuations calendar sequences assocs hashtables
accessors arrays alarms quotations combinators fry assocs.lib ; accessors arrays alarms quotations combinators fry assocs.lib ;
IN: http.server.callbacks IN: furnace.callbacks
SYMBOL: responder SYMBOL: responder

View File

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

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: 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 ; kernel accessors continuations namespaces destructors ;
IN: http.server.db IN: furnace.db
TUPLE: db-persistence < filter-responder pool ; TUPLE: db-persistence < filter-responder pool ;

View File

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

View File

@ -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 ;

View File

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

View File

@ -4,8 +4,8 @@ USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms fry calendar combinators destructors alarms
db db.tuples db.types db db.tuples db.types
http http.server html.elements ; http http.server html.elements html.templates.chloe ;
IN: http.server.sessions IN: furnace.sessions
TUPLE: session id expires uid namespace changed? ; TUPLE: session id expires uid namespace changed? ;
@ -136,7 +136,8 @@ M: session-saver dispose
: put-session-cookie ( response -- response' ) : put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ; session get id>> number>string <session-cookie> put-cookie ;
: session-form-field ( -- ) M: sessions hidden-form-field ( responder -- )
drop
<input <input
"hidden" =type "hidden" =type
session-id-key =name session-id-key =name
@ -144,10 +145,17 @@ M: session-saver dispose
input/> ; input/> ;
M: sessions call-responder* ( path responder -- response ) M: sessions call-responder* ( path responder -- response )
[ session-form-field ] add-form-hook
sessions set sessions set
request-session [ begin-session ] unless* request-session [ begin-session ] unless*
existing-session put-session-cookie ; existing-session put-session-cookie ;
: logout-all-sessions ( uid -- ) : logout-all-sessions ( uid -- )
session new swap >>uid delete-tuples ; session new swap >>uid delete-tuples ;
M: sessions link-attr
drop
"session" optional-attr {
{ "none" [ session off flow-id off ] }
{ "current" [ ] }
{ f [ ] }
} case ;

View File

@ -11,7 +11,7 @@ html.components namespaces ;
TUPLE: color red green blue ; 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 [ 1 ] [ "red" value ] unit-test
@ -107,7 +107,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test [ ] [ 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" "delivery"
<checkbox> <checkbox>

View File

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

View File

@ -4,7 +4,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations 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 IN: html.elements
@ -126,11 +127,22 @@ SYMBOL: html
dup def-for-html-word-<foo dup def-for-html-word-<foo
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-attr ( value name -- )
" " write-html " " write-html
write-html write-html
"='" write-html "='" write-html
escape-quoted-string write-html object>string escape-quoted-string write-html
"'" write-html ; "'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ; : attribute-effect T{ effect f { "string" } 0 } ;
@ -162,7 +174,7 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "media" "title" "multiple" "checked"
] [ define-attribute-word ] each ] [ define-attribute-word ] each
>> >>

View File

@ -27,8 +27,7 @@ IN: html.templates.chloe.tests
: test-template ( name -- template ) : test-template ( name -- template )
"resource:extra/html/templates/chloe/test/" "resource:extra/html/templates/chloe/test/"
swap prepend <chloe> ;
".xml" 3append <chloe> ;
[ "Hello world" ] [ [ "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>" ] [ [ "<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 ] run-template [ blank? not ] filter
] unit-test ] unit-test
[ ] [ 1 "id" set-value ] unit-test
[ "<a name=\"1\">Hello</a>" ] [
[
"test11" test-template call-template
] run-template
] unit-test

View File

@ -3,16 +3,12 @@
USING: accessors kernel sequences combinators kernel namespaces USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string 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 multiline xml xml.data xml.writer xml.utilities
html.elements html.elements
html.components html.components
html.templates html.templates
http.server html.templates.chloe.syntax ;
http.server.auth
http.server.flows
http.server.actions
http.server.sessions ;
IN: html.templates.chloe IN: html.templates.chloe
! Chloe is Ed's favorite web designer ! Chloe is Ed's favorite web designer
@ -23,8 +19,6 @@ C: <chloe> chloe
DEFER: process-template DEFER: process-template
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
: chloe-attrs-only ( assoc -- assoc' ) : chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = ] assoc-filter ; [ drop name-url chloe-ns = ] assoc-filter ;
@ -38,35 +32,22 @@ DEFER: process-template
[ t ] [ t ]
} cond nip ; } 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-tag-children ( tag -- )
[ process-template ] each ; [ process-template ] each ;
CHLOE: chloe process-tag-children ;
: children>string ( tag -- string ) : children>string ( tag -- string )
[ process-tag-children ] with-string-writer ; [ process-tag-children ] with-string-writer ;
: title-tag ( tag -- ) CHLOE: title children>string set-title ;
children>string set-title ;
: write-title-tag ( tag -- ) CHLOE: write-title
drop drop
"head" tags get member? "title" tags get member? not and "head" tags get member? "title" tags get member? not and
[ <title> write-title </title> ] [ write-title ] if ; [ <title> write-title </title> ] [ write-title ] if ;
: style-tag ( tag -- ) CHLOE: style
dup "include" optional-attr dup [ dup "include" optional-attr dup [
swap children>string empty? [ swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw "style tag cannot have both an include attribute and a body" throw
@ -76,146 +57,12 @@ MEMO: chloe-name ( string -- name )
drop children>string drop children>string
] if add-style ; ] if add-style ;
: write-style-tag ( tag -- ) CHLOE: write-style
drop <style> write-style </style> ; drop <style> write-style </style> ;
: atom-tag ( tag -- ) CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
[ "title" required-attr ]
[ "href" required-attr ]
bi set-atom-feed ;
: write-atom-tag ( tag -- ) CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
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) ;
: (bind-tag) ( tag quot -- ) : (bind-tag) ( tag quot -- )
[ [
@ -223,83 +70,36 @@ STRING: button-tag-markup
'[ , process-tag-children ] '[ , process-tag-children ]
] dip call ; inline ] dip call ; inline
: bind-tuple-tag ( tag -- ) CHLOE: each [ with-each-value ] (bind-tag) ;
[ with-tuple-values ] (bind-tag) ;
: bind-assoc-tag ( tag -- ) CHLOE: bind-each [ with-each-object ] (bind-tag) ;
[ with-assoc-values ] (bind-tag) ;
CHLOE: bind [ with-values ] (bind-tag) ;
: error-message-tag ( tag -- ) : error-message-tag ( tag -- )
children>string render-error ; children>string render-error ;
: validation-messages-tag ( tag -- ) CHLOE: comment drop ;
drop render-validation-messages ;
: singleton-component-tag ( tag class -- ) CHLOE: call-next-template drop call-next-template ;
[ "name" required-attr ] dip render ;
: attrs>slots ( tag tuple -- ) CHLOE-SINGLETON: label
[ attrs>> ] [ <mirror> ] bi* CHLOE-SINGLETON: link
'[ CHLOE-SINGLETON: farkup
swap tag>> dup "name" = CHLOE-SINGLETON: inspector
[ 2drop ] [ , set-at ] if CHLOE-SINGLETON: comparison
] assoc-each ; CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
: tuple-component-tag ( tag class -- ) CHLOE-TUPLE: field
[ drop "name" required-attr ] CHLOE-TUPLE: password
[ new [ attrs>slots ] keep ] CHLOE-TUPLE: choice
2bi render ; CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- ) : process-chloe-tag ( tag -- )
dup name-tag { dup name-tag tags get at
{ "chloe" [ process-tag-children ] } [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
! 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 ;
: process-tag ( tag -- ) : process-tag ( tag -- )
{ {
@ -310,7 +110,15 @@ STRING: button-tag-markup
[ drop tags get pop* ] [ drop tags get pop* ]
} cleave ; } cleave ;
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
[ "@" ?head [ value object>string ] when ] assoc-map
] change-attrs
] when ;
: process-template ( xml -- ) : process-template ( xml -- )
expand-attrs
{ {
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] } { [ dup [ tag? ] is? ] [ process-tag ] }
@ -334,6 +142,6 @@ STRING: button-tag-markup
] with-scope ; ] with-scope ;
M: chloe call-template* 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 INSTANCE: chloe template

View File

@ -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

View File

@ -3,12 +3,12 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table> <table>
<t:each-tuple t:values="people"> <t:bind-each t:name="people">
<tr> <tr>
<td><t:label t:name="first-name"/></td> <td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td> <td><t:label t:name="last-name"/></td>
</tr> </tr>
</t:each-tuple> </t:bind-each>
</table> </table>
</t:chloe> </t:chloe>

View File

@ -1,14 +1,3 @@
<?xml version='1.0' ?> <?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>
<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>

View File

@ -3,7 +3,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<ul> <ul>
<t:each t:values="numbers"> <t:each t:name="numbers">
<li><t:label t:name="value"/></li> <li><t:label t:name="value"/></li>
</t:each> </t:each>
</ul> </ul>

View File

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

View File

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

View File

@ -27,8 +27,7 @@ SYMBOL: redirects
redirects inc redirects inc
redirects get max-redirects < [ redirects get max-redirects < [
request get request get
swap "location" header dup absolute-url? swap "location" header request-with-url
[ request-with-url ] [ request-with-path ] if
"GET" >>method http-request "GET" >>method http-request
] [ ] [
too-many-redirects too-many-redirects
@ -51,7 +50,7 @@ PRIVATE>
: http-request ( request -- response data ) : http-request ( request -- response data )
dup request [ dup request [
dup request-addr latin1 [ dup url>> url-addr latin1 [
1 minutes timeouts 1 minutes timeouts
write-request write-request
read-response read-response

View File

@ -1,37 +1,13 @@
USING: http tools.test multiline tuple-syntax USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations ; assocs io.sockets db db.sqlite continuations urls ;
IN: http.tests 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
[ "/" ] [ "http://foo.com/" url>path ] unit-test [ "/" ] [ "http://foo.com/" url>path ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/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 ; : lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1
@ -45,11 +21,8 @@ blah
[ [
TUPLE{ request TUPLE{ request
protocol: http url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
port: 80
method: "GET" method: "GET"
path: "/bar"
query: H{ }
version: "1.1" version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } } header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah" post-data: "blah"
@ -85,14 +58,10 @@ Host: www.sex.com
[ [
TUPLE{ request TUPLE{ request
protocol: http url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
port: 80
method: "HEAD" method: "HEAD"
path: "/bar"
query: H{ }
version: "1.1" version: "1.1"
header: H{ { "host" "www.sex.com" } } header: H{ { "host" "www.sex.com" } }
host: "www.sex.com"
cookies: V{ } cookies: V{ }
} }
] [ ] [
@ -101,6 +70,15 @@ Host: www.sex.com
] with-string-reader ] with-string-reader
] unit-test ] 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 STRING: read-response-test-1
HTTP/1.1 404 not found HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8 Content-Type: text/html; charset=UTF8
@ -145,14 +123,14 @@ read-response-test-1' 1array [
] unit-test ] unit-test
! Live-fire exercise ! Live-fire exercise
USING: http.server http.server.static http.server.sessions USING: http.server http.server.static furnace.sessions
http.server.actions http.server.auth.login http.server.db http.client furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii io.server io.files io io.encodings.ascii
accessors namespaces threads ; accessors namespaces threads ;
: add-quit-action : add-quit-action
<action> <action>
[ stop-server [ "Goodbye" write ] <html-content> ] >>display [ stop-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ; "quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ; : test-db "test.db" temp-file sqlite-db ;
@ -171,7 +149,7 @@ test-db [
"resource:extra/http/test" <static> >>default "resource:extra/http/test" <static> >>default
"nested" add-responder "nested" add-responder
<action> <action>
[ "redirect-loop" f <standard-redirect> ] >>display [ URL" redirect-loop" <redirect> ] >>display
"redirect-loop" add-responder "redirect-loop" add-responder
main-responder set main-responder set
@ -186,16 +164,6 @@ test-db [
"http://localhost:1237/nested/foo.html" http-get = "http://localhost:1237/nested/foo.html" http-get =
] unit-test ] 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 ] [ "http://localhost:1237/redirect-loop" http-get ]
[ too-many-redirects? ] must-fail-with [ too-many-redirects? ] must-fail-with
@ -237,7 +205,7 @@ test-db [
[ ] [ [ ] [
[ [
<dispatcher> <dispatcher>
<action> [ [ "Hi" write ] <text-content> ] >>display <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login> <login>
<sessions> <sessions>
"" add-responder "" add-responder

View File

@ -7,88 +7,31 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string 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 unicode.case unicode.categories qualified
html.templates ; urls html.templates ;
EXCLUDE: fry => , ; EXCLUDE: fry => , ;
IN: http 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 ) : protocol-port ( protocol -- port )
M: http http-port drop 80 ;
M: https http-port drop 443 ;
GENERIC: protocol>string ( protocol -- string )
M: http protocol>string drop "http" ;
M: https protocol>string drop "https" ;
: string>protocol ( string -- protocol )
{ {
{ "http" [ http ] } { "http" [ 80 ] }
{ "https" [ https ] } { "https" [ 443 ] }
[ "Unknown protocol: " swap append throw ]
} case ; } case ;
: absolute-url? ( url -- ? ) : ensure-port ( url -- url' )
[ "http://" head? ] [ "https://" head? ] bi or ; dup protocol>> '[ , protocol-port or ] change-port ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
: crlf "\r\n" write ; : crlf "\r\n" write ;
@ -130,6 +73,7 @@ M: https protocol>string drop "https" ;
{ {
{ [ dup number? ] [ number>string ] } { [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] } { [ dup timestamp? ] [ timestamp>http-string ] }
{ [ dup url? ] [ url>string ] }
{ [ dup string? ] [ ] } { [ dup string? ] [ ] }
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] } { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
} cond ; } cond ;
@ -145,42 +89,6 @@ M: https protocol>string drop "https" ;
header-value>string check-header-string write crlf header-value>string check-header-string write crlf
] assoc-each 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 ; TUPLE: cookie name value path domain expires max-age http-only ;
: <cookie> ( value name -- cookie ) : <cookie> ( value name -- cookie )
@ -236,12 +144,8 @@ TUPLE: cookie name value path domain expires max-age http-only ;
[ unparse-cookie ] map concat "; " join ; [ unparse-cookie ] map concat "; " join ;
TUPLE: request TUPLE: request
protocol
host
port
method method
path url
query
version version
header header
post-data post-data
@ -254,19 +158,15 @@ cookies ;
: <request> : <request>
request new request new
"1.1" >>version "1.1" >>version
http >>protocol <url>
H{ } clone >>header "http" >>protocol
H{ } clone >>query H{ } clone >>query
>>url
H{ } clone >>header
V{ } clone >>cookies V{ } clone >>cookies
"close" "connection" set-header "close" "connection" set-header
"Factor http.client vocabulary" "user-agent" 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' ) : chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip ":" split1 "//" ?head drop nip
CHAR: / over index over length or tail CHAR: / over index over length or tail
@ -284,21 +184,17 @@ cookies ;
" " read-until [ "Bad request: method" throw ] unless " " read-until [ "Bad request: method" throw ] unless
>>method ; >>method ;
: read-query ( request -- request ) : check-absolute ( url -- url )
" " read-until dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
[ "Bad request: query params" throw ] unless
query>assoc >>query ;
: read-url ( request -- request ) : read-url ( request -- request )
" ?" read-until { " " read-until [
{ CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
{ CHAR: ? [ url>path >>path read-query ] } ] [ "Bad request: URL" throw ] if ;
[ "Bad request: URL" throw ]
} case ;
: parse-version ( string -- version ) : parse-version ( string -- version )
"HTTP/" ?head [ "Bad version" throw ] unless "HTTP/" ?head [ "Bad request: version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
: read-request-version ( request -- request ) : read-request-version ( request -- request )
read-crlf [ CHAR: \s = ] left-trim read-crlf [ CHAR: \s = ] left-trim
@ -325,13 +221,11 @@ SYMBOL: max-post-request
: read-post-data ( request -- request ) : read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ; dup header>> content-length [ read >>post-data ] when* ;
: parse-host ( string -- host port )
"." ?tail drop ":" split1
dup [ string>number ] when ;
: extract-host ( request -- request ) : extract-host ( request -- request )
dup [ "host" header parse-host ] keep protocol>> http-port or [ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi* ; [ >>host ] [ >>port ] bi*
ensure-port
drop ;
: extract-post-data-type ( request -- request ) : extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ; dup "content-type" header >>post-data-type ;
@ -349,6 +243,9 @@ SYMBOL: max-post-request
: parse-content-type ( content-type -- type encoding ) : parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ; ";" 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 ) : read-request ( -- request )
<request> <request>
read-method read-method
@ -356,6 +253,7 @@ SYMBOL: max-post-request
read-request-version read-request-version
read-request-header read-request-header
read-post-data read-post-data
detect-protocol
extract-host extract-host
extract-post-data-type extract-post-data-type
parse-post-data parse-post-data
@ -364,15 +262,8 @@ SYMBOL: max-post-request
: write-method ( request -- request ) : write-method ( request -- request )
dup method>> write bl ; 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 ) : write-request-url ( request -- request )
dup write-url bl ; dup url>> relative-url url>string write bl ;
: write-version ( request -- request ) : write-version ( request -- request )
"HTTP/" write dup request-version write crlf ; "HTTP/" write dup request-version write crlf ;
@ -383,24 +274,13 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type "application/x-www-form-urlencoded" >>post-data-type
] if ; ] if ;
GENERIC: protocol-addr ( request protocol -- addr ) : url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
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 =
[ drop ] [ ":" swap number>string 3append ] if ; [ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request ) : write-request-header ( request -- request )
dup header>> >hashtable 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>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" 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* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@ -419,38 +299,8 @@ M: https protocol-addr
flush flush
drop ; drop ;
: request-with-path ( request path -- request )
[ "/" prepend ] [ "/" ] if*
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
: request-with-url ( request url -- request ) : request-with-url ( request url -- request )
":" split1 '[ , >url derive-url ensure-port ] change-url ;
[ string>protocol >>protocol ]
[
"//" ?head [ "Invalid URL" throw ] unless
"/" split1
[
parse-host [ >>host ] [ >>port ] bi*
dup protocol>> http-port '[ , or ] change-port
]
[ request-with-path ]
bi*
] bi* ;
: request-url ( request -- url )
[
[
dup host>> [
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
[ write-url ]
tri
] with-string-writer ;
GENERIC: write-response ( response -- ) GENERIC: write-response ( response -- )

View File

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

View File

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

View File

@ -1,27 +1,52 @@
USING: http.server tools.test kernel namespaces accessors 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 IN: http.server.tests
\ find-responder must-infer \ find-responder must-infer
[ [
<request> <request>
http >>protocol <url>
"http" >>protocol
"www.apple.com" >>host "www.apple.com" >>host
"/xxx/bar" >>path "/xxx/bar" >>path
{ { "a" "b" } } >>query { { "a" "b" } } >>query
>>url
request set request set
[ ] link-hook 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/bar" ] [
[ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test <url> adjust-url url>string
[ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test ] 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/xxx/baz" ] [
[ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test <url> "baz" >>path adjust-url url>string
[ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test ] unit-test
[ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] 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 ] with-scope
TUPLE: mock-responder path ; TUPLE: mock-responder path ;
@ -31,7 +56,7 @@ C: <mock-responder> mock-responder
M: mock-responder call-responder* M: mock-responder call-responder*
nip nip
path>> on path>> on
[ ] <text-content> ; [ ] "text/plain" <content> ;
: check-dispatch ( tag path -- ? ) : check-dispatch ( tag path -- ? )
H{ } clone base-paths set H{ } clone base-paths set
@ -84,7 +109,7 @@ C: <path-check-responder> path-check-responder
M: path-check-responder call-responder* M: path-check-responder call-responder*
drop drop
>array <text-content> ; >array "text/plain" <content> ;
[ { "c" } ] [ [ { "c" } ] [
H{ } clone base-paths set 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* M: base-path-check-responder call-responder*
2drop 2drop
"$funny-dispatcher" resolve-base-path "$funny-dispatcher" resolve-base-path
<text-content> ; "text/plain" <content> ;
[ ] [ [ ] [
<dispatcher> <dispatcher>

View File

@ -2,23 +2,16 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting USING: assocs kernel namespaces io io.timeouts strings splitting
threads sequences prettyprint io.server logging calendar http threads sequences prettyprint io.server logging calendar http
html.streams html.elements accessors math.parser html.streams html.components html.elements html.templates
combinators.lib tools.vocabs debugger continuations random accessors math.parser combinators.lib tools.vocabs debugger
combinators destructors io.encodings.8-bit fry classes words continuations random combinators destructors io.streams.string
math rss json.writer ; io.encodings.8-bit fry classes words math urls
arrays vocabs.loader ;
IN: http.server IN: http.server
! path is a sequence of path component strings ! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response ) 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 ) : <content> ( body content-type -- response )
<response> <response>
200 >>code 200 >>code
@ -26,21 +19,6 @@ GENERIC: call-responder* ( path responder -- response )
swap >>content-type swap >>content-type
swap >>body ; 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 ; TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder C: <trivial-responder> trivial-responder
@ -55,7 +33,8 @@ M: trivial-responder call-responder* nip response>> call ;
</html> ; </html> ;
: <trivial-response> ( code message -- response ) : <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ] <html-content> 2dup [ trivial-response-body ] with-string-writer
"text/html" <content>
swap >>message swap >>message
swap >>code ; swap >>code ;
@ -69,7 +48,7 @@ SYMBOL: 404-responder
[ <404> ] <trivial-responder> 404-responder set-global [ <404> ] <trivial-responder> 404-responder set-global
SYMBOL: base-paths SYMBOL: responder-nesting
: invert-slice ( slice -- slice' ) : invert-slice ( slice -- slice' )
dup slice? [ dup slice? [
@ -78,86 +57,81 @@ SYMBOL: base-paths
drop { } drop { }
] if ; ] if ;
: add-base-path ( path dispatcher -- ) : vocab-path ( vocab -- path )
[ invert-slice ] [ class word-name ] bi* dup vocab-dir vocab-append-path ;
base-paths get set-at ;
: 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 ) : 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 -- ) : each-responder ( quot -- )
link-hook [ compose ] change ; inline nested-responders swap each ; inline
: modify-query ( query -- query ) : responder-path ( string -- pair )
link-hook get call ; dup responder-nesting get at
: base-path ( string -- path )
dup base-paths get at
[ ] [ "No such responder: " swap append throw ] ?if ; [ ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' ) : base-path ( string -- path )
"$" ?head [ 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 ] "" make
] when ; ] when ; inline
: link>string ( url query -- url' ) : resolve-base-path ( string -- string' )
[ resolve-base-path ] [ modify-query ] bi* (link>string) ; [ base-path ] resolve-responder-path ;
: write-link ( url query -- ) : resolve-template-path ( string -- string' )
link>string write ; [ template-path ] resolve-responder-path ;
SYMBOL: form-hook GENERIC: modify-query ( query responder -- query' )
: add-form-hook ( quot -- ) M: object modify-query drop ;
form-hook [ compose ] change ;
: hidden-form-field ( -- ) : adjust-url ( url -- url' )
form-hook get call ; 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 ) : <custom-redirect> ( url code message -- response )
#! Same host. <trivial-response>
request get clone swap dup url? [ adjust-url ] when
swap [ >>query ] when* "location" set-header ;
swap url-encode >>path
[ modify-query ] change-query
request-url ;
: replace-last-component ( path with -- path' ) \ <custom-redirect> DEBUG add-input-logging
[ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
[ modify-query ] change-query
request-url ;
: derive-url ( to query -- url )
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
<trivial-response> -rot derive-url "location" set-header ;
\ <redirect> DEBUG add-input-logging
: <permanent-redirect> ( to query -- response ) : <permanent-redirect> ( to query -- response )
301 "Moved Permanently" <redirect> ; 301 "Moved Permanently" <custom-redirect> ;
: <temporary-redirect> ( to query -- response ) : <temporary-redirect> ( to query -- response )
307 "Temporary Redirect" <redirect> ; 307 "Temporary Redirect" <custom-redirect> ;
: <standard-redirect> ( to query -- response ) : <redirect> ( to query -- response )
request get method>> "POST" = request get method>> {
[ <permanent-redirect> ] [ <temporary-redirect> ] if ; { "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
TUPLE: dispatcher default responders ; TUPLE: dispatcher default responders ;
@ -187,7 +161,7 @@ TUPLE: vhost-dispatcher default responders ;
404-responder get H{ } clone vhost-dispatcher boa ; 404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder ) : find-vhost ( dispatcher -- responder )
request get host>> over responders>> at* request get url>> host>> over responders>> at*
[ nip ] [ drop default>> ] if ; [ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response ) M: vhost-dispatcher call-responder* ( path dispatcher -- response )
@ -242,35 +216,28 @@ SYMBOL: development-mode
LOG: httpd-hit NOTICE LOG: httpd-hit NOTICE
: log-request ( request -- ) : log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ; [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path ) : split-path ( string -- path )
"/" split harvest ; "/" split harvest ;
: init-request ( -- ) : init-request ( request -- )
H{ } clone base-paths set request set
H{ } clone responder-nesting set
[ ] link-hook set [ ] link-hook set
[ ] form-hook set ; [ ] form-hook set ;
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
: do-request ( request -- response ) : do-request ( request -- response )
[ [
init-request [ init-request ]
[ request set ]
[ log-request ] [ log-request ]
[ path>> split-path main-responder get call-responder ] tri [ dispatch-request ] tri
[ <404> ] unless* ]
] [ [ [ \ do-request log-error ] [ <500> ] bi ]
[ \ do-request log-error ] recover ;
[ <500> ]
bi
] recover ;
: ?refresh-all ( -- ) : ?refresh-all ( -- )
development-mode get-global development-mode get-global

View File

@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors 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 IN: http.server.static
! special maps mime types to quots with effect ( path -- ) ! 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 ) : list-directory ( directory -- response )
file-responder get allow-listings>> [ file-responder get allow-listings>> [
'[ , directory. ] <html-content> '[ , directory. ] "text/html" <content>
] [ ] [
drop <403> drop <403>
] if ; ] if ;
@ -85,7 +85,7 @@ TUPLE: file-responder root hook special allow-listings ;
find-index [ serve-file ] [ list-directory ] ?if find-index [ serve-file ] [ list-directory ] ?if
] [ ] [
drop drop
request get path>> "/" append f <standard-redirect> request get url>> clone [ "/" append ] change-path <redirect>
] if ; ] if ;
: serve-object ( filename -- response ) : serve-object ( filename -- response )
@ -101,6 +101,6 @@ M: file-responder call-responder* ( path responder -- response )
! file responder integration ! file responder integration
: enable-fhtml ( responder -- responder ) : enable-fhtml ( responder -- responder )
[ <fhtml> <html-content> ] [ <fhtml> "text/html" <content> ]
"application/x-factor-server-page" "application/x-factor-server-page"
pick special>> set-at ; pick special>> set-at ;

View File

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

View File

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

View File

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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman ! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: tangle
GENERIC: render* ( content templater -- output ) GENERIC: render* ( content templater -- output )
@ -20,7 +20,7 @@ C: <tangle> tangle
[ [ db>> ] [ seq>> ] bi ] dip with-db ; [ [ db>> ] [ seq>> ] bi ] dip with-db ;
: node-response ( id -- response ) : 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 ) : display-node ( params -- response )
[ [
@ -36,7 +36,7 @@ C: <tangle> tangle
: submit-node ( params -- response ) : submit-node ( params -- response )
[ [
"node_content" swap at* [ "node_content" swap at* [
create-node id>> number>string <text-content> create-node id>> number>string "text/plain" <content>
] [ ] [
drop <400> drop <400>
] if ] if
@ -52,7 +52,7 @@ TUPLE: path-responder ;
C: <path-responder> path-responder C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response ) 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 ; TUPLE: tangle-dispatcher < dispatcher tangle ;

View File

@ -77,10 +77,17 @@ USING: urls tools.test tuple-syntax arrays kernel assocs ;
} }
"a/relative/path" "a/relative/path"
} }
{
TUPLE{ url
path: "bar"
query: H{ { "a" "b" } }
}
"bar?a=b"
}
} ; } ;
urls [ urls [
[ 1array ] [ [ string>url ] curry ] bi* unit-test [ 1array ] [ [ >url ] curry ] bi* unit-test
] assoc-each ] assoc-each
urls [ urls [
@ -192,3 +199,7 @@ urls [
derive-url derive-url
] unit-test ] unit-test
[ "a" ] [
<url> "a" "b" set-query-param "b" query-param
] unit-test

View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel unicode.categories combinators sequences splitting USING: kernel unicode.categories combinators sequences splitting
fry namespaces assocs arrays strings mirrors fry namespaces assocs arrays strings io.encodings.string
io.encodings.string io.encodings.utf8 io.encodings.utf8 math math.parser accessors mirrors parser
math math.parser accessors namespaces.lib ; prettyprint.backend hashtables ;
IN: urls IN: urls
: url-quotable? ( ch -- ? ) : url-quotable? ( ch -- ? )
@ -91,11 +91,13 @@ IN: urls
TUPLE: url protocol host port path query anchor ; TUPLE: url protocol host port path query anchor ;
: <url> ( -- url ) url new ;
: query-param ( request key -- value ) : query-param ( request key -- value )
swap query>> at ; swap query>> at ;
: set-query-param ( request value key -- request ) : set-query-param ( request value key -- request )
pick query>> set-at ; '[ , , _ ?set-at ] change-query ;
: parse-host ( string -- host port ) : parse-host ( string -- host port )
":" split1 [ url-decode ] [ ":" split1 [ url-decode ] [
@ -105,40 +107,44 @@ TUPLE: url protocol host port path query anchor ;
] when ] when
] bi* ; ] bi* ;
: parse-host-part ( protocol rest -- string' ) : parse-host-part ( url protocol rest -- url string' )
[ "protocol" set ] [ [ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless "//" ?head [ "Invalid URL" throw ] unless
"/" split1 [ "/" split1 [
parse-host [ "host" set ] [ "port" set ] bi* parse-host [ >>host ] [ >>port ] bi*
] [ "/" prepend ] bi* ] [ "/" prepend ] bi*
] bi* ; ] bi* ;
: string>url ( string -- url ) GENERIC: >url ( obj -- url )
[
M: url >url ;
M: string >url
<url> swap
":" split1 [ parse-host-part ] when* ":" split1 [ parse-host-part ] when*
"#" split1 [ "#" split1 [
"?" split1 [ query>assoc "query" set ] when* "?" split1
url-decode "path" set [ url-decode >>path ]
] [ [ [ query>assoc >>query ] when* ] bi*
url-decode "anchor" set ]
] bi* [ url-decode >>anchor ] bi* ;
] url make-object ;
: unparse-host-part ( protocol -- ) : unparse-host-part ( url protocol -- )
% %
"://" % "://" %
"host" get url-encode % [ host>> url-encode % ]
"port" get [ ":" % # ] when* [ port>> [ ":" % # ] when* ]
"path" get "/" head? [ "Invalid URL" throw ] unless ; [ path>> "/" head? [ "/" % ] unless ]
tri ;
: url>string ( url -- string ) : url>string ( url -- string )
[ [
<mirror> [ {
"protocol" get [ unparse-host-part ] when* [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
"path" get url-encode % [ path>> url-encode % ]
"query" get [ "?" % assoc>query % ] when* [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
"anchor" get [ "#" % url-encode % ] when* [ anchor>> [ "#" % url-encode % ] when* ]
] bind } cleave
] "" make ; ] "" make ;
: url-append-path ( path1 path2 -- path ) : url-append-path ( path1 path2 -- path )
@ -158,3 +164,7 @@ TUPLE: url protocol host port path query anchor ;
: relative-url ( url -- url' ) : relative-url ( url -- url' )
clone f >>protocol f >>host f >>port ; 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 ;

View File

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

View File

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

View File

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

View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <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> <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> <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table> </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: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> <table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr> <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: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> <h2>New Annotation</h2>
@ -55,6 +53,6 @@
<input type="SUBMIT" value="Done" /> <input type="SUBMIT" value="Done" />
</t:form> </t:form>
</t:bind-assoc> </t:bind>
</t:chloe> </t:chloe>

View File

@ -2,6 +2,8 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <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" /> <t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar"> <div class="navbar">

View File

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

View File

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

View File

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

View File

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

View File

@ -3,19 +3,16 @@
USING: kernel accessors sequences sorting math math.order USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables sequences.lib db.types db.tuples db fry locals hashtables
html.components html.templates.chloe html.components
rss xml.writer rss urls xml.writer
validators validators
http.server http.server
http.server.actions furnace.actions
http.server.boilerplate furnace.boilerplate
http.server.auth.login furnace.auth.login
http.server.auth ; furnace.auth ;
IN: webapps.planet IN: webapps.planet
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
TUPLE: blog id name www-url feed-url ; TUPLE: blog id name www-url feed-url ;
M: blog link-title name>> ; M: blog link-title name>> ;
@ -61,7 +58,7 @@ posting "POSTINGS"
: <edit-blogroll-action> ( -- action ) : <edit-blogroll-action> ( -- action )
<page-action> <page-action>
[ blogroll "blogroll" set-value ] >>init [ blogroll "blogroll" set-value ] >>init
"admin" planet-template >>template ; "$planet-factor/admin" >>template ;
: <planet-action> ( -- action ) : <planet-action> ( -- action )
<page-action> <page-action>
@ -70,7 +67,7 @@ posting "POSTINGS"
postings "postings" set-value postings "postings" set-value
] >>init ] >>init
"planet" planet-template >>template ; "$planet-factor/planet" >>template ;
: planet-feed ( -- feed ) : planet-feed ( -- feed )
feed new feed new
@ -110,7 +107,7 @@ posting "POSTINGS"
<action> <action>
[ [
update-cached-postings update-cached-postings
"" f <permanent-redirect> URL" $planet-factor/admin" <redirect>
] >>submit ; ] >>submit ;
: <delete-blog-action> ( -- action ) : <delete-blog-action> ( -- action )
@ -119,7 +116,7 @@ posting "POSTINGS"
[ [
"id" value <blog> delete-tuples "id" value <blog> delete-tuples
"$planet-factor/admin" f <standard-redirect> URL" $planet-factor/admin" <redirect>
] >>submit ; ] >>submit ;
: validate-blog ( -- ) : validate-blog ( -- )
@ -129,15 +126,12 @@ posting "POSTINGS"
{ "feed-url" [ v-url ] } { "feed-url" [ v-url ] }
} validate-params ; } validate-params ;
: <id-redirect> ( id next -- response )
swap "id" associate <standard-redirect> ;
: deposit-blog-slots ( blog -- ) : deposit-blog-slots ( blog -- )
{ "name" "www-url" "feed-url" } deposit-slots ; { "name" "www-url" "feed-url" } deposit-slots ;
: <new-blog-action> ( -- action ) : <new-blog-action> ( -- action )
<page-action> <page-action>
"new-blog" planet-template >>template "$planet-factor/new-blog" >>template
[ validate-blog ] >>validate [ validate-blog ] >>validate
@ -145,7 +139,12 @@ posting "POSTINGS"
f <blog> f <blog>
[ deposit-blog-slots ] [ deposit-blog-slots ]
[ insert-tuple ] [ 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 tri
] >>submit ; ] >>submit ;
@ -153,10 +152,10 @@ posting "POSTINGS"
<page-action> <page-action>
[ [
validate-integer-id validate-integer-id
"id" value <blog> select-tuple from-tuple "id" value <blog> select-tuple from-object
] >>init ] >>init
"edit-blog" planet-template >>template "$planet-factor/edit-blog" >>template
[ [
validate-integer-id validate-integer-id
@ -167,7 +166,12 @@ posting "POSTINGS"
f <blog> f <blog>
[ deposit-blog-slots ] [ deposit-blog-slots ]
[ update-tuple ] [ update-tuple ]
[ id>> "$planet-factor/admin" <id-redirect> ] [
<url>
"$planet-factor/admin" >>path
swap id>> "id" set-query-param
<redirect>
]
tri tri
] >>submit ; ] >>submit ;
@ -193,7 +197,7 @@ TUPLE: planet-factor < dispatcher ;
<feed-action> "feed.xml" add-responder <feed-action> "feed.xml" add-responder
<planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate> <boilerplate>
"planet-common" planet-template >>template ; "$planet-factor/planet-common" >>template ;
: start-update-task ( db params -- ) : start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -35,7 +35,11 @@
<tr> <tr>
<th class="field-label big-field-label">Capabilities:</th> <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>
<tr> <tr>

View File

@ -35,7 +35,11 @@
<tr> <tr>
<th class="field-label big-field-label">Capabilities:</th> <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> </tr>
</table> </table>

View File

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

View File

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

View File

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

View File

@ -5,7 +5,7 @@
<t:title>Recent Changes</t:title> <t:title>Recent Changes</t:title>
<ul> <ul>
<t:each-tuple t:values="changes"> <t:bind-each t:name="changes">
<li> <li>
<t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a> <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
on on
@ -13,7 +13,7 @@
by by
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
</li> </li>
</t:each-tuple> </t:bind-each>
</ul> </ul>
</t:chloe> </t:chloe>

View File

@ -2,34 +2,34 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <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:title>Diff: <t:label t:name="title" /></t:title>
</t:bind-tuple> </t:bind>
<table> <table>
<tr> <tr>
<th class="field-label">Old revision:</th> <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> <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>
<tr> <tr>
<th class="field-label">New revision:</th> <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> <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>
</table> </table>
<t:comparison t:name="diff" /> <t:comparison t:name="diff" />
<t:bind-tuple t:name="old"> <t:bind t:name="old">
<div class="navbar"> <div class="navbar">
<t:a t:href="$wiki/view" t:query="title">Latest</t:a> <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/revisions" t:query="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:query="title">Edit</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> | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div> </div>
</t:bind-tuple> </t:bind>
</t:chloe> </t:chloe>

View File

@ -4,15 +4,23 @@
<t:title>Revisions of <t:label t:name="title" /></t:title> <t:title>Revisions of <t:label t:name="title" /></t:title>
<ul> <div class="revisions">
<t:each-tuple t:values="revisions"> <table>
<li> <tr>
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> <th>Revision</th>
by <th>Author</th>
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> <th>Rollback</th>
</li> </tr>
</t:each-tuple>
</ul> <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> <h2>View Differences</h2>
@ -23,9 +31,9 @@
<td> <td>
<select name="old-id"> <select name="old-id">
<t:each-tuple t:values="revisions"> <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option> <option> <t:label t:name="id" /> </option>
</t:each-tuple> </t:bind-each>
</select> </select>
</td> </td>
</tr> </tr>
@ -34,9 +42,9 @@
<td> <td>
<select name="new-id"> <select name="new-id">
<t:each-tuple t:values="revisions"> <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option> <option> <t:label t:name="id" /> </option>
</t:each-tuple> </t:bind-each>
</select> </select>
</td> </td>
</tr> </tr>
@ -45,4 +53,13 @@
<input type="submit" value="View" /> <input type="submit" value="View" />
</form> </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> </t:chloe>

View File

@ -5,13 +5,13 @@
<t:title>Edits by <t:label t:name="author" /></t:title> <t:title>Edits by <t:label t:name="author" /></t:title>
<ul> <ul>
<t:each-tuple t:values="user-edits"> <t:bind-each t:name="user-edits">
<li> <li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a> <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
</li> </li>
</t:each-tuple> </t:bind-each>
</ul> </ul>
</t:chloe> </t:chloe>

View File

@ -1,8 +1,3 @@
.comparison table, {
border-color: #666;
border-style: solid;
}
.comparison th { .comparison th {
border-width: 1px; border-width: 1px;
border-color: #666; border-color: #666;
@ -10,12 +5,13 @@
} }
.comparison table { .comparison table {
border-color: #666;
border-style: solid;
border-width: 1px; border-width: 1px;
border-spacing: 0; border-spacing: 0;
border-collapse: collapse; border-collapse: collapse;
} }
.insert { .insert {
background-color: #9f9; background-color: #9f9;
} }
@ -23,3 +19,21 @@
.delete { .delete {
background-color: #f99; 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;
}

View File

@ -3,14 +3,13 @@
USING: accessors kernel hashtables calendar USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order namespaces splitting sequences sorting math.order
html.components html.components
html.templates.chloe
http.server http.server
http.server.actions furnace.actions
http.server.auth furnace.auth
http.server.auth.login furnace.auth.login
http.server.boilerplate furnace.boilerplate
validators validators
db.types db.tuples lcs farkup ; db.types db.tuples lcs farkup urls ;
IN: webapps.wiki IN: webapps.wiki
TUPLE: article title revision ; TUPLE: article title revision ;
@ -41,18 +40,17 @@ revision "REVISIONS" {
: init-revisions-table revision ensure-table ; : 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 ( -- ) : validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ; { { "title" [ v-one-line ] } } validate-params ;
: <main-article-action> ( -- action ) : <main-article-action> ( -- 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 ) : <view-article-action> ( -- action )
<action> <action>
@ -65,10 +63,13 @@ revision "REVISIONS" {
[ [
"title" value dup <article> select-tuple [ "title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-tuple revision>> <revision> select-tuple from-object
"view" wiki-template <html-content> "$wiki/view" <chloe-content>
] [ ] [
"$wiki/edit" <title-redirect> <url>
"$wiki/edit" >>path
swap "title" set-query-param
<redirect>
] ?if ] ?if
] >>display ; ] >>display ;
@ -77,10 +78,10 @@ revision "REVISIONS" {
[ [
{ { "id" [ v-integer ] } } validate-params { { "id" [ v-integer ] } } validate-params
"id" value <revision> "id" value <revision>
select-tuple from-tuple select-tuple from-object
] >>init ] >>init
"view" wiki-template >>template ; "$wiki/view" >>template ;
: add-revision ( revision -- ) : add-revision ( revision -- )
[ insert-tuple ] [ insert-tuple ]
@ -97,11 +98,11 @@ revision "REVISIONS" {
[ [
validate-title validate-title
"title" value <article> select-tuple [ "title" value <article> select-tuple [
revision>> <revision> select-tuple from-tuple revision>> <revision> select-tuple from-object
] when* ] when*
] >>init ] >>init
"edit" wiki-template >>template "$wiki/edit" >>template
[ [
validate-title validate-title
@ -113,7 +114,12 @@ revision "REVISIONS" {
logged-in-user get username>> >>author logged-in-user get username>> >>author
"content" value >>content "content" value >>content
[ add-revision ] [ add-revision ]
[ title>> "$wiki/view" <title-redirect> ] bi [
<url>
"$wiki/view" >>path
swap title>> "title" set-query-param
<redirect>
] bi
] >>submit ; ] >>submit ;
: <list-revisions-action> ( -- action ) : <list-revisions-action> ( -- action )
@ -125,7 +131,24 @@ revision "REVISIONS" {
"revisions" set-value "revisions" set-value
] >>init ] >>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 ) : <list-changes-action> ( -- action )
<page-action> <page-action>
@ -135,7 +158,7 @@ revision "REVISIONS" {
"changes" set-value "changes" set-value
] >>init ] >>init
"changes" wiki-template >>template ; "$wiki/changes" >>template ;
: <delete-action> ( -- action ) : <delete-action> ( -- action )
<action> <action>
@ -144,7 +167,7 @@ revision "REVISIONS" {
[ [
"title" value <article> delete-tuples "title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples f <revision> "title" value >>title delete-tuples
"" f <standard-redirect> URL" $wiki" <redirect>
] >>submit ; ] >>submit ;
: <diff-action> ( -- action ) : <diff-action> ( -- action )
@ -162,7 +185,7 @@ revision "REVISIONS" {
2bi 2bi
] >>init ] >>init
"diff" wiki-template >>template ; "$wiki/diff" >>template ;
: <list-articles-action> ( -- action ) : <list-articles-action> ( -- action )
<page-action> <page-action>
@ -172,7 +195,7 @@ revision "REVISIONS" {
"articles" set-value "articles" set-value
] >>init ] >>init
"articles" wiki-template >>template ; "$wiki/articles" >>template ;
: <user-edits-action> ( -- action ) : <user-edits-action> ( -- action )
<page-action> <page-action>
@ -182,7 +205,7 @@ revision "REVISIONS" {
select-tuples "user-edits" set-value select-tuples "user-edits" set-value
] >>init ] >>init
"user-edits" wiki-template >>template ; "$wiki/user-edits" >>template ;
TUPLE: wiki < dispatcher ; TUPLE: wiki < dispatcher ;
@ -192,6 +215,7 @@ TUPLE: wiki < dispatcher ;
<view-article-action> "view" add-responder <view-article-action> "view" add-responder
<view-revision-action> "revision" add-responder <view-revision-action> "revision" add-responder
<list-revisions-action> "revisions" add-responder <list-revisions-action> "revisions" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder <user-edits-action> "user-edits" add-responder
<diff-action> "diff" add-responder <diff-action> "diff" add-responder
<list-articles-action> "articles" add-responder <list-articles-action> "articles" add-responder
@ -199,4 +223,4 @@ TUPLE: wiki < dispatcher ;
<edit-article-action> { } <protected> "edit" add-responder <edit-article-action> { } <protected> "edit" add-responder
<delete-action> { } <protected> "delete" add-responder <delete-action> { } <protected> "delete" add-responder
<boilerplate> <boilerplate>
"wiki-common" wiki-template >>template ; "$wiki/wiki-common" >>template ;

View File

@ -1,14 +1,14 @@
USING: xmode.tokens xmode.marker xmode.catalog kernel USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8 html.elements io io.files sequences words io.encodings.utf8
namespaces xml.entities ; namespaces xml.entities accessors ;
IN: xmode.code2html IN: xmode.code2html
: htmlize-tokens ( tokens -- ) : htmlize-tokens ( tokens -- )
[ [
dup token-str swap token-id [ [ str>> ] [ id>> ] bi [
<span word-name =class span> escape-string write </span> <span word-name =class span> escape-string write </span>
] [ ] [
write escape-string write
] if* ] if*
] each ; ] each ;

View File

@ -12,5 +12,5 @@ IN: xmode.code2html.responder
, utf8 [ , utf8 [
, file-name input-stream get htmlize-stream , file-name input-stream get htmlize-stream
] with-file-reader ] with-file-reader
] <html-content> ] "text/html" <content>
] <file-responder> ; ] <file-responder> ;