Start of new web framework
slava
parent
247c55f94c
commit
b8cf64bc76
|
|
@ -55,6 +55,7 @@ USING: sequences kernel parser math namespaces io ;
|
||||||
|
|
||||||
: with-embedded-file ( filename quot -- )
|
: with-embedded-file ( filename quot -- )
|
||||||
[
|
[
|
||||||
|
file-vocabs
|
||||||
over file set ! so that reload works properly
|
over file set ! so that reload works properly
|
||||||
>r <file-reader> contents r> call
|
>r <file-reader> contents r> call
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
REQUIRES: contrib/furnace ;
|
||||||
|
|
||||||
|
PROVIDE: contrib/furnace-pastebin { "pastebin.factor" } ;
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
<form method="POST" action="/responder/pastebin/submit-paste">
|
||||||
|
|
||||||
|
<table>
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<th>Summary:</th>
|
||||||
|
<td><input type="TEXT" name="summary" value="" /></td>
|
||||||
|
</tr>
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<th>Your name:</th>
|
||||||
|
<td><input type="TEXT" name="author" value="" /></td>
|
||||||
|
</tr>
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<th valign="top">Contents:</th>
|
||||||
|
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||||
|
</tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<input type="SUBMIT" value="Submit paste" />
|
||||||
|
</form>
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
<% USING: namespaces furnace sequences ; %>
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th>Summary:</th><th>Paste by:</th></tr>
|
||||||
|
<% "pastes" get [ "paste-summary" render-template ] each %></table>
|
||||||
|
|
||||||
|
<% "new-paste-quot" get "New paste" render-link %>
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
<% USING: namespaces io kernel math furnace ; %>
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<td><% "summary" get write %></td>
|
||||||
|
<td><% "author" get write %></td>
|
||||||
|
<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
|
||||||
|
</tr>
|
||||||
|
|
@ -0,0 +1,62 @@
|
||||||
|
IN: furnace:pastebin
|
||||||
|
USING: calendar kernel namespaces sequences furnace hashtables
|
||||||
|
math ;
|
||||||
|
|
||||||
|
TUPLE: paste n summary author contents date ;
|
||||||
|
|
||||||
|
C: paste ( summary author contents -- paste )
|
||||||
|
[ set-paste-contents ] keep
|
||||||
|
[ set-paste-author ] keep
|
||||||
|
[ set-paste-summary ] keep ;
|
||||||
|
|
||||||
|
TUPLE: pastebin pastes ;
|
||||||
|
|
||||||
|
C: pastebin ( -- pastebin )
|
||||||
|
V{ } clone over set-pastebin-pastes ;
|
||||||
|
|
||||||
|
: add-paste ( paste pastebin -- )
|
||||||
|
now timestamp>http-string pick set-paste-date
|
||||||
|
dup pastebin-pastes length pick set-paste-n
|
||||||
|
pastebin-pastes push ;
|
||||||
|
|
||||||
|
<pastebin> "pastebin" set-global
|
||||||
|
|
||||||
|
: get-paste ( n -- paste )
|
||||||
|
"pastebin" get pastebin-pastes nth ;
|
||||||
|
|
||||||
|
: show-paste ( n -- )
|
||||||
|
"Paste"
|
||||||
|
swap string>number get-paste
|
||||||
|
"show-paste" render-page ;
|
||||||
|
|
||||||
|
\ show-paste { { "n" "0" } } define-action
|
||||||
|
|
||||||
|
: new-paste ( -- )
|
||||||
|
"New paste" f "new-paste" render-page ;
|
||||||
|
|
||||||
|
\ new-paste { } define-action
|
||||||
|
|
||||||
|
: submit-paste ( summary author contents -- )
|
||||||
|
<paste> "pastebin" get-global add-paste ;
|
||||||
|
|
||||||
|
\ submit-paste {
|
||||||
|
{ "summary" "" }
|
||||||
|
{ "author" "" }
|
||||||
|
{ "contents" "" }
|
||||||
|
} define-action
|
||||||
|
|
||||||
|
: paste-list ( -- )
|
||||||
|
[
|
||||||
|
[ show-paste ] "show-paste-quot" set
|
||||||
|
[ new-paste ] "new-paste-quot" set
|
||||||
|
|
||||||
|
"Pastebin"
|
||||||
|
"pastebin" get
|
||||||
|
"paste-list" render-page
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
\ paste-list { } define-action
|
||||||
|
|
||||||
|
\ submit-paste [ paste-list ] define-redirect
|
||||||
|
|
||||||
|
"pastebin" "paste-list" "contrib/pastebin" web-app
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
<% USING: namespaces io ; %>
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th>Summary:</th><td><% "summary" get write %></td></tr>
|
||||||
|
<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
|
||||||
|
<tr><th>Created:</th><td><% "date" get write %></td></tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<pre><% "contents" get write %></pre>
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
REQUIRES: contrib/httpd ;
|
||||||
|
|
||||||
|
PROVIDE: contrib/furnace {
|
||||||
|
"responder.factor"
|
||||||
|
} {
|
||||||
|
"test/responder.factor"
|
||||||
|
} ;
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
<% USING: namespaces io furnace ; %>
|
||||||
|
|
||||||
|
<html>
|
||||||
|
|
||||||
|
<head><title><% "title" get write %></title></head>
|
||||||
|
|
||||||
|
<body><% "root" get render-component %></body>
|
||||||
|
|
||||||
|
</html>
|
||||||
|
|
@ -0,0 +1,114 @@
|
||||||
|
IN: furnace
|
||||||
|
USING: embedded generic arrays namespaces prettyprint io
|
||||||
|
sequences words kernel httpd html errors hashtables http
|
||||||
|
callback-responder ;
|
||||||
|
|
||||||
|
SYMBOL: default-action
|
||||||
|
|
||||||
|
SYMBOL: template-path
|
||||||
|
|
||||||
|
: define-action ( word params -- )
|
||||||
|
over t "action" set-word-prop
|
||||||
|
"action-params" set-word-prop ;
|
||||||
|
|
||||||
|
: define-redirect ( word quot -- )
|
||||||
|
"action-redirect" set-word-prop ;
|
||||||
|
|
||||||
|
: responder-vocab ( name -- vocab )
|
||||||
|
"furnace:" swap append ;
|
||||||
|
|
||||||
|
: lookup-action ( name webapp -- word )
|
||||||
|
responder-vocab lookup dup [
|
||||||
|
dup "action" word-prop [ drop f ] unless
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: current-action ( url -- word/f )
|
||||||
|
dup empty? [ drop default-action get ] when
|
||||||
|
"responder" get lookup-action ;
|
||||||
|
|
||||||
|
PREDICATE: word action "action" word-prop ;
|
||||||
|
|
||||||
|
: quot>query ( seq action -- hash )
|
||||||
|
"action-params" word-prop
|
||||||
|
[ first swap 2array ] 2map alist>hash ;
|
||||||
|
|
||||||
|
: action-link ( query action -- url )
|
||||||
|
[
|
||||||
|
"/responder/" % "responder" get % "/" %
|
||||||
|
word-name %
|
||||||
|
] "" make swap build-url ;
|
||||||
|
|
||||||
|
: action-call? ( args obj -- ? )
|
||||||
|
action? >r [ word? not ] all? r> and ;
|
||||||
|
|
||||||
|
: quot-link ( quot -- url )
|
||||||
|
1 swap cut* peek 2dup action-call? [
|
||||||
|
[ quot>query ] keep action-link
|
||||||
|
] [
|
||||||
|
t register-html-callback
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: render-link ( quot name -- )
|
||||||
|
<a swap quot-link =href a> write </a> ;
|
||||||
|
|
||||||
|
: query>quot ( params action -- seq )
|
||||||
|
"action-params" word-prop
|
||||||
|
[ dup first rot hash [ ] [ second ] ?if ] map-with ;
|
||||||
|
|
||||||
|
: perform-redirect ( action -- )
|
||||||
|
"action-redirect" word-prop [ quot-link redirect ] when* ;
|
||||||
|
|
||||||
|
: call-action ( params action -- )
|
||||||
|
[ query>quot ] keep [ add >quotation call ] keep
|
||||||
|
perform-redirect ;
|
||||||
|
|
||||||
|
: service-request ( url params -- )
|
||||||
|
current-action [
|
||||||
|
[ call-action ] [ <pre> print-error </pre> ] recover
|
||||||
|
] [
|
||||||
|
"404 no such action: " "argument" get append httpd-error
|
||||||
|
] if* ;
|
||||||
|
|
||||||
|
: service-get ( url -- ) "query" get swap service-request ;
|
||||||
|
|
||||||
|
: service-post ( url -- ) "response" get swap service-request ;
|
||||||
|
|
||||||
|
: explode-tuple ( tuple -- )
|
||||||
|
dup tuple>array 2 tail swap class "slot-names" word-prop
|
||||||
|
[ set ] 2each ;
|
||||||
|
|
||||||
|
: call-template ( model template -- )
|
||||||
|
[
|
||||||
|
>r [ explode-tuple ] when* r>
|
||||||
|
".fhtml" append resource-path run-embedded-file
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
TUPLE: component model template ;
|
||||||
|
|
||||||
|
TUPLE: page title root ;
|
||||||
|
|
||||||
|
C: page ( title model template -- page )
|
||||||
|
[ >r <component> r> set-page-root ] keep
|
||||||
|
[ set-page-title ] keep ;
|
||||||
|
|
||||||
|
: render-template ( model template -- )
|
||||||
|
template-path get swap path+ call-template ;
|
||||||
|
|
||||||
|
: render-component
|
||||||
|
dup component-model swap component-template
|
||||||
|
render-template ;
|
||||||
|
|
||||||
|
: render-page ( title model template -- )
|
||||||
|
serving-html
|
||||||
|
<page> "contrib/furnace/page" call-template ;
|
||||||
|
|
||||||
|
: web-app ( name default path -- )
|
||||||
|
over responder-vocab create-vocab drop
|
||||||
|
[
|
||||||
|
template-path set
|
||||||
|
default-action set
|
||||||
|
"responder" set
|
||||||
|
[ service-get ] "get" set
|
||||||
|
[ service-post ] "post" set
|
||||||
|
! [ service-head ] "head" set
|
||||||
|
] make-responder ;
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: test namespaces furnace ;
|
||||||
|
|
||||||
|
: foo ;
|
||||||
|
|
||||||
|
\ foo { { "foo" "2" } { "bar" f } } define-action
|
||||||
|
|
||||||
|
[
|
||||||
|
{ "2" "hello" }
|
||||||
|
] [
|
||||||
|
[
|
||||||
|
H{
|
||||||
|
{ "bar" "hello" }
|
||||||
|
} "query" set
|
||||||
|
|
||||||
|
\ foo query>quot
|
||||||
|
] with-scope
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
H{ { "foo" "1" } { "bar" "2" } }
|
||||||
|
] [
|
||||||
|
{ "1" "2" } \ foo quot>query
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
"/responder/bar/foo?foo=3"
|
||||||
|
] [
|
||||||
|
[
|
||||||
|
"bar" "responder" set
|
||||||
|
[ "3" foo ] quot-link
|
||||||
|
] with-scope
|
||||||
|
] unit-test
|
||||||
Loading…
Reference in New Issue