] 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
[ "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
-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
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
fry continuations locals ;\r
IN: http.server.actions\r
\r
-SYMBOL: +append-path\r
+SYMBOL: +path+\r
\r
SYMBOL: params\r
\r
\r
M: action call-responder ( path action -- response )\r
'[\r
- , ,\r
- [ +append-path associate request-params assoc-union params set ]\r
- [ action set ] bi*\r
- request get method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
+ , [ CHAR: / = ] right-trim empty? [\r
+ , action set\r
+ request-params params set\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case\r
+ ] [\r
+ <404>\r
+ ] if\r
] with-exit-continuation ;\r
\r
: successful-login ( user -- response )\r
logged-in-user sset\r
- post-login-url sget "" or f <permanent-redirect>\r
+ post-login-url sget "
$login" or f <permanent-redirect>
\r f post-login-url sset ;\r
\r
:: <login-action> ( -- action )\r
<action>\r
[\r
blank-values\r
+\r
logged-in-user sget\r
- dup username>> "username" set-value\r
- dup realname>> "realname" set-value\r
- dup email>> "email" set-value\r
+ [ username>> "username" set-value ]\r
+ [ realname>> "realname" set-value ]\r
+ [ email>> "email" set-value ]\r
+ tri\r
] >>init\r
\r
[ form edit-form ] >>display\r
"realname" value >>realname\r
"email" value >>email\r
\r
+ drop\r
+\r
user-profile-changed? on\r
\r
previous-page sget f <permanent-redirect>\r
<action>\r
[\r
f logged-in-user sset\r
- "login" f <permanent-redirect>\r
+ "
$login/login" f <permanent-redirect>
\r ] >>submit ;\r
\r
! ! ! Authentication logic\r
\r
: show-login-page ( -- response )\r
request get request-url post-login-url sset\r
- "login" f <permanent-redirect> ;\r
+ "$login/login" f <temporary-redirect> ;\r
\r
M: protected call-responder ( path responder -- response )\r
logged-in-user sget dup [\r
<request> "GET" >>method request set\r
[\r
exit-continuation set\r
- "xxx"\r
+ { }\r
<action> [ [ "hello" print 123 ] show-final ] >>display\r
<callback-responder>\r
call-responder\r
[\r
exit-continuation set\r
<request> "GET" >>method request set\r
- "" "r" get call-responder\r
+ { } "r" get call-responder\r
] callcc1\r
\r
body>> first\r
\r
[\r
exit-continuation set\r
- "/"\r
+ { }\r
"r" get call-responder\r
] callcc1\r
\r
\r
[\r
exit-continuation set\r
- "/"\r
+ { }\r
"r" get call-responder\r
] callcc1\r
] unit-test\r
--- /dev/null
+! 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 ;
<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 ;
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
"text/plain" <content> ;
: check-dispatch ( tag path -- ? )
+ H{ } clone base-paths set
over off
+ split-path
main-responder get call-responder
write-response get ;
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
[ 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
[
[ "/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
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 )
[ <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 ;
: 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' )
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 ;
: <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> ;
-
-M: dispatcher call-responder ( path dispatcher -- response )
- over [
- find-responder call-responder
+ over empty? [
+ "" over responders>> at*
+ [ nip ] [ drop default>> ] if
] [
- 2drop redirect-with-/
+ over first over responders>> at*
+ [ >r drop 1 tail-slice r> ] [ drop default>> ] if
] if ;
+M: dispatcher call-responder ( path dispatcher -- response )
+ [ add-base-path ] [ find-responder call-responder ] 2bi ;
+
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
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
: 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 ]
<request>\r
"GET" >>method\r
request set\r
- "/etc" "manager" get call-responder\r
+ { "etc" } "manager" get call-responder\r
response set\r
] unit-test\r
\r
"id" get session-id-key set-query-param\r
"/" >>path\r
request set\r
- "/" "manager" get call-responder\r
+ { } "manager" get call-responder\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
"GET" >>method\r
"/" >>path\r
request set\r
- "/etc" "manager" get call-responder response set\r
+ { "etc" } "manager" get call-responder response set\r
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
response get\r
] with-destructors\r
"cookies" get >>cookies\r
"/" >>path\r
request set\r
- "/" "manager" get call-responder\r
+ { } "manager" get call-responder\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
request set\r
\r
[\r
- "/" <exiting-action> <cookie-sessions>\r
+ { } <exiting-action> <cookie-sessions>\r
call-responder\r
] with-destructors response set\r
] unit-test\r
swap '[ , directory. ] >>body ;\r
\r
: find-index ( filename -- path )\r
- { "index.html" "index.fhtml" } [ append-path ] with map\r
- [ exists? ] find nip ;\r
+ "index.html" append-path dup exists? [ drop f ] unless ;\r
\r
: serve-directory ( filename -- response )\r
- dup "/" tail? [\r
- dup find-index\r
- [ serve-file ] [ list-directory ] ?if\r
+ request get path>> "/" tail? [\r
+ dup\r
+ find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
- drop request get redirect-with-/\r
+ drop\r
+ request get path>> "/" append f <permanent-redirect>\r
] if ;\r
\r
: serve-object ( filename -- response )\r
- serving-path dup exists? [\r
- dup directory? [ serve-directory ] [ serve-file ] if\r
- ] [\r
- drop <404>\r
- ] if ;\r
+ serving-path dup exists?\r
+ [ dup directory? [ serve-directory ] [ serve-file ] if ]\r
+ [ drop <404> ]\r
+ if ;\r
\r
M: file-responder call-responder ( path responder -- response )\r
file-responder set\r
- dup [\r
- ".." over subseq? [\r
- drop <400>\r
- ] [\r
- serve-object\r
- ] if\r
- ] [\r
- drop redirect-with-/\r
- ] if ;\r
+ ".." over member?\r
+ [ drop <400> ] [ "/" join serve-object ] if ;\r
: 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 ;
! 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
sessions-in-db >>sessions
test-db <db-persistence> ;
-: init-factor-website ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
+: <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-sessions-table
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
+
+ init-factor-db
+
+ <factor-website> main-responder set-global
+
+ "planet" main-responder get responders>> at start-update-task ;
<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;
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 />
--- /dev/null
+<?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>
--- /dev/null
+Slava Pestov
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+pre.code {
+ border:1px dashed #ccc;
+ background-color:#f5f5f5;
+ padding:5px;
+ font-size:150%;
+ color:#000000;
+}
--- /dev/null
+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 ;
--- /dev/null
+<?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>
<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>
<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:title>Edit Blog</t:title>
- <t:form action="edit-blog">
+ <t:form action="$planet-factor/admin/edit-blog">
<t:edit component="id" />
</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>
</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>
! 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
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 ;
: 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>> ;
{ "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 ;
: <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
"www-url" <url>
t >>required
add-field
- "atom-url" <url>
+ "feed-url" <url>
t >>required
add-field ;
] >>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>
: 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' )
: 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 ;
<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 ;
<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>
+++ /dev/null
-<?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>
<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>
<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>
-.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%;
}
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 ;
"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 ;
<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>
<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>
projects / factor.git / commitdiff