steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

XML templating engine

db4
Slava Pestov 2008-04-15 06:10:08 -05:00
parent 1ef0042f6a
commit 7bcadd99a4
39 changed files with 854 additions and 397 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
extra/editors/vim/generate-syntax/generate-syntax.factor
View File

@ -1,9 +1,10 @@
! Generate a new factor.vim file for syntax highlighting ! Generate a new factor.vim file for syntax highlighting
USING: http.server.templating.fhtml io.files ; USING: http.server.templating http.server.templating.fhtml
io.files ;
IN: editors.vim.generate-syntax IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- ) : generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path "misc/factor.vim.fgen" resource-path <fhtml>
"misc/factor.vim" resource-path "misc/factor.vim" resource-path
template-convert ; template-convert ;

15
extra/http/http.factor
View File

@ -394,14 +394,17 @@ body ;
[ unparse-cookies "set-cookie" pick set-at ] when* [ unparse-cookies "set-cookie" pick set-at ] when*
write-header ; write-header ;
: write-response-body ( response -- response ) : body>quot ( body -- quot )
dup body>> { {
{ [ dup not ] [ drop ] } { [ dup not ] [ drop [ ] ] }
{ [ dup string? ] [ write ] } { [ dup string? ] [ [ write ] curry ] }
{ [ dup callable? ] [ call ] } { [ dup callable? ] [ ] }
[ stdio get stream-copy ] [ [ stdio get stream-copy ] curry ]
} cond ; } cond ;
: write-response-body ( response -- response )
dup body>> body>quot call ;
M: response write-response ( respose -- ) M: response write-response ( respose -- )
write-response-version write-response-version
write-response-code write-response-code

9
extra/http/server/auth/login/boilerplate.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h1><t:write-title /></h1>
<t:call-next-template />
</t:chloe>

77
extra/http/server/auth/login/edit-profile.fhtml
View File

@ -1,77 +0,0 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>Edit profile</h1>
<form method="POST" action="edit-profile">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-view %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Current password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<td>New password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p><input type="submit" value="Update" />
<% {
{ [ login-failed? get ] [ "invalid password" render-error ] }
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

77
extra/http/server/auth/login/edit-profile.xml Normal file
View File

@ -0,0 +1,77 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Edit Profile</t:title>
<t:form action="edit-profile">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:view component="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
<td><t:edit component="realname" /></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<th class="field-label">Current password:</th>
<td><t:edit component="password" /></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<th class="field-label">New password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p>
<input type="submit" value="Update" />
<t:if var="http.server.auth.login:login-failed?">
<t:error>invalid password</t:error>
</t:if>
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

43
extra/http/server/auth/login/login.factor
View File

@ -15,7 +15,9 @@ http.server.actions
http.server.components http.server.components
http.server.forms http.server.forms
http.server.sessions http.server.sessions
http.server.templating.fhtml http.server.boilerplate
http.server.templating
http.server.templating.chloe
http.server.validators ; http.server.validators ;
IN: http.server.auth.login IN: http.server.auth.login
QUALIFIED: smtp QUALIFIED: smtp
@ -40,11 +42,15 @@ M: user-saver dispose
: save-user-after ( user -- ) : save-user-after ( user -- )
<user-saver> add-always-destructor ; <user-saver> add-always-destructor ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"
3append <chloe> ;
! ! ! Login ! ! ! Login
: <login-form> : <login-form>
"login" <form> "login" <form>
"resource:extra/http/server/auth/login/login.fhtml" >>edit-template "login" login-template >>edit-template
"username" <username> "username" <username>
t >>required t >>required
add-field add-field
@ -86,7 +92,7 @@ M: user-saver dispose
: <register-form> ( -- form ) : <register-form> ( -- form )
"register" <form> "register" <form>
"resource:extra/http/server/auth/login/register.fhtml" >>edit-template "register" login-template >>edit-template
"username" <username> "username" <username>
t >>required t >>required
add-field add-field
@ -147,7 +153,7 @@ SYMBOL: user-exists?
: <edit-profile-form> ( -- form ) : <edit-profile-form> ( -- form )
"edit-profile" <form> "edit-profile" <form>
"resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template "edit-profile" login-template >>edit-template
"username" <username> add-field "username" <username> add-field
"realname" <string> add-field "realname" <string> add-field
"password" <password> add-field "password" <password> add-field
@ -242,7 +248,7 @@ SYMBOL: lost-password-from
: <recover-form-1> ( -- form ) : <recover-form-1> ( -- form )
"register" <form> "register" <form>
"resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template "recover-1" login-template >>edit-template
"username" <username> "username" <username>
t >>required t >>required
add-field add-field
@ -271,13 +277,13 @@ SYMBOL: lost-password-from
send-password-email send-password-email
] when* ] when*
"resource:extra/http/server/auth/login/recover-2.fhtml" serve-template "recover-2" login-template serve-template
] >>submit ] >>submit
] ; ] ;
: <recover-form-3> : <recover-form-3>
"new-password" <form> "new-password" <form>
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template "recover-3" login-template >>edit-template
"username" <username> "username" <username>
hidden >>renderer hidden >>renderer
t >>required t >>required
@ -326,8 +332,7 @@ SYMBOL: lost-password-from
"new-password" value >>password "new-password" value >>password
users update-user users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml" "recover-4" login-template serve-template
serve-template
] [ ] [
<400> <400>
] if* ] if*
@ -367,24 +372,32 @@ M: login call-responder ( path responder -- response )
dup login set dup login set
call-next-method ; call-next-method ;
: <login-boilerplate> ( responder -- responder' )
<boilerplate>
"boilerplate" login-template >>template ;
: <login> ( responder -- auth ) : <login> ( responder -- auth )
login new-dispatcher login new-dispatcher
swap <protected> >>default swap <protected> >>default
<login-action> "login" add-responder <login-action> <login-boilerplate> "login" add-responder
<logout-action> "logout" add-responder <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ; no-users >>users ;
! ! ! Configuration ! ! ! Configuration
: allow-edit-profile ( login -- login ) : allow-edit-profile ( login -- login )
<edit-profile-action> <protected> "edit-profile" add-responder ; <edit-profile-action> <protected> <login-boilerplate>
"edit-profile" add-responder ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )
<register-action> "register" add-responder ; <register-action> <login-boilerplate>
"register" add-responder ;
: allow-password-recovery ( login -- login ) : allow-password-recovery ( login -- login )
<recover-action-1> "recover-password" add-responder <recover-action-1> <login-boilerplate>
<recover-action-3> "new-password" add-responder ; "recover-password" add-responder
<recover-action-3> <login-boilerplate>
"new-password" add-responder ;
: allow-edit-profile? ( -- ? ) : allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ; login get responders>> "edit-profile" swap key? ;

46
extra/http/server/auth/login/login.fhtml
View File

@ -1,46 +0,0 @@
<% USING: http.server.auth.login http.server.components http.server
kernel namespaces ; %>
<html>
<body>
<h1>Login required</h1>
<form method="POST" action="login">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
</tr>
</table>
<p><input type="submit" value="Log in" />
<%
login-failed? get
[ "Invalid username or password" render-error ] when
%>
</p>
</form>
<p>
<% allow-registration? [ %>
<a href="<% "register" f write-link %>">Register</a>
<% ] when %>
<% allow-password-recovery? [ %>
<a href="<% "recover-password" f write-link %>">
Recover Password
</a>
<% ] when %>
</p>
</body>
</html>

44
extra/http/server/auth/login/login.xml Normal file
View File

@ -0,0 +1,44 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Login</t:title>
<t:form action="login">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="password" /></td>
</tr>
</table>
<p>
<input type="submit" value="Log in" />
<t:if var="http.server.auth.login:login-failed?">
<t:error>invalid username or password</t:error>
</t:if>
</p>
</t:form>
<p>
<t:if code="http.server.auth.login:login-failed?">
<t:a href="register">Register</t:a>
</t:if>
|
<t:if code="http.server.auth.login:allow-password-recovery?">
<t:a href="recover-password">Recover Password</t:a>
</t:if>
</p>
</t:chloe>

41
extra/http/server/auth/login/recover-1.fhtml
View File

@ -1,41 +0,0 @@
<% USING: http.server.components http.server ; %>
<html>
<body>
<h1>Recover lost password: step 1 of 4</h1>
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<form method="POST" action="recover-password">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
</tr>
</table>
<input type="submit" value="Recover password" />
</form>
</body>
</html>

39
extra/http/server/auth/login/recover-1.xml Normal file
View File

@ -0,0 +1,39 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 1 of 4</t:title>
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<t:form action="recover-password">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></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 e-mail you will be blocked.</td>
</tr>
</table>
<input type="submit" value="Recover password" />
</t:form>
</t:chloe>

9
extra/http/server/auth/login/recover-2.fhtml
View File

@ -1,9 +0,0 @@
<% USING: http.server.components ; %>
<html>
<body>
<h1>Recover lost password: step 2 of 4</h1>
<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
</body>
</html>

9
extra/http/server/auth/login/recover-2.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 2 of 4</t:title>
<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
</t:chloe>

46
extra/http/server/auth/login/recover-3.fhtml
View File

@ -1,46 +0,0 @@
<% USING: http.server.components http.server.auth.login http.server
namespaces kernel combinators ; %>
<html>
<body>
<h1>Recover lost password: step 3 of 4</h1>
<p>Choose a new password for your account.</p>
<form method="POST" action="new-password">
<% hidden-form-field %>
<table>
<% "username" component render-edit %>
<% "ticket" component render-edit %>
<tr>
<td>Password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify password:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p><input type="submit" value="Set password" />
<% password-mismatch? get [
"passwords do not match" render-error
] when %>
</p>
</form>
</body>
</html>

43
extra/http/server/auth/login/recover-3.xml Normal file
View File

@ -0,0 +1,43 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 3 of 4</t:title>
<p>Choose a new password for your account.</p>
<t:form action="new-password">
<table>
<t:edit component="username" />
<t:edit component="ticket" />
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify password:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p>
<input type="submit" value="Set password" />
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

10
extra/http/server/auth/login/recover-4.fhtml
View File

@ -1,10 +0,0 @@
<% USING: http.server ; %>
<html>
<body>
<h1>Recover lost password: step 4 of 4</h1>
<p>Your password has been reset.
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
</body>
</html>

9
extra/http/server/auth/login/recover-4.xml Executable file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 4 of 4</t:title>
<p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>
</t:chloe>

77
extra/http/server/auth/login/register.fhtml
View File

@ -1,77 +0,0 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>New user registration</h1>
<form method="POST" action="register">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></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>
<p><input type="submit" value="Register" />
<% {
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ user-exists? get ] [ "username taken" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

79
extra/http/server/auth/login/register.xml Normal file
View File

@ -0,0 +1,79 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New User Registration</t:title>
<t:form action="register">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
<td><t:edit component="realname" /></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</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>
<p>
<input type="submit" value="Register" />
<t:if var="http.server.auth.login:user-exists?">
<t:error>username taken</t:error>
</t:if>
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

49
extra/http/server/boilerplate/boilerplate.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings
io io.streams.string
http.server
http.server.templating ;
IN: http.server.boilerplate
TUPLE: boilerplate responder template ;
: <boilerplate> f boilerplate boa ;
SYMBOL: title
: set-title ( string -- )
title get >box ;
: write-title ( -- )
title get value>> write ;
SYMBOL: style
: add-style ( string -- )
"\n" style get push-all
style get push-all ;
: write-style ( -- )
style get >string write ;
SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
M: f call-template drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
style get [ SBUF" " clone style set ] unless
swap with-string-writer next-template set
call-template
] with-scope ; inline
M: boilerplate call-responder
[ responder>> call-responder clone ] [ template>> ] bi
[ [ with-boilerplate ] 2curry ] curry change-body ;

5
extra/http/server/components/components-tests.factor
View File

