Improved HTTP server dispatcher
Slava Pestov
parent
4f7d7e3e0c
commit
a8e8b05339
|
|
@ -133,16 +133,20 @@ read-response-test-1' 1array [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Live-fire exercise
|
! Live-fire exercise
|
||||||
USING: http.server http.server.static http.server.actions
|
USING: http.server http.server.static http.server.sessions
|
||||||
http.client io.server io.files io accessors namespaces threads
|
http.server.actions http.server.auth.login http.client
|
||||||
|
io.server io.files io accessors namespaces threads
|
||||||
io.encodings.ascii ;
|
io.encodings.ascii ;
|
||||||
|
|
||||||
|
: add-quit-action
|
||||||
|
<action>
|
||||||
|
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
|
||||||
|
"quit" add-responder ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
<dispatcher>
|
<dispatcher>
|
||||||
<action>
|
add-quit-action
|
||||||
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
|
|
||||||
"quit" add-responder
|
|
||||||
<dispatcher>
|
<dispatcher>
|
||||||
"extra/http/test" resource-path <static> >>default
|
"extra/http/test" resource-path <static> >>default
|
||||||
"nested" add-responder
|
"nested" add-responder
|
||||||
|
|
@ -176,3 +180,51 @@ io.encodings.ascii ;
|
||||||
[ "Goodbye" ] [
|
[ "Goodbye" ] [
|
||||||
"http://localhost:1237/quit" http-get
|
"http://localhost:1237/quit" http-get
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Dispatcher bugs
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
<dispatcher>
|
||||||
|
<action> <protected>
|
||||||
|
<login>
|
||||||
|
<url-sessions> "" add-responder
|
||||||
|
add-quit-action
|
||||||
|
<dispatcher>
|
||||||
|
<action> "a" add-main-responder
|
||||||
|
"d" add-responder
|
||||||
|
main-responder set
|
||||||
|
|
||||||
|
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||||
|
] with-scope
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1000 sleep ] unit-test
|
||||||
|
|
||||||
|
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
|
||||||
|
|
||||||
|
! This should give a 404 not an infinite redirect loop
|
||||||
|
[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with
|
||||||
|
|
||||||
|
! This should give a 404 not an infinite redirect loop
|
||||||
|
[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with
|
||||||
|
|
||||||
|
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
<dispatcher>
|
||||||
|
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||||
|
<login> <url-sessions>
|
||||||
|
"" add-responder
|
||||||
|
add-quit-action
|
||||||
|
main-responder set
|
||||||
|
|
||||||
|
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||||
|
] with-scope
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1000 sleep ] unit-test
|
||||||
|
|
||||||
|
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
|
||||||
|
|
||||||
|
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
IN: http.server.actions.tests
|
|
||||||
USING: http.server.actions http.server.validators
|
USING: http.server.actions http.server.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
|
||||||
|
|
||||||
[
|
[
|
||||||
"a" [ v-number ] { { "a" "123" } } validate-param
|
"a" [ v-number ] { { "a" "123" } } validate-param
|
||||||
|
|
@ -25,27 +25,5 @@ blah
|
||||||
action-request-test-1 lf>crlf
|
action-request-test-1 lf>crlf
|
||||||
[ read-request ] with-string-reader
|
[ read-request ] with-string-reader
|
||||||
request set
|
request set
|
||||||
"/blah"
|
{ } "action-1" get call-responder
|
||||||
"action-1" get call-responder
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
<action>
|
|
||||||
[ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
|
|
||||||
{ { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
|
|
||||||
"action-2" set
|
|
||||||
|
|
||||||
STRING: action-request-test-2
|
|
||||||
POST http://foo/bar/baz HTTP/1.1
|
|
||||||
content-length: 5
|
|
||||||
content-type: application/x-www-form-urlencoded
|
|
||||||
|
|
||||||
xxx=4
|
|
||||||
;
|
|
||||||
|
|
||||||
[ "/blahXXXX" ] [
|
|
||||||
action-request-test-2 lf>crlf
|
|
||||||
[ read-request ] with-string-reader
|
|
||||||
request set
|
|
||||||
"/blah"
|
|
||||||
"action-2" get call-responder
|
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces
|
||||||
fry continuations locals ;
|
fry continuations locals ;
|
||||||
IN: http.server.actions
|
IN: http.server.actions
|
||||||
|
|
||||||
SYMBOL: +append-path
|
SYMBOL: +path+
|
||||||
|
|
||||||
SYMBOL: params
|
SYMBOL: params
|
||||||
|
|
||||||
|
|
@ -39,12 +39,15 @@ TUPLE: action init display submit get-params post-params ;
|
||||||
|
|
||||||
M: action call-responder ( path action -- response )
|
M: action call-responder ( path action -- response )
|
||||||
'[
|
'[
|
||||||
, ,
|
, [ CHAR: / = ] right-trim empty? [
|
||||||
[ +append-path associate request-params assoc-union params set ]
|
, action set
|
||||||
[ action set ] bi*
|
request-params params set
|
||||||
request get method>> {
|
request get method>> {
|
||||||
{ "GET" [ handle-get ] }
|
{ "GET" [ handle-get ] }
|
||||||
{ "HEAD" [ handle-get ] }
|
{ "HEAD" [ handle-get ] }
|
||||||
{ "POST" [ handle-post ] }
|
{ "POST" [ handle-post ] }
|
||||||
} case
|
} case
|
||||||
|
] [
|
||||||
|
<404>
|
||||||
|
] if
|
||||||
] with-exit-continuation ;
|
] with-exit-continuation ;
|
||||||
|
|
|
||||||
|
|
@ -60,7 +60,7 @@ M: user-saver dispose
|
||||||
|
|
||||||
: successful-login ( user -- response )
|
: successful-login ( user -- response )
|
||||||
logged-in-user sset
|
logged-in-user sset
|
||||||
post-login-url sget "" or f <permanent-redirect>
|
post-login-url sget "$login" or f <permanent-redirect>
|
||||||
f post-login-url sset ;
|
f post-login-url sset ;
|
||||||
|
|
||||||
:: <login-action> ( -- action )
|
:: <login-action> ( -- action )
|
||||||
|
|
@ -162,10 +162,12 @@ SYMBOL: previous-page
|
||||||
<action>
|
<action>
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
||||||
logged-in-user sget
|
logged-in-user sget
|
||||||
dup username>> "username" set-value
|
[ username>> "username" set-value ]
|
||||||
dup realname>> "realname" set-value
|
[ realname>> "realname" set-value ]
|
||||||
dup email>> "email" set-value
|
[ email>> "email" set-value ]
|
||||||
|
tri
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
[ form edit-form ] >>display
|
||||||
|
|
@ -190,6 +192,8 @@ SYMBOL: previous-page
|
||||||
"realname" value >>realname
|
"realname" value >>realname
|
||||||
"email" value >>email
|
"email" value >>email
|
||||||
|
|
||||||
|
drop
|
||||||
|
|
||||||
user-profile-changed? on
|
user-profile-changed? on
|
||||||
|
|
||||||
previous-page sget f <permanent-redirect>
|
previous-page sget f <permanent-redirect>
|
||||||
|
|
@ -329,7 +333,7 @@ SYMBOL: lost-password-from
|
||||||
<action>
|
<action>
|
||||||
[
|
[
|
||||||
f logged-in-user sset
|
f logged-in-user sset
|
||||||
"login" f <permanent-redirect>
|
"$login/login" f <permanent-redirect>
|
||||||
] >>submit ;
|
] >>submit ;
|
||||||
|
|
||||||
! ! ! Authentication logic
|
! ! ! Authentication logic
|
||||||
|
|
@ -340,7 +344,7 @@ C: <protected> protected
|
||||||
|
|
||||||
: show-login-page ( -- response )
|
: show-login-page ( -- response )
|
||||||
request get request-url post-login-url sset
|
request get request-url post-login-url sset
|
||||||
"login" f <permanent-redirect> ;
|
"$login/login" f <temporary-redirect> ;
|
||||||
|
|
||||||
M: protected call-responder ( path responder -- response )
|
M: protected call-responder ( path responder -- response )
|
||||||
logged-in-user sget dup [
|
logged-in-user sget dup [
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@ splitting kernel hashtables continuations ;
|
||||||
<request> "GET" >>method request set
|
<request> "GET" >>method request set
|
||||||
[
|
[
|
||||||
exit-continuation set
|
exit-continuation set
|
||||||
"xxx"
|
{ }
|
||||||
<action> [ [ "hello" print 123 ] show-final ] >>display
|
<action> [ [ "hello" print 123 ] show-final ] >>display
|
||||||
<callback-responder>
|
<callback-responder>
|
||||||
call-responder
|
call-responder
|
||||||
|
|
@ -31,7 +31,7 @@ splitting kernel hashtables continuations ;
|
||||||
[
|
[
|
||||||
exit-continuation set
|
exit-continuation set
|
||||||
<request> "GET" >>method request set
|
<request> "GET" >>method request set
|
||||||
"" "r" get call-responder
|
{ } "r" get call-responder
|
||||||
] callcc1
|
] callcc1
|
||||||
|
|
||||||
body>> first
|
body>> first
|
||||||
|
|
@ -44,7 +44,7 @@ splitting kernel hashtables continuations ;
|
||||||
|
|
||||||
[
|
[
|
||||||
exit-continuation set
|
exit-continuation set
|
||||||
"/"
|
{ }
|
||||||
"r" get call-responder
|
"r" get call-responder
|
||||||
] callcc1
|
] callcc1
|
||||||
|
|
||||||
|
|
@ -57,7 +57,7 @@ splitting kernel hashtables continuations ;
|
||||||
|
|
||||||
[
|
[
|
||||||
exit-continuation set
|
exit-continuation set
|
||||||
"/"
|
{ }
|
||||||
"r" get call-responder
|
"r" get call-responder
|
||||||
] callcc1
|
] callcc1
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,18 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: splitting kernel io sequences xmode.code2html accessors
|
||||||
|
http.server.components ;
|
||||||
|
IN: http.server.components.code
|
||||||
|
|
||||||
|
TUPLE: code-renderer < text-renderer mode ;
|
||||||
|
|
||||||
|
: <code-renderer> ( mode -- renderer )
|
||||||
|
code-renderer new-text-renderer
|
||||||
|
swap >>mode ;
|
||||||
|
|
||||||
|
M: code-renderer render-view*
|
||||||
|
[ string-lines ] [ mode>> value ] bi* htmlize-lines ;
|
||||||
|
|
||||||
|
: <code> ( id mode -- component )
|
||||||
|
swap <text>
|
||||||
|
swap <code-renderer> >>renderer ;
|
||||||
|
|
@ -336,3 +336,26 @@ TUPLE: list < component ;
|
||||||
<list-renderer> list swap new-component ;
|
<list-renderer> list swap new-component ;
|
||||||
|
|
||||||
M: list component-string drop ;
|
M: list component-string drop ;
|
||||||
|
|
||||||
|
! Choice
|
||||||
|
TUPLE: choice-renderer choices ;
|
||||||
|
|
||||||
|
C: <choice-renderer> choice-renderer
|
||||||
|
|
||||||
|
M: choice-renderer render-view*
|
||||||
|
drop write ;
|
||||||
|
|
||||||
|
M: choice-renderer render-edit*
|
||||||
|
<select swap =name select>
|
||||||
|
choices>> [
|
||||||
|
<option [ = [ "true" =selected ] when ] keep option>
|
||||||
|
write
|
||||||
|
</option>
|
||||||
|
] with each
|
||||||
|
</select> ;
|
||||||
|
|
||||||
|
TUPLE: choice < string ;
|
||||||
|
|
||||||
|
: <choice> ( id choices -- component )
|
||||||
|
swap choice new-string
|
||||||
|
swap <choice-renderer> >>renderer ;
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,9 @@
|
||||||
USING: http.server tools.test kernel namespaces accessors
|
USING: http.server tools.test kernel namespaces accessors
|
||||||
io http math sequences assocs ;
|
io http math sequences assocs arrays classes words ;
|
||||||
IN: http.server.tests
|
IN: http.server.tests
|
||||||
|
|
||||||
|
\ find-responder must-infer
|
||||||
|
|
||||||
[
|
[
|
||||||
<request>
|
<request>
|
||||||
"www.apple.com" >>host
|
"www.apple.com" >>host
|
||||||
|
|
@ -29,7 +31,9 @@ M: mock-responder call-responder
|
||||||
"text/plain" <content> ;
|
"text/plain" <content> ;
|
||||||
|
|
||||||
: check-dispatch ( tag path -- ? )
|
: check-dispatch ( tag path -- ? )
|
||||||
|
H{ } clone base-paths set
|
||||||
over off
|
over off
|
||||||
|
split-path
|
||||||
main-responder get call-responder
|
main-responder get call-responder
|
||||||
write-response get ;
|
write-response get ;
|
||||||
|
|
||||||
|
|
@ -44,11 +48,11 @@ M: mock-responder call-responder
|
||||||
main-responder set
|
main-responder set
|
||||||
|
|
||||||
[ "foo" ] [
|
[ "foo" ] [
|
||||||
"foo" main-responder get find-responder path>> nip
|
{ "foo" } main-responder get find-responder path>> nip
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "bar" ] [
|
[ "bar" ] [
|
||||||
"bar" main-responder get find-responder path>> nip
|
{ "bar" } main-responder get find-responder path>> nip
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [ "foo" "foo" check-dispatch ] unit-test
|
[ t ] [ "foo" "foo" check-dispatch ] unit-test
|
||||||
|
|
@ -60,14 +64,6 @@ M: mock-responder call-responder
|
||||||
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
|
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
|
||||||
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
|
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
|
||||||
<request>
|
|
||||||
"baz" >>path
|
|
||||||
request set
|
|
||||||
"baz" main-responder get call-responder
|
|
||||||
dup code>> 300 399 between? >r
|
|
||||||
header>> "location" swap at "baz/" tail? r> and
|
|
||||||
] unit-test
|
|
||||||
] with-scope
|
] with-scope
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
@ -77,3 +73,67 @@ M: mock-responder call-responder
|
||||||
|
|
||||||
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
|
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
|
||||||
] with-scope
|
] with-scope
|
||||||
|
|
||||||
|
! Make sure path for default responder isn't chopped
|
||||||
|
TUPLE: path-check-responder ;
|
||||||
|
|
||||||
|
C: <path-check-responder> path-check-responder
|
||||||
|
|
||||||
|
M: path-check-responder call-responder
|
||||||
|
drop
|
||||||
|
"text/plain" <content> swap >array >>body ;
|
||||||
|
|
||||||
|
[ { "c" } ] [
|
||||||
|
H{ } clone base-paths set
|
||||||
|
|
||||||
|
{ "b" "c" }
|
||||||
|
<dispatcher>
|
||||||
|
<dispatcher>
|
||||||
|
<path-check-responder> >>default
|
||||||
|
"b" add-responder
|
||||||
|
call-responder
|
||||||
|
body>>
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
! Test that "" dispatcher works with default>>
|
||||||
|
[ ] [
|
||||||
|
<dispatcher>
|
||||||
|
"" <mock-responder> "" add-responder
|
||||||
|
"bar" <mock-responder> "bar" add-responder
|
||||||
|
"baz" <mock-responder> >>default
|
||||||
|
main-responder set
|
||||||
|
|
||||||
|
[ t ] [ "" "" check-dispatch ] unit-test
|
||||||
|
[ f ] [ "" "quux" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "baz" "quux" check-dispatch ] unit-test
|
||||||
|
[ f ] [ "foo" "bar" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "bar" "bar" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "baz" "xxx" check-dispatch ] unit-test
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
TUPLE: funny-dispatcher < dispatcher ;
|
||||||
|
|
||||||
|
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||||
|
|
||||||
|
TUPLE: base-path-check-responder ;
|
||||||
|
|
||||||
|
C: <base-path-check-responder> base-path-check-responder
|
||||||
|
|
||||||
|
M: base-path-check-responder call-responder
|
||||||
|
2drop
|
||||||
|
"$funny-dispatcher" resolve-base-path
|
||||||
|
"text/plain" <content> swap >>body ;
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
<dispatcher>
|
||||||
|
<dispatcher>
|
||||||
|
<funny-dispatcher>
|
||||||
|
<base-path-check-responder> "c" add-responder
|
||||||
|
"b" add-responder
|
||||||
|
"a" add-responder
|
||||||
|
main-responder set
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ "/a/b/" ] [
|
||||||
|
"a/b/c" split-path main-responder get call-responder body>>
|
||||||
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -4,9 +4,11 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||||
threads http sequences prettyprint io.server logging calendar
|
threads http sequences prettyprint io.server logging calendar
|
||||||
html.elements accessors math.parser combinators.lib
|
html.elements accessors math.parser combinators.lib
|
||||||
tools.vocabs debugger html continuations random combinators
|
tools.vocabs debugger html continuations random combinators
|
||||||
destructors io.encodings.8-bit fry ;
|
destructors io.encodings.8-bit fry classes words ;
|
||||||
IN: http.server
|
IN: http.server
|
||||||
|
|
||||||
|
! path is a sequence of path component strings
|
||||||
|
|
||||||
GENERIC: call-responder ( path responder -- response )
|
GENERIC: call-responder ( path responder -- response )
|
||||||
|
|
||||||
: request-params ( -- assoc )
|
: request-params ( -- assoc )
|
||||||
|
|
@ -52,13 +54,39 @@ SYMBOL: 404-responder
|
||||||
|
|
||||||
[ <404> ] <trivial-responder> 404-responder set-global
|
[ <404> ] <trivial-responder> 404-responder set-global
|
||||||
|
|
||||||
|
SYMBOL: base-paths
|
||||||
|
|
||||||
|
: invert-slice ( slice -- slice' )
|
||||||
|
dup slice? [
|
||||||
|
[ seq>> ] [ from>> ] bi head-slice
|
||||||
|
] [
|
||||||
|
drop { }
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: add-base-path ( path dispatcher -- )
|
||||||
|
[ invert-slice ] [ class word-name ] bi*
|
||||||
|
base-paths get set-at ;
|
||||||
|
|
||||||
SYMBOL: link-hook
|
SYMBOL: link-hook
|
||||||
|
|
||||||
: modify-query ( query -- query )
|
: modify-query ( query -- query )
|
||||||
link-hook get [ ] or call ;
|
link-hook get [ ] or call ;
|
||||||
|
|
||||||
|
: base-path ( string -- path )
|
||||||
|
dup base-paths get at
|
||||||
|
[ ] [ "No such responder: " swap append throw ] ?if ;
|
||||||
|
|
||||||
|
: resolve-base-path ( string -- string' )
|
||||||
|
"$" ?head [
|
||||||
|
[
|
||||||
|
"/" split1 >r
|
||||||
|
base-path [ "/" % % ] each "/" %
|
||||||
|
r> %
|
||||||
|
] "" make
|
||||||
|
] when ;
|
||||||
|
|
||||||
: link>string ( url query -- url' )
|
: link>string ( url query -- url' )
|
||||||
modify-query (link>string) ;
|
[ resolve-base-path ] [ modify-query ] bi* (link>string) ;
|
||||||
|
|
||||||
: write-link ( url query -- )
|
: write-link ( url query -- )
|
||||||
link>string write ;
|
link>string write ;
|
||||||
|
|
@ -71,8 +99,9 @@ SYMBOL: form-hook
|
||||||
: absolute-redirect ( to query -- url )
|
: absolute-redirect ( to query -- url )
|
||||||
#! Same host.
|
#! Same host.
|
||||||
request get clone
|
request get clone
|
||||||
swap [ >>query ] when*
|
swap [ >>query ] when*
|
||||||
swap url-encode >>path
|
swap url-encode >>path
|
||||||
|
[ modify-query ] change-query
|
||||||
request-url ;
|
request-url ;
|
||||||
|
|
||||||
: replace-last-component ( path with -- path' )
|
: replace-last-component ( path with -- path' )
|
||||||
|
|
@ -82,13 +111,14 @@ SYMBOL: form-hook
|
||||||
request get clone
|
request get clone
|
||||||
swap [ >>query ] when*
|
swap [ >>query ] when*
|
||||||
swap [ '[ , replace-last-component ] change-path ] when*
|
swap [ '[ , replace-last-component ] change-path ] when*
|
||||||
dup query>> modify-query >>query
|
[ modify-query ] change-query
|
||||||
request-url ;
|
request-url ;
|
||||||
|
|
||||||
: derive-url ( to query -- url )
|
: derive-url ( to query -- url )
|
||||||
{
|
{
|
||||||
{ [ over "http://" head? ] [ link>string ] }
|
{ [ over "http://" head? ] [ link>string ] }
|
||||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||||
|
{ [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
|
||||||
[ relative-redirect ]
|
[ relative-redirect ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
@ -113,22 +143,17 @@ TUPLE: dispatcher default responders ;
|
||||||
: <dispatcher> ( -- dispatcher )
|
: <dispatcher> ( -- dispatcher )
|
||||||
dispatcher new-dispatcher ;
|
dispatcher new-dispatcher ;
|
||||||
|
|
||||||
: split-path ( path -- rest first )
|
|
||||||
[ CHAR: / = ] left-trim "/" split1 swap ;
|
|
||||||
|
|
||||||
: find-responder ( path dispatcher -- path responder )
|
: find-responder ( path dispatcher -- path responder )
|
||||||
over split-path pick responders>> at*
|
over empty? [
|
||||||
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
|
"" over responders>> at*
|
||||||
|
[ nip ] [ drop default>> ] if
|
||||||
: redirect-with-/ ( -- response )
|
] [
|
||||||
request get path>> "/" append f <permanent-redirect> ;
|
over first over responders>> at*
|
||||||
|
[ >r drop 1 tail-slice r> ] [ drop default>> ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
M: dispatcher call-responder ( path dispatcher -- response )
|
M: dispatcher call-responder ( path dispatcher -- response )
|
||||||
over [
|
[ add-base-path ] [ find-responder call-responder ] 2bi ;
|
||||||
find-responder call-responder
|
|
||||||
] [
|
|
||||||
2drop redirect-with-/
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
TUPLE: vhost-dispatcher default responders ;
|
TUPLE: vhost-dispatcher default responders ;
|
||||||
|
|
||||||
|
|
@ -142,15 +167,13 @@ TUPLE: vhost-dispatcher default responders ;
|
||||||
M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
||||||
find-vhost call-responder ;
|
find-vhost call-responder ;
|
||||||
|
|
||||||
: set-main ( dispatcher name -- dispatcher )
|
|
||||||
'[ , f <permanent-redirect> ] <trivial-responder>
|
|
||||||
>>default ;
|
|
||||||
|
|
||||||
: add-responder ( dispatcher responder path -- dispatcher )
|
: add-responder ( dispatcher responder path -- dispatcher )
|
||||||
pick responders>> set-at ;
|
pick responders>> set-at ;
|
||||||
|
|
||||||
: add-main-responder ( dispatcher responder path -- dispatcher )
|
: add-main-responder ( dispatcher responder path -- dispatcher )
|
||||||
[ add-responder ] keep set-main ;
|
[ add-responder drop ]
|
||||||
|
[ drop "" add-responder drop ]
|
||||||
|
[ 2drop ] 3tri ;
|
||||||
|
|
||||||
SYMBOL: main-responder
|
SYMBOL: main-responder
|
||||||
|
|
||||||
|
|
@ -197,11 +220,15 @@ SYMBOL: exit-continuation
|
||||||
: with-exit-continuation ( quot -- )
|
: with-exit-continuation ( quot -- )
|
||||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||||
|
|
||||||
|
: split-path ( string -- path )
|
||||||
|
"/" split [ empty? not ] subset ;
|
||||||
|
|
||||||
: do-request ( request -- response )
|
: do-request ( request -- response )
|
||||||
[
|
[
|
||||||
|
H{ } clone base-paths set
|
||||||
[ log-request ]
|
[ log-request ]
|
||||||
[ request set ]
|
[ request set ]
|
||||||
[ path>> main-responder get call-responder ] tri
|
[ path>> split-path main-responder get call-responder ] tri
|
||||||
[ <404> ] unless*
|
[ <404> ] unless*
|
||||||
] [
|
] [
|
||||||
[ \ do-request log-error ]
|
[ \ do-request log-error ]
|
||||||
|
|
|
||||||
|
|
@ -61,7 +61,7 @@ M: foo call-responder
|
||||||
<request>
|
<request>
|
||||||
"GET" >>method
|
"GET" >>method
|
||||||
request set
|
request set
|
||||||
"/etc" "manager" get call-responder
|
{ "etc" } "manager" get call-responder
|
||||||
response set
|
response set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
@ -76,7 +76,7 @@ M: foo call-responder
|
||||||
"id" get session-id-key set-query-param
|
"id" get session-id-key set-query-param
|
||||||
"/" >>path
|
"/" >>path
|
||||||
request set
|
request set
|
||||||
"/" "manager" get call-responder
|
{ } "manager" get call-responder
|
||||||
[ write-response-body drop ] with-string-writer
|
[ write-response-body drop ] with-string-writer
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
|
@ -96,7 +96,7 @@ M: foo call-responder
|
||||||
"GET" >>method
|
"GET" >>method
|
||||||
"/" >>path
|
"/" >>path
|
||||||
request set
|
request set
|
||||||
"/etc" "manager" get call-responder response set
|
{ "etc" } "manager" 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
|
||||||
response get
|
response get
|
||||||
] with-destructors
|
] with-destructors
|
||||||
|
|
@ -111,7 +111,7 @@ response set
|
||||||
"cookies" get >>cookies
|
"cookies" get >>cookies
|
||||||
"/" >>path
|
"/" >>path
|
||||||
request set
|
request set
|
||||||
"/" "manager" get call-responder
|
{ } "manager" get call-responder
|
||||||
[ write-response-body drop ] with-string-writer
|
[ write-response-body drop ] with-string-writer
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
|
|
@ -134,7 +134,7 @@ response set
|
||||||
request set
|
request set
|
||||||
|
|
||||||
[
|
[
|
||||||
"/" <exiting-action> <cookie-sessions>
|
{ } <exiting-action> <cookie-sessions>
|
||||||
call-responder
|
call-responder
|
||||||
] with-destructors response set
|
] with-destructors response set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -69,32 +69,24 @@ TUPLE: file-responder root hook special ;
|
||||||
swap '[ , directory. ] >>body ;
|
swap '[ , directory. ] >>body ;
|
||||||
|
|
||||||
: find-index ( filename -- path )
|
: find-index ( filename -- path )
|
||||||
{ "index.html" "index.fhtml" } [ append-path ] with map
|
"index.html" append-path dup exists? [ drop f ] unless ;
|
||||||
[ exists? ] find nip ;
|
|
||||||
|
|
||||||
: serve-directory ( filename -- response )
|
: serve-directory ( filename -- response )
|
||||||
dup "/" tail? [
|
request get path>> "/" tail? [
|
||||||
dup find-index
|
dup
|
||||||
[ serve-file ] [ list-directory ] ?if
|
find-index [ serve-file ] [ list-directory ] ?if
|
||||||
] [
|
] [
|
||||||
drop request get redirect-with-/
|
drop
|
||||||
|
request get path>> "/" append f <permanent-redirect>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: serve-object ( filename -- response )
|
: serve-object ( filename -- response )
|
||||||
serving-path dup exists? [
|
serving-path dup exists?
|
||||||
dup directory? [ serve-directory ] [ serve-file ] if
|
[ dup directory? [ serve-directory ] [ serve-file ] if ]
|
||||||
] [
|
[ drop <404> ]
|
||||||
drop <404>
|
if ;
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: file-responder call-responder ( path responder -- response )
|
M: file-responder call-responder ( path responder -- response )
|
||||||
file-responder set
|
file-responder set
|
||||||
dup [
|
".." over member?
|
||||||
".." over subseq? [
|
[ drop <400> ] [ "/" join serve-object ] if ;
|
||||||
drop <400>
|
|
||||||
] [
|
|
||||||
serve-object
|
|
||||||
] if
|
|
||||||
] [
|
|
||||||
drop redirect-with-/
|
|
||||||
] if ;
|
|
||||||
|
|
|
||||||
|
|
@ -104,7 +104,8 @@ SYMBOL: tags
|
||||||
: form-start-tag ( tag -- )
|
: form-start-tag ( tag -- )
|
||||||
<form
|
<form
|
||||||
"POST" =method
|
"POST" =method
|
||||||
tag-attrs print-attrs
|
[ "action" required-attr resolve-base-path =action ]
|
||||||
|
[ tag-attrs [ drop name-tag "action" = not ] assoc-subset print-attrs ] bi
|
||||||
form>
|
form>
|
||||||
hidden-form-field ;
|
hidden-form-field ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,21 +1,25 @@
|
||||||
! 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 io.files io.sockets
|
USING: accessors kernel sequences assocs io.files io.sockets
|
||||||
db.sqlite smtp namespaces db
|
namespaces db db.sqlite smtp
|
||||||
|
http.server
|
||||||
http.server.db
|
http.server.db
|
||||||
http.server.sessions
|
http.server.sessions
|
||||||
http.server.auth.login
|
http.server.auth.login
|
||||||
http.server.auth.providers.db
|
http.server.auth.providers.db
|
||||||
http.server.sessions.storage.db
|
http.server.sessions.storage.db
|
||||||
http.server.boilerplate
|
http.server.boilerplate
|
||||||
http.server.templating.chloe ;
|
http.server.templating.chloe
|
||||||
|
webapps.pastebin
|
||||||
|
webapps.planet
|
||||||
|
webapps.todo ;
|
||||||
IN: webapps.factor-website
|
IN: webapps.factor-website
|
||||||
|
|
||||||
|
: test-db "test.db" resource-path sqlite-db ;
|
||||||
|
|
||||||
: factor-template ( path -- template )
|
: factor-template ( path -- template )
|
||||||
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
|
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
|
||||||
|
|
||||||
: test-db "todo.db" resource-path sqlite-db ;
|
|
||||||
|
|
||||||
: <factor-boilerplate> ( responder -- responder' )
|
: <factor-boilerplate> ( responder -- responder' )
|
||||||
<login>
|
<login>
|
||||||
users-in-db >>users
|
users-in-db >>users
|
||||||
|
|
@ -28,11 +32,40 @@ IN: webapps.factor-website
|
||||||
sessions-in-db >>sessions
|
sessions-in-db >>sessions
|
||||||
test-db <db-persistence> ;
|
test-db <db-persistence> ;
|
||||||
|
|
||||||
|
: <pastebin-app> ( -- responder )
|
||||||
|
<pastebin> <factor-boilerplate> ;
|
||||||
|
|
||||||
|
: <planet-app> ( -- responder )
|
||||||
|
<planet-factor> <factor-boilerplate> ;
|
||||||
|
|
||||||
|
: <todo-app> ( -- responder )
|
||||||
|
<todo-list> <protected> <factor-boilerplate> ;
|
||||||
|
|
||||||
|
: init-factor-db ( -- )
|
||||||
|
test-db [
|
||||||
|
init-users-table
|
||||||
|
init-sessions-table
|
||||||
|
|
||||||
|
init-pastes-table
|
||||||
|
init-annotations-table
|
||||||
|
|
||||||
|
init-blog-table
|
||||||
|
|
||||||
|
init-todo-table
|
||||||
|
] with-db ;
|
||||||
|
|
||||||
|
: <factor-website> ( -- responder )
|
||||||
|
<dispatcher>
|
||||||
|
<todo-app> "todo" add-responder
|
||||||
|
<pastebin-app> "pastebin" add-responder
|
||||||
|
<planet-app> "planet" add-responder ;
|
||||||
|
|
||||||
: init-factor-website ( -- )
|
: init-factor-website ( -- )
|
||||||
"factorcode.org" 25 <inet> smtp-server set-global
|
"factorcode.org" 25 <inet> smtp-server set-global
|
||||||
"todo@factorcode.org" lost-password-from set-global
|
"todo@factorcode.org" lost-password-from set-global
|
||||||
|
|
||||||
test-db [
|
init-factor-db
|
||||||
init-sessions-table
|
|
||||||
init-users-table
|
<factor-website> main-responder set-global
|
||||||
] with-db ;
|
|
||||||
|
"planet" main-responder get responders>> at start-update-task ;
|
||||||
|
|
|
||||||
|
|
@ -10,6 +10,8 @@
|
||||||
<head>
|
<head>
|
||||||
<t:write-title />
|
<t:write-title />
|
||||||
|
|
||||||
|
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
|
||||||
|
|
||||||
<t:style>
|
<t:style>
|
||||||
body, button {
|
body, button {
|
||||||
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
|
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
|
||||||
|
|
@ -47,6 +49,18 @@
|
||||||
padding: 5px;
|
padding: 5px;
|
||||||
border: 1px solid #ccc;
|
border: 1px solid #ccc;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.big-field-label {
|
||||||
|
vertical-align: top;
|
||||||
|
}
|
||||||
|
|
||||||
|
.description {
|
||||||
|
border: 1px dashed #ccc;
|
||||||
|
background-color: #f5f5f5;
|
||||||
|
padding: 5px;
|
||||||
|
font-size: 150%;
|
||||||
|
color: #000000;
|
||||||
|
}
|
||||||
</t:style>
|
</t:style>
|
||||||
|
|
||||||
<t:write-style />
|
<t:write-style />
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,23 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<h2>Annotation: <t:view component="summary" /></h2>
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
|
||||||
|
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
|
||||||
|
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<div class="description">
|
||||||
|
<t:view component="contents" />
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<t:form action="$pastebin/delete-annotation" class="inline">
|
||||||
|
<t:edit component="id" />
|
||||||
|
<t:edit component="aid" />
|
||||||
|
<button class="link-button link">Delete Annotation</button>
|
||||||
|
</t:form>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>New Annotation</t:title>
|
||||||
|
|
||||||
|
<t:form action="$pastebin/annotate">
|
||||||
|
<t:edit component="id" />
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
||||||
|
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
|
||||||
|
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
|
||||||
|
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="contents" /></td></tr>
|
||||||
|
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
|
||||||
|
<tr>
|
||||||
|
<td></td>
|
||||||
|
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||||
|
</tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<input type="SUBMIT" value="Done" />
|
||||||
|
</t:form>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,23 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>New Paste</t:title>
|
||||||
|
|
||||||
|
<t:form action="$pastebin/new-paste">
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
||||||
|
<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
|
||||||
|
<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
|
||||||
|
<tr><th class="field-label big-field-label">Description: </th><td><t:edit component="contents" /></td></tr>
|
||||||
|
<tr><th class="field-label">Captcha: </th><td><t:edit component="captcha" /></td></tr>
|
||||||
|
<tr>
|
||||||
|
<td></td>
|
||||||
|
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
|
||||||
|
</tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<input type="SUBMIT" value="Submit" />
|
||||||
|
</t:form>
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>Pastebin</t:title>
|
||||||
|
|
||||||
|
<table width="100%">
|
||||||
|
<th align="left" width="50%">Summary:</th>
|
||||||
|
<th align="left" width="100">Paste by:</th>
|
||||||
|
<th align="left" width="200">Date:</th>
|
||||||
|
|
||||||
|
<t:summary component="pastes" />
|
||||||
|
</table>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,11 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<td><t:a href="view-paste" query="id"><t:view component="summary" /></t:a></td>
|
||||||
|
<td><t:view component="author" /></td>
|
||||||
|
<td><t:view component="date" /></td>
|
||||||
|
</tr>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,27 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>Pastebin</t:title>
|
||||||
|
|
||||||
|
<h2>Paste: <t:view component="summary" /></h2>
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th class="field-label">Author: </th><td><t:view component="author" /></td></tr>
|
||||||
|
<tr><th class="field-label">Mode: </th><td><t:view component="mode" /></td></tr>
|
||||||
|
<tr><th class="field-label">Date: </th><td><t:view component="date" /></td></tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<div class="description">
|
||||||
|
<t:view component="contents" />
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<t:form action="$pastebin/delete-paste" class="inline">
|
||||||
|
<t:edit component="id" />
|
||||||
|
<button class="link-button link">Delete Paste</button>
|
||||||
|
</t:form>
|
||||||
|
|
|
||||||
|
<t:a href="$pastebin/annotate" query="id">Annotate</t:a>
|
||||||
|
|
||||||
|
<t:view component="annotations" />
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
pre.code {
|
||||||
|
border:1px dashed #ccc;
|
||||||
|
background-color:#f5f5f5;
|
||||||
|
padding:5px;
|
||||||
|
font-size:150%;
|
||||||
|
color:#000000;
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,253 @@
|
||||||
|
USING: namespaces assocs sorting sequences kernel accessors
|
||||||
|
hashtables sequences.lib locals db.types db.tuples db
|
||||||
|
calendar calendar.format rss xml.writer
|
||||||
|
xmode.catalog
|
||||||
|
http.server
|
||||||
|
http.server.crud
|
||||||
|
http.server.actions
|
||||||
|
http.server.components
|
||||||
|
http.server.components.code
|
||||||
|
http.server.templating.chloe
|
||||||
|
http.server.boilerplate
|
||||||
|
http.server.validators
|
||||||
|
http.server.forms ;
|
||||||
|
IN: webapps.pastebin
|
||||||
|
|
||||||
|
: <mode> ( id -- component )
|
||||||
|
modes keys natural-sort <choice> ;
|
||||||
|
|
||||||
|
: pastebin-template ( name -- template )
|
||||||
|
"resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
|
||||||
|
|
||||||
|
TUPLE: paste id summary author mode date contents annotations captcha ;
|
||||||
|
|
||||||
|
paste "PASTE"
|
||||||
|
{
|
||||||
|
{ "id" "ID" INTEGER +native-id+ }
|
||||||
|
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "date" "DATE" DATETIME +not-null+ }
|
||||||
|
{ "contents" "CONTENTS" TEXT +not-null+ }
|
||||||
|
} define-persistent
|
||||||
|
|
||||||
|
: <paste> ( id -- paste )
|
||||||
|
paste new
|
||||||
|
swap >>id ;
|
||||||
|
|
||||||
|
: pastes ( -- pastes )
|
||||||
|
f <paste> select-tuples ;
|
||||||
|
|
||||||
|
TUPLE: annotation aid id summary author mode contents date captcha ;
|
||||||
|
|
||||||
|
annotation "ANNOTATION"
|
||||||
|
{
|
||||||
|
{ "aid" "AID" INTEGER +native-id+ }
|
||||||
|
{ "id" "ID" INTEGER +not-null+ }
|
||||||
|
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "date" "DATE" DATETIME +not-null+ }
|
||||||
|
{ "contents" "CONTENTS" TEXT +not-null+ }
|
||||||
|
} define-persistent
|
||||||
|
|
||||||
|
: <annotation> ( id aid -- annotation )
|
||||||
|
annotation new
|
||||||
|
swap >>aid
|
||||||
|
swap >>id ;
|
||||||
|
|
||||||
|
: fetch-annotations ( paste -- paste )
|
||||||
|
dup annotations>> [
|
||||||
|
dup id>> f <annotation> select-tuples >>annotations
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: <annotation-form> ( -- form )
|
||||||
|
"paste" <form>
|
||||||
|
"id" <integer>
|
||||||
|
hidden >>renderer
|
||||||
|
add-field
|
||||||
|
"aid" <integer>
|
||||||
|
hidden >>renderer
|
||||||
|
add-field
|
||||||
|
"annotation" pastebin-template >>view-template
|
||||||
|
"summary" <string> add-field
|
||||||
|
"author" <string> add-field
|
||||||
|
"mode" <mode> add-field
|
||||||
|
"contents" "mode" <code> add-field
|
||||||
|
"date" <date> add-field ;
|
||||||
|
|
||||||
|
: <new-annotation-form> ( -- form )
|
||||||
|
"paste" <form>
|
||||||
|
"new-annotation" pastebin-template >>edit-template
|
||||||
|
"id" <integer>
|
||||||
|
hidden >>renderer
|
||||||
|
t >>required add-field
|
||||||
|
"summary" <string>
|
||||||
|
t >>required add-field
|
||||||
|
"author" <string>
|
||||||
|
t >>required
|
||||||
|
add-field
|
||||||
|
"mode" <mode>
|
||||||
|
"factor" >>default
|
||||||
|
t >>required
|
||||||
|
add-field
|
||||||
|
"contents" "mode" <code>
|
||||||
|
t >>required add-field
|
||||||
|
"captcha" <captcha> add-field ;
|
||||||
|
|
||||||
|
: <paste-form> ( -- form )
|
||||||
|
"paste" <form>
|
||||||
|
"paste" pastebin-template >>view-template
|
||||||
|
"paste-summary" pastebin-template >>summary-template
|
||||||
|
"id" <integer>
|
||||||
|
hidden >>renderer add-field
|
||||||
|
"summary" <string> add-field
|
||||||
|
"author" <string> add-field
|
||||||
|
"mode" <mode> add-field
|
||||||
|
"date" <date> add-field
|
||||||
|
"contents" "mode" <code> add-field
|
||||||
|
"annotations" <annotation-form> +plain+ <list> add-field ;
|
||||||
|
|
||||||
|
: <new-paste-form> ( -- form )
|
||||||
|
"paste" <form>
|
||||||
|
"new-paste" pastebin-template >>edit-template
|
||||||
|
"summary" <string>
|
||||||
|
t >>required add-field
|
||||||
|
"author" <string>
|
||||||
|
t >>required add-field
|
||||||
|
"mode" <mode>
|
||||||
|
"factor" >>default
|
||||||
|
t >>required
|
||||||
|
add-field
|
||||||
|
"contents" "mode" <code>
|
||||||
|
t >>required add-field
|
||||||
|
"captcha" <captcha> add-field ;
|
||||||
|
|
||||||
|
: <paste-list-form> ( -- form )
|
||||||
|
"pastebin" <form>
|
||||||
|
"paste-list" pastebin-template >>view-template
|
||||||
|
"pastes" <paste-form> +plain+ <list> add-field ;
|
||||||
|
|
||||||
|
:: <paste-list-action> ( -- action )
|
||||||
|
[let | form [ <paste-list-form> ] |
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
blank-values
|
||||||
|
|
||||||
|
pastes "pastes" set-value
|
||||||
|
|
||||||
|
form view-form
|
||||||
|
] >>display
|
||||||
|
] ;
|
||||||
|
|
||||||
|
:: <annotate-action> ( form ctor next -- action )
|
||||||
|
<action>
|
||||||
|
{ { "id" [ v-number ] } } >>get-params
|
||||||
|
|
||||||
|
[
|
||||||
|
"id" get f ctor call
|
||||||
|
|
||||||
|
from-tuple form set-defaults
|
||||||
|
] >>init
|
||||||
|
|
||||||
|
[ form edit-form ] >>display
|
||||||
|
|
||||||
|
[
|
||||||
|
f f ctor call from-tuple
|
||||||
|
|
||||||
|
form validate-form
|
||||||
|
|
||||||
|
values-tuple insert-tuple
|
||||||
|
|
||||||
|
"id" value next <id-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
: pastebin-feed-entries ( -- entries )
|
||||||
|
pastes <reversed> 20 short head [
|
||||||
|
[ summary>> ]
|
||||||
|
[ "$pastebin/view-paste" swap id>> "id" associate link>string ]
|
||||||
|
[ date>> ] tri
|
||||||
|
f swap <entry>
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: pastebin-feed ( -- feed )
|
||||||
|
feed new
|
||||||
|
"Factor Pastebin" >>title
|
||||||
|
"http://paste.factorcode.org" >>link
|
||||||
|
pastebin-feed-entries >>entries ;
|
||||||
|
|
||||||
|
: <feed-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
"text/xml" <content>
|
||||||
|
[ pastebin-feed feed>xml write-xml ] >>body
|
||||||
|
] >>display ;
|
||||||
|
|
||||||
|
:: <view-paste-action> ( form ctor -- action )
|
||||||
|
<action>
|
||||||
|
{ { "id" [ v-number ] } } >>get-params
|
||||||
|
|
||||||
|
[ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
|
||||||
|
|
||||||
|
[ form view-form ] >>display ;
|
||||||
|
|
||||||
|
:: <delete-paste-action> ( ctor next -- action )
|
||||||
|
<action>
|
||||||
|
{ { "id" [ v-number ] } } >>post-params
|
||||||
|
|
||||||
|
[
|
||||||
|
"id" get ctor call delete-tuple
|
||||||
|
|
||||||
|
"id" get f <annotation> select-tuples [ delete-tuple ] each
|
||||||
|
|
||||||
|
next f <permanent-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
:: <delete-annotation-action> ( ctor next -- action )
|
||||||
|
<action>
|
||||||
|
{ { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
|
||||||
|
|
||||||
|
[
|
||||||
|
"id" get "aid" get ctor call delete-tuple
|
||||||
|
|
||||||
|
"id" get next <id-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
:: <new-paste-action> ( form ctor next -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
f ctor call from-tuple
|
||||||
|
|
||||||
|
form set-defaults
|
||||||
|
] >>init
|
||||||
|
|
||||||
|
[ form edit-form ] >>display
|
||||||
|
|
||||||
|
[
|
||||||
|
f ctor call from-tuple
|
||||||
|
|
||||||
|
form validate-form
|
||||||
|
|
||||||
|
values-tuple insert-tuple
|
||||||
|
|
||||||
|
"id" value next <id-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
TUPLE: pastebin < dispatcher ;
|
||||||
|
|
||||||
|
: <pastebin> ( -- responder )
|
||||||
|
pastebin new-dispatcher
|
||||||
|
<paste-list-action> "list" add-main-responder
|
||||||
|
<feed-action> "feed.xml" add-responder
|
||||||
|
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
|
||||||
|
[ <paste> ] "$pastebin/list" <delete-paste-action> "delete-paste" add-responder
|
||||||
|
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> "delete-annotation" add-responder
|
||||||
|
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
|
||||||
|
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
|
||||||
|
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
|
||||||
|
<boilerplate>
|
||||||
|
"pastebin" pastebin-template >>template ;
|
||||||
|
|
||||||
|
: init-pastes-table paste ensure-table ;
|
||||||
|
|
||||||
|
: init-annotations-table annotation ensure-table ;
|
||||||
|
|
@ -0,0 +1,29 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:atom title="Pastebin - Atom" href="$pastebin/feed.xml" />
|
||||||
|
|
||||||
|
<t:style include="resource:extra/webapps/pastebin/pastebin.css" />
|
||||||
|
|
||||||
|
<div class="navbar">
|
||||||
|
<t:a href="$pastebin/list">Pastes</t:a>
|
||||||
|
| <t:a href="$pastebin/new-paste">New Paste</t:a>
|
||||||
|
| <t:a href="$pastebin/feed.xml">Atom Feed</t:a>
|
||||||
|
|
||||||
|
<t:comment>
|
||||||
|
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||||
|
| <t:a href="$login/edit-profile">Edit Profile</t:a>
|
||||||
|
</t:if>
|
||||||
|
|
||||||
|
<t:form action="$login/logout" class="inline">
|
||||||
|
| <button type="submit" class="link-button link">Logout</button>
|
||||||
|
</t:form>
|
||||||
|
</t:comment>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<h1><t:write-title /></h1>
|
||||||
|
|
||||||
|
<t:call-next-template />
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -7,7 +7,8 @@
|
||||||
<t:summary component="blogroll" />
|
<t:summary component="blogroll" />
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
<t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
|
<t:a href="$planet-factor/admin/edit-blog">Add Blog</t:a>
|
||||||
|
| <t:a href="$planet-factor/admin/update">Update</t:a>
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
||||||
|
|
@ -2,6 +2,6 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
|
<t:a href="$planet-factor/admin/edit-blog" query="id"><t:view component="name" /></t:a>
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
|
|
||||||
<t:title>Edit Blog</t:title>
|
<t:title>Edit Blog</t:title>
|
||||||
|
|
||||||
<t:form action="edit-blog">
|
<t:form action="$planet-factor/admin/edit-blog">
|
||||||
|
|
||||||
<t:edit component="id" />
|
<t:edit component="id" />
|
||||||
|
|
||||||
|
|
@ -21,8 +21,8 @@
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Atom feed:</th>
|
<th class="field-label">Feed:</th>
|
||||||
<td><t:edit component="atom-url" /></td>
|
<td><t:edit component="feed-url" /></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
</table>
|
</table>
|
||||||
|
|
@ -31,9 +31,7 @@
|
||||||
|
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
||||||
<t:a href="view" query="id">View</t:a>
|
<t:form action="$planet-factor/admin/delete-blog" class="inline">
|
||||||
|
|
|
||||||
<t:form action="delete-blog" class="inline">
|
|
||||||
<t:edit component="id" />
|
<t:edit component="id" />
|
||||||
<button type="submit" class="link-button link">Delete</button>
|
<button type="submit" class="link-button link">Delete</button>
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
|
||||||
|
|
@ -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 sequences sorting locals math
|
USING: kernel accessors sequences sorting locals math
|
||||||
calendar alarms logging concurrency.combinators namespaces
|
calendar alarms logging concurrency.combinators namespaces
|
||||||
db.types db.tuples db
|
sequences.lib db.types db.tuples db
|
||||||
rss xml.writer
|
rss xml.writer
|
||||||
http.server
|
http.server
|
||||||
http.server.crud
|
http.server.crud
|
||||||
|
|
@ -11,8 +11,7 @@ http.server.actions
|
||||||
http.server.boilerplate
|
http.server.boilerplate
|
||||||
http.server.templating.chloe
|
http.server.templating.chloe
|
||||||
http.server.components
|
http.server.components
|
||||||
http.server.auth.login
|
http.server.auth.login ;
|
||||||
webapps.factor-website ;
|
|
||||||
IN: webapps.planet
|
IN: webapps.planet
|
||||||
|
|
||||||
TUPLE: planet-factor < dispatcher postings ;
|
TUPLE: planet-factor < dispatcher postings ;
|
||||||
|
|
@ -20,7 +19,7 @@ TUPLE: planet-factor < dispatcher postings ;
|
||||||
: planet-template ( name -- template )
|
: planet-template ( name -- template )
|
||||||
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
|
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
|
||||||
|
|
||||||
TUPLE: blog id name www-url atom-url ;
|
TUPLE: blog id name www-url feed-url ;
|
||||||
|
|
||||||
M: blog link-title name>> ;
|
M: blog link-title name>> ;
|
||||||
|
|
||||||
|
|
@ -31,7 +30,7 @@ blog "BLOGS"
|
||||||
{ "id" "ID" INTEGER +native-id+ }
|
{ "id" "ID" INTEGER +native-id+ }
|
||||||
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
|
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||||
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
|
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
|
||||||
{ "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
|
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
|
||||||
} define-persistent
|
} define-persistent
|
||||||
|
|
||||||
: init-blog-table blog ensure-table ;
|
: init-blog-table blog ensure-table ;
|
||||||
|
|
@ -54,7 +53,6 @@ blog "BLOGS"
|
||||||
: <blog-form> ( -- form )
|
: <blog-form> ( -- form )
|
||||||
"blog" <form>
|
"blog" <form>
|
||||||
"edit-blog" planet-template >>edit-template
|
"edit-blog" planet-template >>edit-template
|
||||||
"view-blog" planet-template >>view-template
|
|
||||||
"blog-admin-link" planet-template >>summary-template
|
"blog-admin-link" planet-template >>summary-template
|
||||||
"id" <integer>
|
"id" <integer>
|
||||||
hidden >>renderer
|
hidden >>renderer
|
||||||
|
|
@ -65,7 +63,7 @@ blog "BLOGS"
|
||||||
"www-url" <url>
|
"www-url" <url>
|
||||||
t >>required
|
t >>required
|
||||||
add-field
|
add-field
|
||||||
"atom-url" <url>
|
"feed-url" <url>
|
||||||
t >>required
|
t >>required
|
||||||
add-field ;
|
add-field ;
|
||||||
|
|
||||||
|
|
@ -106,14 +104,11 @@ blog "BLOGS"
|
||||||
] >>display
|
] >>display
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: safe-head ( seq n -- seq' )
|
|
||||||
over length min head ;
|
|
||||||
|
|
||||||
:: planet-feed ( planet -- feed )
|
:: planet-feed ( planet -- feed )
|
||||||
feed new
|
feed new
|
||||||
"[ planet-factor ]" >>title
|
"Planet Factor" >>title
|
||||||
"http://planet.factorcode.org" >>link
|
"http://planet.factorcode.org" >>link
|
||||||
planet postings>> 16 safe-head >>entries ;
|
planet postings>> 16 short head >>entries ;
|
||||||
|
|
||||||
:: <feed-action> ( planet -- action )
|
:: <feed-action> ( planet -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
@ -132,7 +127,7 @@ blog "BLOGS"
|
||||||
|
|
||||||
: fetch-blogroll ( blogroll -- entries )
|
: fetch-blogroll ( blogroll -- entries )
|
||||||
dup
|
dup
|
||||||
[ atom-url>> fetch-feed ] parallel-map
|
[ feed-url>> fetch-feed ] parallel-map
|
||||||
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
|
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
|
||||||
|
|
||||||
: sort-entries ( entries -- entries' )
|
: sort-entries ( entries -- entries' )
|
||||||
|
|
@ -140,7 +135,7 @@ blog "BLOGS"
|
||||||
|
|
||||||
: update-cached-postings ( planet -- )
|
: update-cached-postings ( planet -- )
|
||||||
"webapps.planet" [
|
"webapps.planet" [
|
||||||
blogroll fetch-blogroll sort-entries 8 safe-head
|
blogroll fetch-blogroll sort-entries 8 short head
|
||||||
>>postings drop
|
>>postings drop
|
||||||
] with-logging ;
|
] with-logging ;
|
||||||
|
|
||||||
|
|
@ -157,32 +152,20 @@ blog "BLOGS"
|
||||||
<dispatcher>
|
<dispatcher>
|
||||||
planet-factor <edit-blogroll-action> >>default
|
planet-factor <edit-blogroll-action> >>default
|
||||||
|
|
||||||
|
planet-factor <update-action> "update" add-responder
|
||||||
|
|
||||||
! Administrative CRUD
|
! Administrative CRUD
|
||||||
blog-ctor "" <delete-action> "delete-blog" add-responder
|
blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
|
||||||
blog-form blog-ctor <view-action> "view-blog" add-responder
|
blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
|
||||||
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
|
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: <planet-factor> ( -- responder )
|
: <planet-factor> ( -- responder )
|
||||||
planet-factor new-dispatcher
|
planet-factor new-dispatcher
|
||||||
dup <planet-action> >>default
|
dup <planet-action> "list" add-main-responder
|
||||||
dup <feed-action> "feed.xml" add-responder
|
dup <feed-action> "feed.xml" add-responder
|
||||||
dup <update-action> "update" add-responder
|
|
||||||
dup <planet-factor-admin> <protected> "admin" add-responder
|
dup <planet-factor-admin> <protected> "admin" add-responder
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
"planet" planet-template >>template ;
|
"planet" planet-template >>template ;
|
||||||
|
|
||||||
: <planet-app> ( -- responder )
|
|
||||||
<planet-factor> <factor-boilerplate> ;
|
|
||||||
|
|
||||||
: start-update-task ( planet -- )
|
: start-update-task ( planet -- )
|
||||||
[ update-cached-postings ] curry 10 minutes every drop ;
|
[ update-cached-postings ] curry 10 minutes every drop ;
|
||||||
|
|
||||||
: init-planet ( -- )
|
|
||||||
test-db [
|
|
||||||
init-blog-table
|
|
||||||
] with-db
|
|
||||||
|
|
||||||
<dispatcher>
|
|
||||||
<planet-app> "planet" add-responder
|
|
||||||
main-responder set-global ;
|
|
||||||
|
|
|
||||||
|
|
@ -3,22 +3,21 @@
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:comment>
|
<t:comment>
|
||||||
<t:atom title="Planet Factor - Atom" href="feed.xml" />
|
<t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
|
||||||
</t:comment>
|
</t:comment>
|
||||||
<t:style include="resource:extra/webapps/planet/planet.css" />
|
<t:style include="resource:extra/webapps/planet/planet.css" />
|
||||||
|
|
||||||
<div class="navbar">
|
<div class="navbar">
|
||||||
<t:a href="list">Front Page</t:a>
|
<t:a href="$planet-factor/list">Front Page</t:a>
|
||||||
| <t:a href="feed.xml">Atom Feed</t:a>
|
| <t:a href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||||
|
| <t:a href="$planet-factor/admin">Admin</t:a>
|
||||||
| <t:a href="admin">Admin</t:a>
|
|
||||||
|
|
||||||
<t:comment>
|
<t:comment>
|
||||||
<t:if code="http.server.auth.login:allow-edit-profile?">
|
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||||
| <t:a href="edit-profile">Edit Profile</t:a>
|
| <t:a href="$login/edit-profile">Edit Profile</t:a>
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
<t:form action="logout" class="inline">
|
<t:form action="$login/logout" class="inline">
|
||||||
| <button type="submit" class="link-button link">Logout</button>
|
| <button type="submit" class="link-button link">Logout</button>
|
||||||
</t:form>
|
</t:form>
|
||||||
</t:comment>
|
</t:comment>
|
||||||
|
|
|
||||||
|
|
@ -1,41 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
|
||||||
|
|
||||||
<t:title>View Blog</t:title>
|
|
||||||
|
|
||||||
<table>
|
|
||||||
|
|
||||||
<tr>
|
|
||||||
<th class="field-label">Blog name:</th>
|
|
||||||
<td><t:view component="name" /></td>
|
|
||||||
</tr>
|
|
||||||
|
|
||||||
<tr>
|
|
||||||
<th class="field-label">Home page:</th>
|
|
||||||
<td>
|
|
||||||
<t:a value="www-url">
|
|
||||||
<t:view component="www-url" />
|
|
||||||
</t:a>
|
|
||||||
</td>
|
|
||||||
</tr>
|
|
||||||
|
|
||||||
<tr>
|
|
||||||
<th class="field-label">Atom feed:</th>
|
|
||||||
<td>
|
|
||||||
<t:a value="atom-url">
|
|
||||||
<t:view component="atom-url" />
|
|
||||||
</t:a>
|
|
||||||
</td>
|
|
||||||
</tr>
|
|
||||||
|
|
||||||
</table>
|
|
||||||
|
|
||||||
<t:a href="edit-blog" query="id">Edit</t:a>
|
|
||||||
|
|
|
||||||
<t:form action="delete-blog" class="inline">
|
|
||||||
<t:edit component="id" />
|
|
||||||
<button type="submit" class="link-button link">Delete</button>
|
|
||||||
</t:form>
|
|
||||||
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -4,21 +4,21 @@
|
||||||
|
|
||||||
<t:title>Edit Item</t:title>
|
<t:title>Edit Item</t:title>
|
||||||
|
|
||||||
<t:form action="edit">
|
<t:form action="$todo-list/edit">
|
||||||
<t:edit component="id" />
|
<t:edit component="id" />
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
|
||||||
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
|
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
|
||||||
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
|
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
|
||||||
</table>
|
</table>
|
||||||
|
|
||||||
<input type="SUBMIT" value="Done" />
|
<input type="SUBMIT" value="Done" />
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
||||||
<t:a href="view" query="id">View</t:a>
|
<t:a href="$todo-list/view" query="id">View</t:a>
|
||||||
|
|
|
|
||||||
<t:form action="delete" class="inline">
|
<t:form action="$todo-list/delete" class="inline">
|
||||||
<t:edit component="id" />
|
<t:edit component="id" />
|
||||||
<button type="submit" class="link-button link">Delete</button>
|
<button type="submit" class="link-button link">Delete</button>
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
|
||||||
|
|
@ -10,10 +10,10 @@
|
||||||
<t:view component="priority" />
|
<t:view component="priority" />
|
||||||
</td>
|
</td>
|
||||||
<td>
|
<td>
|
||||||
<t:a href="view" query="id">View</t:a>
|
<t:a href="$todo-list/view" query="id">View</t:a>
|
||||||
</td>
|
</td>
|
||||||
<td>
|
<td>
|
||||||
<t:a href="edit" query="id">Edit</t:a>
|
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
||||||
</td>
|
</td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,3 @@
|
||||||
.big-field-label {
|
|
||||||
vertical-align: top;
|
|
||||||
}
|
|
||||||
|
|
||||||
.description {
|
|
||||||
border: 1px dashed #ccc;
|
|
||||||
background-color: #f5f5f5;
|
|
||||||
padding: 5px;
|
|
||||||
font-size: 150%;
|
|
||||||
color: #000000;
|
|
||||||
}
|
|
||||||
|
|
||||||
pre {
|
pre {
|
||||||
font-size: 75%;
|
font-size: 75%;
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -7,8 +7,7 @@ http.server.forms http.server.templating.chloe
|
||||||
http.server.boilerplate http.server.crud http.server.auth
|
http.server.boilerplate http.server.crud http.server.auth
|
||||||
http.server.actions http.server.db
|
http.server.actions http.server.db
|
||||||
http.server.auth.login
|
http.server.auth.login
|
||||||
http.server
|
http.server ;
|
||||||
webapps.factor-website ;
|
|
||||||
IN: webapps.todo
|
IN: webapps.todo
|
||||||
|
|
||||||
TUPLE: todo uid id priority summary description ;
|
TUPLE: todo uid id priority summary description ;
|
||||||
|
|
@ -58,29 +57,17 @@ todo "TODO"
|
||||||
"list" <todo-form> +plain+ <list>
|
"list" <todo-form> +plain+ <list>
|
||||||
add-field ;
|
add-field ;
|
||||||
|
|
||||||
TUPLE: todo-responder < dispatcher ;
|
TUPLE: todo-list < dispatcher ;
|
||||||
|
|
||||||
:: <todo-responder> ( -- responder )
|
:: <todo-list> ( -- responder )
|
||||||
[let | todo-form [ <todo-form> ]
|
[let | todo-form [ <todo-form> ]
|
||||||
list-form [ <todo-list-form> ]
|
list-form [ <todo-list-form> ]
|
||||||
ctor [ [ <todo> ] ] |
|
ctor [ [ <todo> ] ] |
|
||||||
todo-responder new-dispatcher
|
todo-list new-dispatcher
|
||||||
list-form ctor <list-action> "list" add-main-responder
|
list-form ctor <list-action> "list" add-main-responder
|
||||||
todo-form ctor <view-action> "view" add-responder
|
todo-form ctor <view-action> "view" add-responder
|
||||||
todo-form ctor "view" <edit-action> "edit" add-responder
|
todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
|
||||||
ctor "list" <delete-action> "delete" add-responder
|
ctor "$todo-list/list" <delete-action> "delete" add-responder
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
"todo" todo-template >>template
|
"todo" todo-template >>template
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: <todo-app> ( -- responder )
|
|
||||||
<todo-responder> <protected> <factor-boilerplate> ;
|
|
||||||
|
|
||||||
: init-todo ( -- )
|
|
||||||
test-db [
|
|
||||||
init-todo-table
|
|
||||||
] with-db
|
|
||||||
|
|
||||||
<dispatcher>
|
|
||||||
<todo-app> "todo" add-responder
|
|
||||||
main-responder set-global ;
|
|
||||||
|
|
|
||||||
|
|
@ -4,17 +4,15 @@
|
||||||
|
|
||||||
<t:style include="resource:extra/webapps/todo/todo.css" />
|
<t:style include="resource:extra/webapps/todo/todo.css" />
|
||||||
|
|
||||||
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
|
|
||||||
|
|
||||||
<div class="navbar">
|
<div class="navbar">
|
||||||
<t:a href="list">List Items</t:a>
|
<t:a href="$todo-list/list">List Items</t:a>
|
||||||
| <t:a href="edit">Add Item</t:a>
|
| <t:a href="$todo-list/edit">Add Item</t:a>
|
||||||
|
|
||||||
<t:if code="http.server.auth.login:allow-edit-profile?">
|
<t:if code="http.server.auth.login:allow-edit-profile?">
|
||||||
| <t:a href="edit-profile">Edit Profile</t:a>
|
| <t:a href="$login/edit-profile">Edit Profile</t:a>
|
||||||
</t:if>
|
</t:if>
|
||||||
|
|
||||||
<t:form action="logout" class="inline">
|
<t:form action="$login/logout" class="inline">
|
||||||
| <button type="submit" class="link-button link">Logout</button>
|
| <button type="submit" class="link-button link">Logout</button>
|
||||||
</t:form>
|
</t:form>
|
||||||
</div>
|
</div>
|
||||||
|
|
|
||||||
|
|
@ -13,9 +13,9 @@
|
||||||
<t:view component="description" />
|
<t:view component="description" />
|
||||||
</div>
|
</div>
|
||||||
|
|
||||||
<t:a href="edit" query="id">Edit</t:a>
|
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
||||||
|
|
|
|
||||||
<t:form action="delete" class="inline">
|
<t:form action="$todo-list/delete" class="inline">
|
||||||
<t:edit component="id" />
|
<t:edit component="id" />
|
||||||
<button class="link-button link">Delete</button>
|
<button class="link-button link">Delete</button>
|
||||||
</t:form>
|
</t:form>
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue