Improved HTTP server dispatcher
Slava Pestov
parent
4f7d7e3e0c
commit
a8e8b05339
|
|
@ -133,16 +133,20 @@ read-response-test-1' 1array [
|
|||
] unit-test
|
||||
|
||||
! Live-fire exercise
|
||||
USING: http.server http.server.static http.server.actions
|
||||
http.client io.server io.files io accessors namespaces threads
|
||||
USING: http.server http.server.static http.server.sessions
|
||||
http.server.actions http.server.auth.login http.client
|
||||
io.server io.files io accessors namespaces threads
|
||||
io.encodings.ascii ;
|
||||
|
||||
: add-quit-action
|
||||
<action>
|
||||
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
|
||||
"quit" add-responder ;
|
||||
|
||||
[ ] [
|
||||
[
|
||||
<dispatcher>
|
||||
<action>
|
||||
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
|
||||
"quit" add-responder
|
||||
add-quit-action
|
||||
<dispatcher>
|
||||
"extra/http/test" resource-path <static> >>default
|
||||
"nested" add-responder
|
||||
|
|
@ -176,3 +180,51 @@ io.encodings.ascii ;
|
|||
[ "Goodbye" ] [
|
||||
"http://localhost:1237/quit" http-get
|
||||
] 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
|
||||
tools.test math math.parser multiline namespaces http
|
||||
io.streams.string http.server sequences splitting accessors ;
|
||||
IN: http.server.actions.tests
|
||||
|
||||
[
|
||||
"a" [ v-number ] { { "a" "123" } } validate-param
|
||||
|
|
@ -25,27 +25,5 @@ blah
|
|||
action-request-test-1 lf>crlf
|
||||
[ read-request ] with-string-reader
|
||||
request set
|
||||
"/blah"
|
||||
"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
|
||||
{ } "action-1" get call-responder
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces
|
|||
fry continuations locals ;
|
||||
IN: http.server.actions
|
||||
|
||||
SYMBOL: +append-path
|
||||
SYMBOL: +path+
|
||||
|
||||
SYMBOL: params
|
||||
|
||||
|
|
@ -39,12 +39,15 @@ TUPLE: action init display submit get-params post-params ;
|
|||
|
||||
M: action call-responder ( path action -- response )
|
||||
'[
|
||||
, ,
|
||||
[ +append-path associate request-params assoc-union params set ]
|
||||
[ action set ] bi*
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
, [ CHAR: / = ] right-trim empty? [
|
||||
, action set
|
||||
request-params params set
|
||||
request get method>> {
|
||||
{ "GET" [ handle-get ] }
|
||||
{ "HEAD" [ handle-get ] }
|
||||
{ "POST" [ handle-post ] }
|
||||
} case
|
||||
] [
|
||||
<404>
|
||||
] if
|
||||
] with-exit-continuation ;
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ M: user-saver dispose
|
|||
|
||||
: successful-login ( user -- response )
|
||||
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 ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
|
|
@ -162,10 +162,12 @@ SYMBOL: previous-page
|
|||
<action>
|
||||
[
|
||||
blank-values
|
||||
|
||||
logged-in-user sget
|
||||
dup username>> "username" set-value
|
||||
dup realname>> "realname" set-value
|
||||
dup email>> "email" set-value
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
|
||||
[ form edit-form ] >>display
|
||||
|
|
@ -190,6 +192,8 @@ SYMBOL: previous-page
|
|||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
drop
|
||||
|
||||
user-profile-changed? on
|
||||
|
||||
previous-page sget f <permanent-redirect>
|
||||
|
|
@ -329,7 +333,7 @@ SYMBOL: lost-password-from
|
|||
<action>
|
||||
[
|
||||
f logged-in-user sset
|
||||
"login" f <permanent-redirect>
|
||||
"$login/login" f <permanent-redirect>
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
|
|
@ -340,7 +344,7 @@ C: <protected> protected
|
|||
|
||||
: show-login-page ( -- response )
|
||||
request get request-url post-login-url sset
|
||||
"login" f <permanent-redirect> ;
|
||||
"$login/login" f <temporary-redirect> ;
|
||||
|
||||
M: protected call-responder ( path responder -- response )
|
||||
logged-in-user sget dup [
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ splitting kernel hashtables continuations ;
|
|||
<request> "GET" >>method request set
|
||||
[
|
||||
exit-continuation set
|
||||
"xxx"
|
||||
{ }
|
||||
<action> [ [ "hello" print 123 ] show-final ] >>display
|
||||
<callback-responder>
|
||||
call-responder
|
||||
|
|
@ -31,7 +31,7 @@ splitting kernel hashtables continuations ;
|
|||
[
|
||||
exit-continuation set
|
||||
<request> "GET" >>method request set
|
||||
"" "r" get call-responder
|
||||
{ } "r" get call-responder
|
||||
] callcc1
|
||||
|
||||
body>> first
|
||||
|
|
@ -44,7 +44,7 @@ splitting kernel hashtables continuations ;
|
|||
|
||||
[
|
||||
exit-continuation set
|
||||
"/"
|
||||
{ }
|
||||
"r" get call-responder
|
||||
] callcc1
|
||||
|
||||
|
|
@ -57,7 +57,7 @@ splitting kernel hashtables continuations ;
|
|||
|
||||
[
|
||||
exit-continuation set
|
||||
"/"
|
||||
{ }
|
||||
"r" get call-responder
|
||||
] callcc1
|
||||
] 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 ;
|
||||
|
||||
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
|
||||
io http math sequences assocs ;
|
||||
io http math sequences assocs arrays classes words ;
|
||||
IN: http.server.tests
|
||||
|
||||
\ find-responder must-infer
|
||||
|
||||
[
|
||||
<request>
|
||||
"www.apple.com" >>host
|
||||
|
|
@ -29,7 +31,9 @@ M: mock-responder call-responder
|
|||
"text/plain" <content> ;
|
||||
|
||||
: check-dispatch ( tag path -- ? )
|
||||
H{ } clone base-paths set
|
||||
over off
|
||||
split-path
|
||||
main-responder get call-responder
|
||||
write-response get ;
|
||||
|
||||
|
|
@ -44,11 +48,11 @@ M: mock-responder call-responder
|
|||
main-responder set
|
||||
|
||||
[ "foo" ] [
|
||||
"foo" main-responder get find-responder path>> nip
|
||||
{ "foo" } main-responder get find-responder path>> nip
|
||||
] unit-test
|
||||
|
||||
[ "bar" ] [
|
||||
"bar" main-responder get find-responder path>> nip
|
||||
{ "bar" } main-responder get find-responder path>> nip
|
||||
] 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 ] [
|
||||
<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
|
||||
|
||||
[
|
||||
|
|
@ -77,3 +73,67 @@ M: mock-responder call-responder
|
|||
|
||||
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
|
||||
] 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
|
||||
html.elements accessors math.parser combinators.lib
|
||||
tools.vocabs debugger html continuations random combinators
|
||||
destructors io.encodings.8-bit fry ;
|
||||
destructors io.encodings.8-bit fry classes words ;
|
||||
IN: http.server
|
||||
|
||||
! path is a sequence of path component strings
|
||||
|
||||
GENERIC: call-responder ( path responder -- response )
|
||||
|
||||
: request-params ( -- assoc )
|
||||
|
|
@ -52,13 +54,39 @@ SYMBOL: 404-responder
|
|||
|
||||
[ <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
|
||||
|
||||
: modify-query ( query -- query )
|
||||
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' )
|
||||
modify-query (link>string) ;
|
||||
[ resolve-base-path ] [ modify-query ] bi* (link>string) ;
|
||||
|
||||
: write-link ( url query -- )
|
||||
link>string write ;
|
||||
|
|
@ -71,8 +99,9 @@ SYMBOL: form-hook
|
|||
: absolute-redirect ( to query -- url )
|
||||
#! Same host.
|
||||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap url-encode >>path
|
||||
swap [ >>query ] when*
|
||||
swap url-encode >>path
|
||||
[ modify-query ] change-query
|
||||
request-url ;
|
||||
|
||||
: replace-last-component ( path with -- path' )
|
||||
|
|
@ -82,13 +111,14 @@ SYMBOL: form-hook
|
|||
request get clone
|
||||
swap [ >>query ] when*
|
||||
swap [ '[ , replace-last-component ] change-path ] when*
|
||||
dup query>> modify-query >>query
|
||||
[ modify-query ] change-query
|
||||
request-url ;
|
||||
|
||||
: derive-url ( to query -- url )
|
||||
{
|
||||
{ [ over "http://" head? ] [ link>string ] }
|
||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||
{ [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
|
||||
[ relative-redirect ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -113,22 +143,17 @@ TUPLE: dispatcher default responders ;
|
|||
: <dispatcher> ( -- dispatcher )
|
||||
dispatcher new-dispatcher ;
|
||||
|
||||
: split-path ( path -- rest first )
|
||||
[ CHAR: / = ] left-trim "/" split1 swap ;
|
||||
|
||||
: find-responder ( path dispatcher -- path responder )
|
||||
over split-path pick responders>> at*
|
||||
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
|
||||
|
||||
: redirect-with-/ ( -- response )
|
||||
request get path>> "/" append f <permanent-redirect> ;
|
||||
over empty? [
|
||||
"" over responders>> at*
|
||||
[ nip ] [ drop default>> ] if
|
||||
] [
|
||||
over first over responders>> at*
|
||||
[ >r drop 1 tail-slice r> ] [ drop default>> ] if
|
||||
] if ;
|
||||
|
||||
M: dispatcher call-responder ( path dispatcher -- response )
|
||||
over [
|
||||
find-responder call-responder
|
||||
] [
|
||||
2drop redirect-with-/
|
||||
] if ;
|
||||
[ add-base-path ] [ find-responder call-responder ] 2bi ;
|
||||
|
||||
TUPLE: vhost-dispatcher default responders ;
|
||||
|
||||
|
|
@ -142,15 +167,13 @@ TUPLE: vhost-dispatcher default responders ;
|
|||
M: vhost-dispatcher call-responder ( path dispatcher -- response )
|
||||
find-vhost call-responder ;
|
||||
|
||||
: set-main ( dispatcher name -- dispatcher )
|
||||
'[ , f <permanent-redirect> ] <trivial-responder>
|
||||
>>default ;
|
||||
|
||||
: add-responder ( dispatcher responder path -- dispatcher )
|
||||
pick responders>> set-at ;
|
||||
|
||||
: add-main-responder ( dispatcher responder path -- dispatcher )
|
||||
[ add-responder ] keep set-main ;
|
||||
[ add-responder drop ]
|
||||
[ drop "" add-responder drop ]
|
||||
[ 2drop ] 3tri ;
|
||||
|
||||
SYMBOL: main-responder
|
||||
|
||||
|
|
@ -197,11 +220,15 @@ SYMBOL: exit-continuation
|
|||
: with-exit-continuation ( quot -- )
|
||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
||||
: split-path ( string -- path )
|
||||
"/" split [ empty? not ] subset ;
|
||||
|
||||
: do-request ( request -- response )
|
||||
[
|
||||
H{ } clone base-paths set
|
||||
[ log-request ]
|
||||
[ request set ]
|
||||
[ path>> main-responder get call-responder ] tri
|
||||
[ path>> split-path main-responder get call-responder ] tri
|
||||
[ <404> ] unless*
|
||||
] [
|
||||
[ \ do-request log-error ]
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ M: foo call-responder
|
|||
<request>
|
||||
"GET" >>method
|
||||
request set
|
||||
"/etc" "manager" get call-responder
|
||||
{ "etc" } "manager" get call-responder
|
||||
response set
|
||||
] unit-test
|
||||
|
||||
|
|
@ -76,7 +76,7 @@ M: foo call-responder
|
|||
"id" get session-id-key set-query-param
|
||||
"/" >>path
|
||||
request set
|
||||
"/" "manager" get call-responder
|
||||
{ } "manager" get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -96,7 +96,7 @@ M: foo call-responder
|
|||
"GET" >>method
|
||||
"/" >>path
|
||||
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
|
||||
response get
|
||||
] with-destructors
|
||||
|
|
@ -111,7 +111,7 @@ response set
|
|||
"cookies" get >>cookies
|
||||
"/" >>path
|
||||
request set
|
||||
"/" "manager" get call-responder
|
||||
{ } "manager" get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -134,7 +134,7 @@ response set
|
|||
request set
|
||||
|
||||
[
|
||||
"/" <exiting-action> <cookie-sessions>
|
||||
{ } <exiting-action> <cookie-sessions>
|
||||
call-responder
|
||||
] with-destructors response set
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -69,32 +69,24 @@ TUPLE: file-responder root hook special ;
|
|||
swap '[ , directory. ] >>body ;
|
||||
|
||||
: find-index ( filename -- path )
|
||||
{ "index.html" "index.fhtml" } [ append-path ] with map
|
||||
[ exists? ] find nip ;
|
||||
"index.html" append-path dup exists? [ drop f ] unless ;
|
||||
|
||||
: serve-directory ( filename -- response )
|
||||
dup "/" tail? [
|
||||
dup find-index
|
||||
[ serve-file ] [ list-directory ] ?if
|
||||
request get path>> "/" tail? [
|
||||
dup
|
||||
find-index [ serve-file ] [ list-directory ] ?if
|
||||
] [
|
||||
drop request get redirect-with-/
|
||||
drop
|
||||
request get path>> "/" append f <permanent-redirect>
|
||||
] if ;
|
||||
|
||||
: serve-object ( filename -- response )
|
||||
serving-path dup exists? [
|
||||
dup directory? [ serve-directory ] [ serve-file ] if
|
||||
] [
|
||||
drop <404>
|
||||
] if ;
|
||||
serving-path dup exists?
|
||||
[ dup directory? [ serve-directory ] [ serve-file ] if ]
|
||||
[ drop <404> ]
|
||||
if ;
|
||||
|
||||
M: file-responder call-responder ( path responder -- response )
|
||||
file-responder set
|
||||
dup [
|
||||
".." over subseq? [
|
||||
drop <400>
|
||||
] [
|
||||
serve-object
|
||||
] if
|
||||
] [
|
||||
drop redirect-with-/
|
||||
] if ;
|
||||
".." over member?
|
||||
[ drop <400> ] [ "/" join serve-object ] if ;
|
||||
|
|
|
|||
|
|
@ -104,7 +104,8 @@ SYMBOL: tags
|
|||
: form-start-tag ( tag -- )
|
||||
<form
|
||||
"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>
|
||||
hidden-form-field ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,21 +1,25 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences io.files io.sockets
|
||||
db.sqlite smtp namespaces db
|
||||
USING: accessors kernel sequences assocs io.files io.sockets
|
||||
namespaces db db.sqlite smtp
|
||||
http.server
|
||||
http.server.db
|
||||
http.server.sessions
|
||||
http.server.auth.login
|
||||
http.server.auth.providers.db
|
||||
http.server.sessions.storage.db
|
||||
http.server.boilerplate
|
||||
http.server.templating.chloe ;
|
||||
http.server.templating.chloe
|
||||
webapps.pastebin
|
||||
webapps.planet
|
||||
webapps.todo ;
|
||||
IN: webapps.factor-website
|
||||
|
||||
: test-db "test.db" resource-path sqlite-db ;
|
||||
|
||||
: factor-template ( path -- template )
|
||||
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
: test-db "todo.db" resource-path sqlite-db ;
|
||||
|
||||
: <factor-boilerplate> ( responder -- responder' )
|
||||
<login>
|
||||
users-in-db >>users
|
||||
|
|
@ -28,11 +32,40 @@ IN: webapps.factor-website
|
|||
sessions-in-db >>sessions
|
||||
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 ( -- )
|
||||
"factorcode.org" 25 <inet> smtp-server set-global
|
||||
"todo@factorcode.org" lost-password-from set-global
|
||||
|
||||
test-db [
|
||||
init-sessions-table
|
||||
init-users-table
|
||||
] with-db ;
|
||||
init-factor-db
|
||||
|
||||
<factor-website> main-responder set-global
|
||||
|
||||
"planet" main-responder get responders>> at start-update-task ;
|
||||
|
|
|
|||
|
|
@ -10,6 +10,8 @@
|
|||
<head>
|
||||
<t:write-title />
|
||||
|
||||
<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
|
||||
|
||||
<t:style>
|
||||
body, button {
|
||||
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
|
||||
|
|
@ -47,6 +49,18 @@
|
|||
padding: 5px;
|
||||
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: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" />
|
||||
|
||||
<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>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -2,6 +2,6 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Blog</t:title>
|
||||
|
||||
<t:form action="edit-blog">
|
||||
<t:form action="$planet-factor/admin/edit-blog">
|
||||
|
||||
<t:edit component="id" />
|
||||
|
||||
|
|
@ -21,8 +21,8 @@
|
|||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Atom feed:</th>
|
||||
<td><t:edit component="atom-url" /></td>
|
||||
<th class="field-label">Feed:</th>
|
||||
<td><t:edit component="feed-url" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
|
@ -31,9 +31,7 @@
|
|||
|
||||
</t:form>
|
||||
|
||||
<t:a href="view" query="id">View</t:a>
|
||||
|
|
||||
<t:form action="delete-blog" class="inline">
|
||||
<t:form action="$planet-factor/admin/delete-blog" class="inline">
|
||||
<t:edit component="id" />
|
||||
<button type="submit" class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences sorting locals math
|
||||
calendar alarms logging concurrency.combinators namespaces
|
||||
db.types db.tuples db
|
||||
sequences.lib db.types db.tuples db
|
||||
rss xml.writer
|
||||
http.server
|
||||
http.server.crud
|
||||
|
|
@ -11,8 +11,7 @@ http.server.actions
|
|||
http.server.boilerplate
|
||||
http.server.templating.chloe
|
||||
http.server.components
|
||||
http.server.auth.login
|
||||
webapps.factor-website ;
|
||||
http.server.auth.login ;
|
||||
IN: webapps.planet
|
||||
|
||||
TUPLE: planet-factor < dispatcher postings ;
|
||||
|
|
@ -20,7 +19,7 @@ TUPLE: planet-factor < dispatcher postings ;
|
|||
: planet-template ( name -- template )
|
||||
"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>> ;
|
||||
|
||||
|
|
@ -31,7 +30,7 @@ blog "BLOGS"
|
|||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "name" "NAME" { 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
|
||||
|
||||
: init-blog-table blog ensure-table ;
|
||||
|
|
@ -54,7 +53,6 @@ blog "BLOGS"
|
|||
: <blog-form> ( -- form )
|
||||
"blog" <form>
|
||||
"edit-blog" planet-template >>edit-template
|
||||
"view-blog" planet-template >>view-template
|
||||
"blog-admin-link" planet-template >>summary-template
|
||||
"id" <integer>
|
||||
hidden >>renderer
|
||||
|
|
@ -65,7 +63,7 @@ blog "BLOGS"
|
|||
"www-url" <url>
|
||||
t >>required
|
||||
add-field
|
||||
"atom-url" <url>
|
||||
"feed-url" <url>
|
||||
t >>required
|
||||
add-field ;
|
||||
|
||||
|
|
@ -106,14 +104,11 @@ blog "BLOGS"
|
|||
] >>display
|
||||
] ;
|
||||
|
||||
: safe-head ( seq n -- seq' )
|
||||
over length min head ;
|
||||
|
||||
:: planet-feed ( planet -- feed )
|
||||
feed new
|
||||
"[ planet-factor ]" >>title
|
||||
"Planet Factor" >>title
|
||||
"http://planet.factorcode.org" >>link
|
||||
planet postings>> 16 safe-head >>entries ;
|
||||
planet postings>> 16 short head >>entries ;
|
||||
|
||||
:: <feed-action> ( planet -- action )
|
||||
<action>
|
||||
|
|
@ -132,7 +127,7 @@ blog "BLOGS"
|
|||
|
||||
: fetch-blogroll ( blogroll -- entries )
|
||||
dup
|
||||
[ atom-url>> fetch-feed ] parallel-map
|
||||
[ feed-url>> fetch-feed ] parallel-map
|
||||
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
|
|
@ -140,7 +135,7 @@ blog "BLOGS"
|
|||
|
||||
: update-cached-postings ( planet -- )
|
||||
"webapps.planet" [
|
||||
blogroll fetch-blogroll sort-entries 8 safe-head
|
||||
blogroll fetch-blogroll sort-entries 8 short head
|
||||
>>postings drop
|
||||
] with-logging ;
|
||||
|
||||
|
|
@ -157,32 +152,20 @@ blog "BLOGS"
|
|||
<dispatcher>
|
||||
planet-factor <edit-blogroll-action> >>default
|
||||
|
||||
planet-factor <update-action> "update" add-responder
|
||||
|
||||
! Administrative CRUD
|
||||
blog-ctor "" <delete-action> "delete-blog" add-responder
|
||||
blog-form blog-ctor <view-action> "view-blog" add-responder
|
||||
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
|
||||
blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
|
||||
blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
|
||||
] ;
|
||||
|
||||
: <planet-factor> ( -- responder )
|
||||
planet-factor new-dispatcher
|
||||
dup <planet-action> >>default
|
||||
dup <planet-action> "list" add-main-responder
|
||||
dup <feed-action> "feed.xml" add-responder
|
||||
dup <update-action> "update" add-responder
|
||||
dup <planet-factor-admin> <protected> "admin" add-responder
|
||||
<boilerplate>
|
||||
"planet" planet-template >>template ;
|
||||
|
||||
: <planet-app> ( -- responder )
|
||||
<planet-factor> <factor-boilerplate> ;
|
||||
|
||||
: start-update-task ( planet -- )
|
||||
[ 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:comment>
|
||||
<t:atom title="Planet Factor - Atom" href="feed.xml" />
|
||||
<t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
|
||||
</t:comment>
|
||||
<t:style include="resource:extra/webapps/planet/planet.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a href="list">Front Page</t:a>
|
||||
| <t:a href="feed.xml">Atom Feed</t:a>
|
||||
|
||||
| <t:a href="admin">Admin</t:a>
|
||||
<t:a href="$planet-factor/list">Front Page</t:a>
|
||||
| <t:a href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||
| <t:a href="$planet-factor/admin">Admin</t:a>
|
||||
|
||||
<t:comment>
|
||||
<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:form action="logout" class="inline">
|
||||
<t:form action="$login/logout" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</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:form action="edit">
|
||||
<t:form action="$todo-list/edit">
|
||||
<t:edit component="id" />
|
||||
|
||||
<table>
|
||||
<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">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 big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
|
||||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Done" />
|
||||
</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" />
|
||||
<button type="submit" class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
|
|
|
|||
|
|
@ -10,10 +10,10 @@
|
|||
<t:view component="priority" />
|
||||
</td>
|
||||
<td>
|
||||
<t:a href="view" query="id">View</t:a>
|
||||
<t:a href="$todo-list/view" query="id">View</t:a>
|
||||
</td>
|
||||
<td>
|
||||
<t:a href="edit" query="id">Edit</t:a>
|
||||
<t:a href="$todo-list/edit" query="id">Edit</t:a>
|
||||
</td>
|
||||
</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 {
|
||||
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.actions http.server.db
|
||||
http.server.auth.login
|
||||
http.server
|
||||
webapps.factor-website ;
|
||||
http.server ;
|
||||
IN: webapps.todo
|
||||
|
||||
TUPLE: todo uid id priority summary description ;
|
||||
|
|
@ -58,29 +57,17 @@ todo "TODO"
|
|||
"list" <todo-form> +plain+ <list>
|
||||
add-field ;
|
||||
|
||||
TUPLE: todo-responder < dispatcher ;
|
||||
TUPLE: todo-list < dispatcher ;
|
||||
|
||||
:: <todo-responder> ( -- responder )
|
||||
:: <todo-list> ( -- responder )
|
||||
[let | todo-form [ <todo-form> ]
|
||||
list-form [ <todo-list-form> ]
|
||||
ctor [ [ <todo> ] ] |
|
||||
todo-responder new-dispatcher
|
||||
todo-list new-dispatcher
|
||||
list-form ctor <list-action> "list" add-main-responder
|
||||
todo-form ctor <view-action> "view" add-responder
|
||||
todo-form ctor "view" <edit-action> "edit" add-responder
|
||||
ctor "list" <delete-action> "delete" add-responder
|
||||
todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
|
||||
ctor "$todo-list/list" <delete-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"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/xmode/code2html/stylesheet.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a href="list">List Items</t:a>
|
||||
| <t:a href="edit">Add Item</t:a>
|
||||
<t:a href="$todo-list/list">List Items</t:a>
|
||||
| <t:a href="$todo-list/edit">Add Item</t:a>
|
||||
|
||||
<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:form action="logout" class="inline">
|
||||
<t:form action="$login/logout" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</div>
|
||||
|
|
|
|||
|
|
@ -13,9 +13,9 @@
|
|||
<t:view component="description" />
|
||||
</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" />
|
||||
<button class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
|
|
|
|||
Loading…
Reference in New Issue