@ -2,6 +2,7 @@ IN: http.server.components.tests
USING: http.server.components http.server.forms USING: http.server.components http.server.forms
http.server.validators namespaces tools.test kernel accessors http.server.validators namespaces tools.test kernel accessors
tuple-syntax mirrors http.server.actions tuple-syntax mirrors http.server.actions
http.server.templating.fhtml
io.streams.string io.streams.null ; io.streams.string io.streams.null ;
\ render-edit must-infer \ render-edit must-infer
@ -49,8 +50,8 @@ TUPLE: test-tuple text number more-text ;
: <test-form> ( -- form ) : <test-form> ( -- form )
"test" <form> "test" <form>
"resource:extra/http/server/components/test/form.fhtml" >>view-template "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
"resource:extra/http/server/components/test/form.fhtml" >>edit-template "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
"text" <string> "text" <string>
t >>required t >>required
add-field add-field

21
extra/http/server/components/components.factor
View File

@ -203,22 +203,35 @@ M: captcha validate*
drop v-captcha ; drop v-captcha ;
! Text areas ! Text areas
TUPLE: textarea-renderer ; TUPLE: textarea-renderer rows cols ;
: textarea-renderer T{ textarea-renderer } ; : new-textarea-renderer ( class -- renderer )
new
60 >>cols
20 >>rows ;
: <textarea-renderer> ( -- renderer )
textarea-renderer new-textarea-renderer ;
M: textarea-renderer render-view* M: textarea-renderer render-view*
drop write ; drop write ;
M: textarea-renderer render-edit* M: textarea-renderer render-edit*
drop <textarea [ =id ] [ =name ] bi textarea> write </textarea> ; <textarea
[ rows>> [ number>string =rows ] when* ]
[ cols>> [ number>string =cols ] when* ] bi
[ =id ]
[ =name ] bi
textarea>
write
</textarea> ;
TUPLE: text < string ; TUPLE: text < string ;
: new-text ( id class -- component ) : new-text ( id class -- component )
new-string new-string
f >>one-line f >>one-line
textarea-renderer >>renderer ; <textarea-renderer> >>renderer ;
: <text> ( id -- component ) : <text> ( id -- component )
text new-text ; text new-text ;

5
extra/http/server/components/farkup/farkup.factor
View File

@ -6,11 +6,12 @@ IN: http.server.components.farkup
TUPLE: farkup-renderer < textarea-renderer ; TUPLE: farkup-renderer < textarea-renderer ;
: farkup-renderer T{ farkup-renderer } ; : <farkup-renderer>
farkup-renderer new-textarea-renderer ;
M: farkup-renderer render-view* M: farkup-renderer render-view*
drop string-lines "\n" join convert-farkup write ; drop string-lines "\n" join convert-farkup write ;
: <farkup> ( id -- component ) : <farkup> ( id -- component )
<text> <text>
farkup-renderer >>renderer ; <farkup-renderer> >>renderer ;

47
extra/http/server/crud/crud.factor
View File

@ -23,29 +23,18 @@ IN: http.server.crud
: <id-redirect> ( id next -- response ) : <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ; swap number>string "id" associate <permanent-redirect> ;
:: <create-action> ( form ctor next -- action )
<action>
[ f ctor call from-tuple form set-defaults ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
f ctor call from-tuple
form validate-form
values-tuple insert-tuple
"id" value next <id-redirect>
] >>submit ;
:: <edit-action> ( form ctor next -- action ) :: <edit-action> ( form ctor next -- action )
<action> <action>
{ { "id" [ v-number ] } } >>get-params { { "id" [ [ v-number ] v-optional ] } } >>get-params
[ "id" get ctor call select-tuple from-tuple ] >>init
[
"id" get ctor call
"id" get
[ select-tuple from-tuple ]
[ from-tuple form set-defaults ]
if
] >>init
[ [
"text/html" <content> "text/html" <content>
@ -57,7 +46,8 @@ IN: http.server.crud
form validate-form form validate-form
values-tuple update-tuple values-tuple
"id" value [ update-tuple ] [ insert-tuple ] if
"id" value next <id-redirect> "id" value next <id-redirect>
] >>submit ; ] >>submit ;
@ -71,3 +61,16 @@ IN: http.server.crud
next f <permanent-redirect> next f <permanent-redirect>
] >>submit ; ] >>submit ;
:: <list-action> ( form ctor -- action )
<action>
[
"text/html" <content>
[
blank-values
f ctor call select-tuples "list" set-value
form view-form
] >>body
] >>display ;

32
extra/http/server/forms/forms.factor
View File

