continuations tuples classes io.files
http http.server.templating http.basic-authentication
webapps.callback html html.elements
- http.server.responders furnace.validator ;
+ http.server.responders furnace.validator vocabs ;
IN: furnace
SYMBOL: default-action
: service-post ( url -- ) "response" get swap service-request ;
+: send-resource ( name -- )
+ template-path get swap path+ resource-path <file-reader>
+ stdio get stream-copy ;
+
: render-template ( template -- )
template-path get swap path+
".furnace" append resource-path
: render-component ( model template -- )
swap [ render-template ] with-slots ;
-! Deprecated stuff
-
-: render-page* ( model body-template head-template -- )
- [
- [ render-component ] [ f rot render-component ] html-document
- ] serve-html ;
-
-: render-titled-page* ( model body-template head-template title -- )
- [
- [ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
- ] serve-html ;
-
-: render-page ( model template title -- )
- [
- [ render-component ] simple-html-document
- ] serve-html ;
+: browse-webapp-source ( vocab -- )
+ <a f >vocab-link browser-link-href =href a>
+ "Browse source" write
+ </a> ;
+++ /dev/null
-<% USING: namespaces io kernel furnace words prettyprint
-generic sequences parser ; %>
-
-<% "model" get %>
-
-<form action="<% dup class dup word-vocabulary use+ unparse write %>-update" method="post">
-
-<% dup crud-index [ %>
-
-<input type="hidden" name="crud-index" value="<% write %>"/>
-
-<% ] when* %>
-
-<table>
-
-<% dup tuple-slots swap class "slot-names" word-prop [ %> <tr><td><% dup write %>:</td>
- <td><input type="text" name="<% write %>" value="<% write %>"/></td></tr><% ] 2each %>
-
-</table>
-<input type="submit" name="submit" value="submit"/>
-</form>
\ No newline at end of file
+++ /dev/null
-<% USING: namespaces kernel io sequences generic words
-prettyprint furnace parser ; %>
-
-<% "model" get dup sequence? not [ unparse %>
-<p><a href="<% write %>-new">New</a></p><% ] [ %>
-
-<p><a href="<% first class unparse write %>-new">New</a></p>
-
-<table>
-<% "model" get dup first class dup
- word-vocabulary use+ "slot-names" word-prop %>
-<tr><% [ %><th><% write %></th><% ] each %></tr>
-
-<% [ %>
-
-<tr><% dup tuple-slots [ %><td><% write %></td><% ] each %>
-
- <% dup crud-index swap class dup "crud-index" word-prop swap unparse %>
- <td><a href="<% 3dup write %>-show?<% write %>=<% write %>">Show</a></td>
- <td><a href="<% 3dup write %>-edit?<% write %>=<% write %>">Edit</a></td>
- <td><a href="<% write %>-delete?<% write %>=<% write %>">Delete</a></td></tr>
-
-<% ] each %>
-
-</table>
-
-<% ] if %>
\ No newline at end of file
+++ /dev/null
-<% USING: namespaces io kernel words generic sequences
-prettyprint furnace parser ; %>
-
-<% "model" get [ %>
-
-<% dup tuple-slots over class dup
- word-vocabulary use+ "slot-names" word-prop %>
-
-<table>
-
-<% [ %><tr><td><% write %>:</td><td><% write %></td></tr><% ] 2each %>
-
-</table>
-
-<% dup crud-index swap class dup "crud-index" word-prop swap unparse %>
-<p><a href="<% 3dup write %>-edit?<% write %>=<% write %>">Edit</a> |
- <a href="<% [ write %>-delete?<% write %>=<% write ] keep %>">Delete</a> |
- <a href="<% dup write %>-new">New</a> | <a href="<% write %>-list">List</a></p>
-
-<% ] [ %><p>No such tuple</p><% ] if* %>
\ No newline at end of file
+++ /dev/null
-USING: http.server help.markup help.syntax kernel prettyprint
-sequences parser namespaces words classes math tuples.private
-quotations arrays strings ;
-
-IN: furnace
-
-TUPLE: furnace-model model ;
-C: <furnace-model> furnace-model
-
-HELP: furnace-model "This definition exists to circumvent a limitation in furnace with regard to sending arbitrary objects as models to .furnace templates." ;
-
-: crud-create ( class string -- word )
- swap unparse "-" rot 3append in get create ;
-
-HELP: crud-create
-{ $values { "class" class } { "string" string } { "word" word } }
-{ $description "A CRUD utility function - creates a new action word for a given class and suffix string" } ;
-
-: crud-word ( class string -- word )
- swap unparse "-" rot 3append parse first ;
-HELP: crud-word
-{ $values { "class" class } { "string" string } { "word" word } }
-{ $description "A CRUD utility function - looks up a word that has been crud-created" } ;
-
-: crud-index ( tuple -- )
- dup class dup "crud-index" word-prop crud-word execute ;
-
-: crud-lookup ( string class -- obj )
- get-global [ crud-index = ] curry* subset
- dup empty? [ drop f ] [ first ] if ;
-HELP: crud-lookup
-{ $values { "string" string } { "class" class } { "obj" object } }
-{ $description "A CRUD utility function - looks up an object in the store by the pre-designated index." } ;
-
-: crud-lookup* ( string class -- tuple )
- tuck crud-lookup
- [ ] [ dup "slot-names" word-prop length 2 + <tuple> ] ?if ;
-
-HELP: crud-lookup*
-{ $values { "string" string } { "class" class } { "tuple" tuple } }
-"A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class. When the lookup fails, returns a tuple of the given class with all slots set to f." ;
-
-: crud-page ( model template title -- )
- [ "libs/furnace/crud-templates" template-path set render-page ]
- with-scope ;
-
-: define-list ( class -- word )
- dup "list" crud-create swap
- [ dup get-global dup empty? -rot ? <furnace-model> "list" "List" crud-page ]
- curry dupd define-compound ;
-
-: define-show ( class -- word )
- dup "show" crud-create swap
- [ crud-lookup <furnace-model> "show" "Show" crud-page ]
- curry dupd define-compound ;
-
-: define-edit ( class -- word )
- dup "edit" crud-create swap
- [ crud-lookup* <furnace-model> "edit" "Edit" crud-page ]
- curry dupd define-compound ;
-
-: define-new ( class -- word )
- dup "new" crud-create swap "edit" crud-word
- [ f swap execute ]
- curry dupd define-compound ;
-
-: define-update ( class -- word )
- dup "update" crud-create swap
- [
- tuck crud-lookup [ over get-global remove over set-global ] when*
- dup >r "constructor" word-prop execute
- r> 2dup get-global swap add over set-global swap
- crud-index swap "show" crud-word execute
- ] curry dupd define-compound ;
-
-: define-delete ( class -- word )
- dup "delete" crud-create swap
- [
- tuck crud-lookup [ over get-global remove over set-global ] when*
- "list" crud-word execute
- ] curry dupd define-compound ;
-
-: define-lookup ( class -- )
- dup "crud-index" word-prop ">" pick unparse 3append in get create
- swap [ crud-lookup ] curry define-compound ;
-
-: define-lookup* ( class -- )
- dup "crud-index" word-prop ">" pick unparse "*" append 3append
- in get create swap [ crud-lookup* ] curry define-compound ;
-
-: scaffold-params ( class -- array )
- "crud-index" word-prop 1array 1array ;
-
-: scaffold ( class index realm -- )
- -rot dupd "crud-index" set-word-prop
- [ define-lookup ] keep [ define-lookup* ] keep
- [ get-global [ { } over set-global ] unless ] keep
- [ define-list { } rot define-authenticated-action ] 2keep
- [ dup define-show swap scaffold-params rot
- define-authenticated-action ] 2keep
- [ dup define-edit swap scaffold-params rot
- define-authenticated-action ] 2keep
- [ define-new { } rot define-authenticated-action ] 2keep
- [ dup define-update swap "slot-names" word-prop
- "crud-index" add [ 1array ] map rot
- define-authenticated-action ] 2keep
- dup define-delete swap scaffold-params rot
- define-authenticated-action ;
-
-HELP: scaffold
-{ $values { "class" class } { "index" "an index" } { "realm" "a realm" } }
-"If realm is not f, then realm is used as the basic authentication realm for the scaffolding actions." ;
-
-ARTICLE: { "furnace" "crud" } "CRUD Scaffolding"
-{ $code
- "\"libs/furnace\" require"
- "USING: furnace httpd threads ;"
- "IN: furnace:crud-example"
- "TUPLE: foo bar baz ;"
- "\"crud-example\" \"foo-list\" f web-app"
- "foo \"bar\" f scaffold"
- "[ 8888 httpd ] in-thread"
-} ;
\ No newline at end of file
USING: kernel furnace sqlite.tuple-db webapps.article-manager.database
sequences namespaces math arrays assocs quotations io.files
http.server http.basic-authentication http.server.responders
- webapps.file ;
+ webapps.file html html.elements io ;
IN: webapps.article-manager
: current-site ( -- site )
host get-site* ;
+: render-titled-page* ( model body-template head-template title -- )
+ [
+ [ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
+ ] serve-html ;
+
TUPLE: template-args arg1 ;
C: <template-args> template-args
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
- <% f "navigation" render-template %>
+ <% "navigation" render-template %>
<div id="article">
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
<% "arg1" get second article-body write-html %>
<h1>Tags</h1>
- <% "arg1" get second tags-for-article <template-args> "tags" render-template %>
+ <% "arg1" get second tags-for-article <template-args> "tags" render-component %>
</div>
<p class="footer"></p>
<p id="copyright"><% "arg1" get first site-footer write %></p>
</head>
<body>
<div id="banner"><h1><% "title" get write %></h1></div>
- <% f "navigation" render-template %>
+ <% "navigation" render-template %>
<div id="article">
<% "intro" get write-html %>
<h1>Recent Articles</h1>
but in the meantime, Google is likely to provide
reasonable results.
</p>
- <% host all-tags <template-args> "tags" render-template %>
+ <% host all-tags <template-args> "tags" render-component %>
</div>
<p class="footer"></p>
<p id="copyright"><% "footer" get write %></p>
</ul>
<% current-site site-ad1 write-html %>
<h1>Tags</h1>
- <% host all-tags <template-args> "tags" render-template %>
+ <% host all-tags <template-args> "tags" render-component %>
</div>
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
- <% f "navigation" render-template %>
+ <% "navigation" render-component %>
<div id="article">
<h1><% "arg1" get second tag-title write %></h1>
<% "arg1" get second tag-description write-html %>
USING: kernel furnace fjsc parser-combinators namespaces
lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders
- webapps.file ;
+ webapps.file html ;
IN: webapps.fjsc
: compile ( code -- )
{ "url" v-required }
} define-action
+: render-page* ( model body-template head-template -- )
+ [
+ [ render-component ] [ f rot render-component ] html-document
+ ] serve-html ;
+
: repl ( -- )
#! The main 'repl' page.
f "repl" "head" render-page* ;
--- /dev/null
+<% USING: namespaces io kernel furnace words prettyprint
+generic sequences parser ; %>
+
+<% "model" get %>
+
+<form action="<% dup class dup word-vocabulary use+ unparse write %>-update" method="post">
+
+<% dup crud-index [ %>
+
+<input type="hidden" name="crud-index" value="<% write %>"/>
+
+<% ] when* %>
+
+<table>
+
+<% dup tuple-slots swap class "slot-names" word-prop [ %> <tr><td><% dup write %>:</td>
+ <td><input type="text" name="<% write %>" value="<% write %>"/></td></tr><% ] 2each %>
+
+</table>
+<input type="submit" name="submit" value="submit"/>
+</form>
\ No newline at end of file
--- /dev/null
+<% USING: namespaces kernel io sequences generic words
+prettyprint furnace parser ; %>
+
+<% "model" get dup sequence? not [ unparse %>
+<p><a href="<% write %>-new">New</a></p><% ] [ %>
+
+<p><a href="<% first class unparse write %>-new">New</a></p>
+
+<table>
+<% "model" get dup first class dup
+ word-vocabulary use+ "slot-names" word-prop %>
+<tr><% [ %><th><% write %></th><% ] each %></tr>
+
+<% [ %>
+
+<tr><% dup tuple-slots [ %><td><% write %></td><% ] each %>
+
+ <% dup crud-index swap class dup "crud-index" word-prop swap unparse %>
+ <td><a href="<% 3dup write %>-show?<% write %>=<% write %>">Show</a></td>
+ <td><a href="<% 3dup write %>-edit?<% write %>=<% write %>">Edit</a></td>
+ <td><a href="<% write %>-delete?<% write %>=<% write %>">Delete</a></td></tr>
+
+<% ] each %>
+
+</table>
+
+<% ] if %>
\ No newline at end of file
--- /dev/null
+<% USING: namespaces io kernel words generic sequences
+prettyprint furnace parser ; %>
+
+<% "model" get [ %>
+
+<% dup tuple-slots over class dup
+ word-vocabulary use+ "slot-names" word-prop %>
+
+<table>
+
+<% [ %><tr><td><% write %>:</td><td><% write %></td></tr><% ] 2each %>
+
+</table>
+
+<% dup crud-index swap class dup "crud-index" word-prop swap unparse %>
+<p><a href="<% 3dup write %>-edit?<% write %>=<% write %>">Edit</a> |
+ <a href="<% [ write %>-delete?<% write %>=<% write ] keep %>">Delete</a> |
+ <a href="<% dup write %>-new">New</a> | <a href="<% write %>-list">List</a></p>
+
+<% ] [ %><p>No such tuple</p><% ] if* %>
\ No newline at end of file
--- /dev/null
+USING: http.server help.markup help.syntax kernel prettyprint
+sequences parser namespaces words classes math tuples.private
+quotations arrays strings ;
+
+IN: furnace.scaffold
+
+TUPLE: furnace-model model ;
+C: <furnace-model> furnace-model
+
+HELP: furnace-model "This definition exists to circumvent a limitation in furnace with regard to sending arbitrary objects as models to .furnace templates." ;
+
+: crud-create ( class string -- word )
+ swap unparse "-" rot 3append in get create ;
+
+HELP: crud-create
+{ $values { "class" class } { "string" string } { "word" word } }
+{ $description "A CRUD utility function - creates a new action word for a given class and suffix string" } ;
+
+: crud-word ( class string -- word )
+ swap unparse "-" rot 3append parse first ;
+HELP: crud-word
+{ $values { "class" class } { "string" string } { "word" word } }
+{ $description "A CRUD utility function - looks up a word that has been crud-created" } ;
+
+: crud-index ( tuple -- )
+ dup class dup "crud-index" word-prop crud-word execute ;
+
+: crud-lookup ( string class -- obj )
+ get-global [ crud-index = ] curry* subset
+ dup empty? [ drop f ] [ first ] if ;
+HELP: crud-lookup
+{ $values { "string" string } { "class" class } { "obj" object } }
+{ $description "A CRUD utility function - looks up an object in the store by the pre-designated index." } ;
+
+: crud-lookup* ( string class -- tuple )
+ tuck crud-lookup
+ [ ] [ dup "slot-names" word-prop length 2 + <tuple> ] ?if ;
+
+HELP: crud-lookup*
+{ $values { "string" string } { "class" class } { "tuple" tuple } }
+"A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class. When the lookup fails, returns a tuple of the given class with all slots set to f." ;
+
+: render-page ( model template title -- )
+ [
+ [ render-component ] simple-html-document
+ ] serve-html ;
+
+: crud-page ( model template title -- )
+ [ "libs/furnace/crud-templates" template-path set render-page ]
+ with-scope ;
+
+: define-list ( class -- word )
+ dup "list" crud-create swap
+ [ dup get-global dup empty? -rot ? <furnace-model> "list" "List" crud-page ]
+ curry dupd define-compound ;
+
+: define-show ( class -- word )
+ dup "show" crud-create swap
+ [ crud-lookup <furnace-model> "show" "Show" crud-page ]
+ curry dupd define-compound ;
+
+: define-edit ( class -- word )
+ dup "edit" crud-create swap
+ [ crud-lookup* <furnace-model> "edit" "Edit" crud-page ]
+ curry dupd define-compound ;
+
+: define-new ( class -- word )
+ dup "new" crud-create swap "edit" crud-word
+ [ f swap execute ]
+ curry dupd define-compound ;
+
+: define-update ( class -- word )
+ dup "update" crud-create swap
+ [
+ tuck crud-lookup [ over get-global remove over set-global ] when*
+ dup >r "constructor" word-prop execute
+ r> 2dup get-global swap add over set-global swap
+ crud-index swap "show" crud-word execute
+ ] curry dupd define-compound ;
+
+: define-delete ( class -- word )
+ dup "delete" crud-create swap
+ [
+ tuck crud-lookup [ over get-global remove over set-global ] when*
+ "list" crud-word execute
+ ] curry dupd define-compound ;
+
+: define-lookup ( class -- )
+ dup "crud-index" word-prop ">" pick unparse 3append in get create
+ swap [ crud-lookup ] curry define-compound ;
+
+: define-lookup* ( class -- )
+ dup "crud-index" word-prop ">" pick unparse "*" append 3append
+ in get create swap [ crud-lookup* ] curry define-compound ;
+
+: scaffold-params ( class -- array )
+ "crud-index" word-prop 1array 1array ;
+
+: scaffold ( class index realm -- )
+ -rot dupd "crud-index" set-word-prop
+ [ define-lookup ] keep [ define-lookup* ] keep
+ [ get-global [ { } over set-global ] unless ] keep
+ [ define-list { } rot define-authenticated-action ] 2keep
+ [ dup define-show swap scaffold-params rot
+ define-authenticated-action ] 2keep
+ [ dup define-edit swap scaffold-params rot
+ define-authenticated-action ] 2keep
+ [ define-new { } rot define-authenticated-action ] 2keep
+ [ dup define-update swap "slot-names" word-prop
+ "crud-index" add [ 1array ] map rot
+ define-authenticated-action ] 2keep
+ dup define-delete swap scaffold-params rot
+ define-authenticated-action ;
+
+HELP: scaffold
+{ $values { "class" class } { "index" "an index" } { "realm" "a realm" } }
+"If realm is not f, then realm is used as the basic authentication realm for the scaffolding actions." ;
+
+ARTICLE: { "furnace" "crud" } "CRUD Scaffolding"
+{ $code
+ "\"libs/furnace\" require"
+ "USING: furnace httpd threads ;"
+ "IN: furnace:crud-example"
+ "TUPLE: foo bar baz ;"
+ "\"crud-example\" \"foo-list\" f web-app"
+ "foo \"bar\" f scaffold"
+ "[ 8888 httpd ] in-thread"
+} ;
\ No newline at end of file
projects / factor.git / commitdiff