@ -1,11 +1,13 @@
USING: kernel accessors assocs namespaces io.files fry USING: kernel accessors assocs namespaces io.files sequences fry
http.server.actions http.server.actions
http.server.components http.server.components
http.server.validators http.server.validators
http.server.templating.fhtml ; http.server.templating ;
IN: http.server.forms IN: http.server.forms
TUPLE: form < component view-template edit-template components ; TUPLE: form < component
view-template edit-template summary-template
components ;
M: form init V{ } clone >>components ; M: form init V{ } clone >>components ;
@ -28,10 +30,13 @@ M: form init V{ } clone >>components ;
] with-form ; ] with-form ;
: view-form ( form -- ) : view-form ( form -- )
dup view-template>> '[ , run-template ] with-form ; dup view-template>> '[ , call-template ] with-form ;
: edit-form ( form -- ) : edit-form ( form -- )
dup edit-template>> '[ , run-template ] with-form ; dup edit-template>> '[ , call-template ] with-form ;
: summary-form ( form -- )
dup summary-template>> '[ , call-template ] with-form ;
: validate-param ( id component -- ) : validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ] [ [ params get at ] [ validate ] bi* ]
@ -46,3 +51,20 @@ M: form init V{ } clone >>components ;
: validate-form ( form -- ) : validate-form ( form -- )
(validate-form) [ validation-failed ] when ; (validate-form) [ validation-failed ] when ;
! List components
TUPLE: list-renderer form ;
C: <list-renderer> list-renderer
M: list-renderer render-view*
form>> [
[ >r from-tuple r> summary-form ] with-scope
] curry each ;
TUPLE: list < component ;
: <list> ( id form -- list )
list swap <list-renderer> new-component ;
M: list component-string drop ;

97
extra/http/server/templating/chloe/chloe-tests.factor Normal file
View File

@ -0,0 +1,97 @@
USING: http.server.templating http.server.templating.chloe
http.server.components http.server.boilerplate tools.test
io.streams.string kernel sequences ascii boxes namespaces xml
splitting ;
IN: http.server.templating.chloe.tests
[ "foo" ]
[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
unit-test
[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
[ "href attribute is required" = ]
must-fail-with
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
blank-values
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
blank-values
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test
: run-template
with-string-writer [ "\r\n\t" member? not ] subset
"?>" split1 nip ; inline
: test-template ( name -- template )
"resource:extra/http/server/templating/chloe/test/"
swap
".xml" 3append <chloe> ;
[ "Hello world" ] [
[
"test1" test-template call-template
] run-template
] unit-test
[ "Blah blah" "Hello world" ] [
[
<box> title set
[
"test2" test-template call-template
] run-template
title get box>
] with-scope
] unit-test
[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
[
[
"test2" test-template call-template
] "test3" test-template with-boilerplate
] run-template
] unit-test
: test4-aux? t ;
[ "True" ] [
[
"test4" test-template call-template
] run-template
] unit-test
: test5-aux? f ;
[ "" ] [
[
"test5" test-template call-template
] run-template
] unit-test
SYMBOL: test6-aux?
[ "True" ] [
[
test6-aux? on
"test6" test-template call-template
] run-template
] unit-test
SYMBOL: test7-aux?
[ "" ] [
[
test7-aux? off
"test7" test-template call-template
] run-template
] unit-test

168
extra/http/server/templating/chloe/chloe.factor Normal file
View File

@ -0,0 +1,168 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays
io.files io.encodings.utf8 html.elements unicode.case
tuple-syntax xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.components
http.server.sessions
http.server.templating
http.server.boilerplate ;
IN: http.server.templating.chloe
! Chloe is Ed's favorite web designer
TUPLE: chloe path ;
C: <chloe> chloe
DEFER: process-template
: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
: chloe-tag? ( tag -- ? )
{
{ [ dup tag? not ] [ f ] }
{ [ dup chloe-ns names-match? not ] [ f ] }
[ t ]
} cond nip ;
SYMBOL: tags
: required-attr ( tag name -- value )
dup rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
swap at ;
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
: style-tag ( tag -- )
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
] unless
utf8 file-contents
] [
drop children>string
] if add-style ;
: write-style-tag ( tag -- )
drop <style> write-style </style> ;
: component-attr ( tag -- name )
"component" required-attr ;
: view-tag ( tag -- )
component-attr component render-view ;
: edit-tag ( tag -- )
component-attr component render-edit ;
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: a-start-tag ( tag -- )
<a
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi link>string =href
a> ;
: process-tag-children ( tag -- )
[ process-template ] each ;
: a-tag ( tag -- )
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: form-start-tag ( tag -- )
<form
"POST" =method
tag-attrs print-attrs
form>
hidden-form-field ;
: form-tag ( tag -- )
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
{
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
[ "var" optional-attr [ attr>var get ] [ t ] if* ]
[ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
[ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
} cleave 4array [ ] all? ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
: error-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
{ "title" [ children>string set-title ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "view" [ view-tag ] }
{ "edit" [ edit-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }
{ "if" [ if-tag ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ]
} case ;
: process-tag ( tag -- )
{
[ name-tag >lower tags get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tags get pop* ]
} cleave ;
: process-template ( xml -- )
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
: process-chloe ( xml -- )
[
V{ } clone tags set
{
[ xml-prolog write-prolog ]
[ xml-before write-chunk ]
[ process-template ]
[ xml-after write-chunk ]
} cleave
] with-scope ;
M: chloe call-template
path>> utf8 <file-reader> read-xml process-chloe ;

5
extra/http/server/templating/chloe/test/test1.xml Normal file
View File

@ -0,0 +1,5 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
Hello world
</t:chloe>

6
extra/http/server/templating/chloe/test/test2.xml Normal file
View File

@ -0,0 +1,6 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Hello world</t:title>
Blah blah
</t:chloe>

5
extra/http/server/templating/chloe/test/test3-aux.xml Normal file
View File

@ -0,0 +1,5 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Hello world</t:title>
</t:chloe>

12
extra/http/server/templating/chloe/test/test3.xml Normal file
View File

@ -0,0 +1,12 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<head>
<t:write-title />
</head>
<body>
<t:call-next-template />
</body>
</html>
</t:chloe>

9
extra/http/server/templating/chloe/test/test4.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if code="http.server.templating.chloe.tests:test4-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test5.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if code="http.server.templating.chloe.tests:test5-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test6.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if var="http.server.templating.chloe.tests:test6-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test7.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if var="http.server.templating.chloe.tests:test7-aux?">
True
</t:if>
</t:chloe>

6
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -1,13 +1,13 @@
USING: io io.files io.streams.string io.encodings.utf8 USING: io io.files io.streams.string io.encodings.utf8
http.server.templating.fhtml kernel tools.test sequences http.server.templating http.server.templating.fhtml kernel
parser ; tools.test sequences parser ;
IN: http.server.templating.fhtml.tests IN: http.server.templating.fhtml.tests
: test-template ( path -- ? ) : test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/" "resource:extra/http/server/templating/fhtml/test/"
prepend prepend
[ [
".fhtml" append [ run-template ] with-string-writer ".fhtml" append <fhtml> [ call-template ] with-string-writer
] keep ] keep
".html" append utf8 file-contents = ; ".html" append utf8 file-contents = ;

30
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2005 Alex Chapman ! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2008 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel parser namespaces io USING: continuations sequences kernel namespaces debugger
io.files io.streams.string html html.elements source-files combinators math quotations generic strings splitting
debugger combinators math quotations generic strings splitting accessors assocs fry
accessors http.server.static http.server assocs parser io io.files io.streams.string io.encodings.utf8 source-files
io.encodings.utf8 fry accessors ; html html.elements
http.server.static http.server http.server.templating ;
IN: http.server.templating.fhtml IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
@ -72,9 +72,13 @@ DEFER: <% delimiter
: html-error. ( error -- ) : html-error. ( error -- )
<pre> error. </pre> ; <pre> error. </pre> ;
: run-template ( filename -- ) TUPLE: fhtml path ;
C: <fhtml> fhtml
M: fhtml call-template ( filename -- )
'[ '[
, [ , path>> [
"quiet" on "quiet" on
parser-notes off parser-notes off
templating-vocab use+ templating-vocab use+
@ -85,16 +89,8 @@ DEFER: <% delimiter
] with-file-vocabs ] with-file-vocabs
] assert-depth ; ] assert-depth ;
: template-convert ( infile outfile -- )
utf8 [ run-template ] with-file-writer ;
! responder integration
: serve-template ( name -- response )
"text/html" <content>
swap '[ , run-template ] >>body ;
! file responder integration ! file responder integration
: enable-fhtml ( responder -- responder ) : enable-fhtml ( responder -- responder )
[ serve-template ] [ <fhtml> serve-template ]
"application/x-factor-server-page" "application/x-factor-server-page"
pick special>> set-at ; pick special>> set-at ;

13
extra/http/server/templating/templating.factor Normal file
View File

@ -0,0 +1,13 @@
USING: accessors kernel fry io.encodings.utf8 io.files
http.server ;
IN: http.server.templating
GENERIC: call-template ( template -- )
: template-convert ( template output -- )
utf8 [ call-template ] with-file-writer ;
! responder integration
: serve-template ( template -- response )
"text/html" <content>
swap '[ , call-template ] >>body ;

6
extra/http/server/validators/validators.factor
View File

@ -11,8 +11,7 @@ TUPLE: validation-error value reason ;
C: <validation-error> validation-error C: <validation-error> validation-error
: with-validator ( value quot -- result ) : with-validator ( value quot -- result )
[ validation-failed? on <validation-error> ] recover ; [ validation-failed? on <validation-error> ] recover ; inline
inline
: v-default ( str def -- str ) : v-default ( str def -- str )
over empty? spin ? ; over empty? spin ? ;
@ -20,6 +19,9 @@ C: <validation-error> validation-error
: v-required ( str -- str ) : v-required ( str -- str )
dup empty? [ "required" throw ] when ; dup empty? [ "required" throw ] when ;
: v-optional ( str quot -- str )
over empty? [ 2drop f ] [ call ] if ; inline
: v-min-length ( str n -- str ) : v-min-length ( str n -- str )
over length over < [ over length over < [
[ "must be at least " % # " characters" % ] "" make [ "must be at least " % # " characters" % ] "" make

30
extra/xml/writer/writer.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg ! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math namespaces sequences strings USING: hashtables kernel math namespaces sequences strings
io io.streams.string xml.data assocs wrap xml.entities assocs combinators io io.streams.string
unicode.categories ; xml.data wrap xml.entities unicode.categories ;
IN: xml.writer IN: xml.writer
SYMBOL: xml-pprint? SYMBOL: xml-pprint?
@ -61,6 +61,9 @@ M: string write-item
?indent CHAR: < write1 ?indent CHAR: < write1
dup print-name tag-attrs print-attrs ; dup print-name tag-attrs print-attrs ;
: write-start-tag ( tag -- )
write-tag ">" write ;
M: contained-tag write-item M: contained-tag write-item
write-tag "/>" write ; write-tag "/>" write ;
@ -72,11 +75,14 @@ M: contained-tag write-item
?indent "</" write print-name CHAR: > write1 ; ?indent "</" write print-name CHAR: > write1 ;
M: open-tag write-item M: open-tag write-item
xml-pprint? [ [ xml-pprint? get >r
over sensitive? not and xml-pprint? set {
dup write-tag CHAR: > write1 [ sensitive? not xml-pprint? get and xml-pprint? set ]
dup write-children write-end-tag [ write-start-tag ]
] keep ] change ; [ write-children ]
[ write-end-tag ]
} cleave
r> xml-pprint? set ;
M: comment write-item M: comment write-item
"<!--" write comment-text write "-->" write ; "<!--" write comment-text write "-->" write ;
@ -97,10 +103,12 @@ M: instruction write-item
[ write-item ] each ; [ write-item ] each ;
: write-xml ( xml -- ) : write-xml ( xml -- )
dup xml-prolog write-prolog {
dup xml-before write-chunk [ xml-prolog write-prolog ]
dup write-item [ xml-before write-chunk ]
xml-after write-chunk ; [ write-item ]
[ xml-after write-chunk ]
} cleave ;
: print-xml ( xml -- ) : print-xml ( xml -- )
write-xml nl ; write-xml nl ;