Merge branch 'clean-linux-x86-32' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
14456e3a13
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -54,10 +54,12 @@ IN: farkup.tests
|
||||||
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||||
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
|
[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
|
||||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||||
|
|
||||||
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||||
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||||
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays io kernel memoize namespaces peg sequences strings
|
USING: arrays io io.styles kernel memoize namespaces peg
|
||||||
html.elements xml.entities xmode.code2html splitting
|
sequences strings html.elements xml.entities xmode.code2html
|
||||||
io.streams.string html peg.parsers html.elements sequences.deep
|
splitting io.streams.string html peg.parsers html.elements
|
||||||
unicode.categories ;
|
sequences.deep unicode.categories ;
|
||||||
IN: farkup
|
IN: farkup
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
@ -55,7 +55,13 @@ MEMO: eq ( -- parser )
|
||||||
|
|
||||||
: render-code ( string mode -- string' )
|
: render-code ( string mode -- string' )
|
||||||
>r string-lines r>
|
>r string-lines r>
|
||||||
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
|
[
|
||||||
|
[
|
||||||
|
H{ { wrap-margin f } } [
|
||||||
|
htmlize-lines
|
||||||
|
] with-nesting
|
||||||
|
] with-html-stream
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
: escape-link ( href text -- href-esc text-esc )
|
: escape-link ( href text -- href-esc text-esc )
|
||||||
>r escape-quoted-string r> escape-string ;
|
>r escape-quoted-string r> escape-string ;
|
||||||
|
|
|
||||||
|
|
@ -394,13 +394,18 @@ body ;
|
||||||
[ unparse-cookies "set-cookie" pick set-at ] when*
|
[ unparse-cookies "set-cookie" pick set-at ] when*
|
||||||
write-header ;
|
write-header ;
|
||||||
|
|
||||||
|
GENERIC: write-response-body* ( body -- )
|
||||||
|
|
||||||
|
M: f write-response-body* drop ;
|
||||||
|
|
||||||
|
M: string write-response-body* write ;
|
||||||
|
|
||||||
|
M: callable write-response-body* call ;
|
||||||
|
|
||||||
|
M: object write-response-body* stdio get stream-copy ;
|
||||||
|
|
||||||
: write-response-body ( response -- response )
|
: write-response-body ( response -- response )
|
||||||
dup body>> {
|
dup body>> write-response-body* ;
|
||||||
{ [ dup not ] [ drop ] }
|
|
||||||
{ [ dup string? ] [ write ] }
|
|
||||||
{ [ dup callable? ] [ call ] }
|
|
||||||
[ stdio get stream-copy ]
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
M: response write-response ( respose -- )
|
M: response write-response ( respose -- )
|
||||||
write-response-version
|
write-response-version
|
||||||
|
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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
|
||||||
|
|
@ -62,10 +68,7 @@ M: user-saver dispose
|
||||||
<action>
|
<action>
|
||||||
[ blank-values ] >>init
|
[ blank-values ] >>init
|
||||||
|
|
||||||
[
|
[ form edit-form ] >>display
|
||||||
"text/html" <content>
|
|
||||||
[ form edit-form ] >>body
|
|
||||||
] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
@ -86,7 +89,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
|
||||||
|
|
@ -114,10 +117,7 @@ SYMBOL: user-exists?
|
||||||
<action>
|
<action>
|
||||||
[ blank-values ] >>init
|
[ blank-values ] >>init
|
||||||
|
|
||||||
[
|
[ form edit-form ] >>display
|
||||||
"text/html" <content>
|
|
||||||
[ form edit-form ] >>body
|
|
||||||
] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
@ -147,7 +147,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
|
||||||
|
|
@ -168,10 +168,7 @@ SYMBOL: previous-page
|
||||||
dup email>> "email" set-value
|
dup email>> "email" set-value
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[
|
[ form edit-form ] >>display
|
||||||
"text/html" <content>
|
|
||||||
[ form edit-form ] >>body
|
|
||||||
] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
@ -242,7 +239,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
|
||||||
|
|
@ -256,10 +253,7 @@ SYMBOL: lost-password-from
|
||||||
<action>
|
<action>
|
||||||
[ blank-values ] >>init
|
[ blank-values ] >>init
|
||||||
|
|
||||||
[
|
[ form edit-form ] >>display
|
||||||
"text/html" <content>
|
|
||||||
[ form edit-form ] >>body
|
|
||||||
] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
@ -271,13 +265,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
|
||||||
|
|
@ -308,10 +302,7 @@ SYMBOL: lost-password-from
|
||||||
] H{ } make-assoc values set
|
] H{ } make-assoc values set
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[
|
[ <recover-form-3> edit-form ] >>display
|
||||||
"text/html" <content>
|
|
||||||
[ <recover-form-3> edit-form ] >>body
|
|
||||||
] >>display
|
|
||||||
|
|
||||||
[
|
[
|
||||||
blank-values
|
blank-values
|
||||||
|
|
@ -326,8 +317,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 +357,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? ;
|
||||||
|
|
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -0,0 +1,58 @@
|
||||||
|
! 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
|
||||||
|
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: nested-template?
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
[
|
||||||
|
[
|
||||||
|
nested-template? on
|
||||||
|
write-response-body*
|
||||||
|
] with-string-writer
|
||||||
|
next-template set
|
||||||
|
]
|
||||||
|
[ call-template ]
|
||||||
|
bi*
|
||||||
|
] with-scope ; inline
|
||||||
|
|
||||||
|
M: boilerplate call-responder
|
||||||
|
[ responder>> call-responder clone ] [ template>> ] bi
|
||||||
|
[ [ with-boilerplate ] 2curry ] curry change-body ;
|
||||||
|
|
@ -1,11 +1,10 @@
|
||||||
IN: http.server.components.tests
|
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 http.server.actions http.server.templating.fhtml
|
||||||
io.streams.string io.streams.null ;
|
io.streams.string io.streams.null ;
|
||||||
|
|
||||||
\ render-edit must-infer
|
|
||||||
|
|
||||||
validation-failed? off
|
validation-failed? off
|
||||||
|
|
||||||
[ 3 ] [ "3" "n" <number> validate ] unit-test
|
[ 3 ] [ "3" "n" <number> validate ] unit-test
|
||||||
|
|
@ -49,8 +48,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
|
||||||
|
|
@ -64,9 +63,9 @@ TUPLE: test-tuple text number more-text ;
|
||||||
"hi" >>default
|
"hi" >>default
|
||||||
add-field ;
|
add-field ;
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test
|
[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
|
||||||
|
|
||||||
[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test
|
[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
|
||||||
|
|
||||||
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
|
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
|
||||||
<test-tuple> from-tuple
|
<test-tuple> from-tuple
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,12 @@ continuations math ;
|
||||||
IN: http.server.components
|
IN: http.server.components
|
||||||
|
|
||||||
! Renderer protocol
|
! Renderer protocol
|
||||||
|
GENERIC: render-summary* ( value renderer -- )
|
||||||
GENERIC: render-view* ( value renderer -- )
|
GENERIC: render-view* ( value renderer -- )
|
||||||
GENERIC: render-edit* ( value id renderer -- )
|
GENERIC: render-edit* ( value id renderer -- )
|
||||||
|
|
||||||
|
M: object render-summary* render-view* ;
|
||||||
|
|
||||||
TUPLE: field type ;
|
TUPLE: field type ;
|
||||||
|
|
||||||
C: <field> field
|
C: <field> field
|
||||||
|
|
@ -203,22 +206,67 @@ 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 ;
|
||||||
|
|
||||||
|
! List components
|
||||||
|
SYMBOL: +plain+
|
||||||
|
SYMBOL: +ordered+
|
||||||
|
SYMBOL: +unordered+
|
||||||
|
|
||||||
|
TUPLE: list-renderer component type ;
|
||||||
|
|
||||||
|
C: <list-renderer> list-renderer
|
||||||
|
|
||||||
|
: render-list ( value component -- )
|
||||||
|
[ render-summary* ] curry each ;
|
||||||
|
|
||||||
|
: render-ordered-list ( value component -- )
|
||||||
|
[ <li> render-summary* </li> ] curry each ;
|
||||||
|
|
||||||
|
: render-unordered-list ( value component -- )
|
||||||
|
[ <li> render-summary* </li> ] curry each ;
|
||||||
|
|
||||||
|
M: list-renderer render-view*
|
||||||
|
[ component>> ] [ type>> ] bi {
|
||||||
|
{ +plain+ [ render-list ] }
|
||||||
|
{ +ordered+ [ <ol> render-ordered-list </ol> ] }
|
||||||
|
{ +unordered+ [ <ul> render-unordered-list </ul> ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
TUPLE: list < component ;
|
||||||
|
|
||||||
|
: <list> ( id component type -- list )
|
||||||
|
<list-renderer> list swap new-component ;
|
||||||
|
|
||||||
|
M: list component-string drop ;
|
||||||
|
|
|
||||||
|
|
@ -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 ;
|
||||||
|
|
|
||||||
|
|
@ -15,49 +15,33 @@ IN: http.server.crud
|
||||||
|
|
||||||
[ "id" get ctor call select-tuple from-tuple ] >>init
|
[ "id" get ctor call select-tuple from-tuple ] >>init
|
||||||
|
|
||||||
[
|
[ form view-form ] >>display ;
|
||||||
"text/html" <content>
|
|
||||||
[ form view-form ] >>body
|
|
||||||
] >>display ;
|
|
||||||
|
|
||||||
: <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
|
|
||||||
|
|
||||||
[
|
[
|
||||||
"text/html" <content>
|
"id" get ctor call
|
||||||
[ form edit-form ] >>body
|
|
||||||
] >>display
|
"id" get
|
||||||
|
[ select-tuple from-tuple ]
|
||||||
|
[ from-tuple form set-defaults ]
|
||||||
|
if
|
||||||
|
] >>init
|
||||||
|
|
||||||
|
[ form edit-form ] >>display
|
||||||
|
|
||||||
[
|
[
|
||||||
f ctor call from-tuple
|
f ctor call from-tuple
|
||||||
|
|
||||||
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 +55,13 @@ IN: http.server.crud
|
||||||
|
|
||||||
next f <permanent-redirect>
|
next f <permanent-redirect>
|
||||||
] >>submit ;
|
] >>submit ;
|
||||||
|
|
||||||
|
:: <list-action> ( form ctor -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
blank-values
|
||||||
|
|
||||||
|
f ctor call select-tuples "list" set-value
|
||||||
|
|
||||||
|
form view-form
|
||||||
|
] >>display ;
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,16 @@
|
||||||
USING: kernel accessors assocs namespaces io.files fry
|
! Copyright (C) 2008 Slava Pestov
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel accessors assocs namespaces io.files sequences fry
|
||||||
|
http.server
|
||||||
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 ;
|
||||||
|
|
||||||
|
|
@ -15,8 +20,11 @@ M: form init V{ } clone >>components ;
|
||||||
: add-field ( form component -- form )
|
: add-field ( form component -- form )
|
||||||
dup id>> pick components>> set-at ;
|
dup id>> pick components>> set-at ;
|
||||||
|
|
||||||
|
: set-components ( form -- )
|
||||||
|
components>> components set ;
|
||||||
|
|
||||||
: with-form ( form quot -- )
|
: with-form ( form quot -- )
|
||||||
>r components>> components r> with-variable ; inline
|
[ [ set-components ] [ call ] bi* ] with-scope ; inline
|
||||||
|
|
||||||
: set-defaults ( form -- )
|
: set-defaults ( form -- )
|
||||||
[
|
[
|
||||||
|
|
@ -27,11 +35,16 @@ M: form init V{ } clone >>components ;
|
||||||
] assoc-each
|
] assoc-each
|
||||||
] with-form ;
|
] with-form ;
|
||||||
|
|
||||||
: view-form ( form -- )
|
: <form-response> ( form template -- response )
|
||||||
dup view-template>> '[ , run-template ] with-form ;
|
[ components>> components set ]
|
||||||
|
[ "text/html" <content> swap >>body ]
|
||||||
|
bi* ;
|
||||||
|
|
||||||
: edit-form ( form -- )
|
: view-form ( form -- response )
|
||||||
dup edit-template>> '[ , run-template ] with-form ;
|
dup view-template>> <form-response> ;
|
||||||
|
|
||||||
|
: edit-form ( form -- response )
|
||||||
|
dup edit-template>> <form-response> ;
|
||||||
|
|
||||||
: validate-param ( id component -- )
|
: validate-param ( id component -- )
|
||||||
[ [ params get at ] [ validate ] bi* ]
|
[ [ params get at ] [ validate ] bi* ]
|
||||||
|
|
@ -46,3 +59,20 @@ M: form init V{ } clone >>components ;
|
||||||
|
|
||||||
: validate-form ( form -- )
|
: validate-form ( form -- )
|
||||||
(validate-form) [ validation-failed ] when ;
|
(validate-form) [ validation-failed ] when ;
|
||||||
|
|
||||||
|
: render-form ( value form template -- )
|
||||||
|
[
|
||||||
|
[ from-tuple ]
|
||||||
|
[ set-components ]
|
||||||
|
[ call-template ]
|
||||||
|
tri*
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M: form render-summary*
|
||||||
|
dup summary-template>> render-form ;
|
||||||
|
|
||||||
|
M: form render-view*
|
||||||
|
dup view-template>> render-form ;
|
||||||
|
|
||||||
|
M: form render-edit*
|
||||||
|
dup edit-template>> render-form ;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -0,0 +1,174 @@
|
||||||
|
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
|
||||||
|
|
||||||
|
nested-template? get [
|
||||||
|
process-template
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
[ xml-prolog write-prolog ]
|
||||||
|
[ xml-before write-chunk ]
|
||||||
|
[ process-template ]
|
||||||
|
[ xml-after write-chunk ]
|
||||||
|
} cleave
|
||||||
|
] if
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
M: chloe call-template
|
||||||
|
path>> utf8 <file-reader> read-xml process-chloe ;
|
||||||
|
|
||||||
|
INSTANCE: chloe template
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
Hello world
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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 = ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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,10 @@ 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 ;
|
||||||
|
|
||||||
|
INSTANCE: fhtml template
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,17 @@
|
||||||
|
USING: accessors kernel fry io.encodings.utf8 io.files
|
||||||
|
http http.server ;
|
||||||
|
IN: http.server.templating
|
||||||
|
|
||||||
|
MIXIN: template
|
||||||
|
|
||||||
|
GENERIC: call-template ( template -- )
|
||||||
|
|
||||||
|
M: template write-response-body* call-template ;
|
||||||
|
|
||||||
|
: template-convert ( template output -- )
|
||||||
|
utf8 [ call-template ] with-file-writer ;
|
||||||
|
|
||||||
|
! responder integration
|
||||||
|
: serve-template ( template -- response )
|
||||||
|
"text/html" <content>
|
||||||
|
swap '[ , call-template ] >>body ;
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
! Copyright (c) 2008 Eric Mertens
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays assocs kernel math math.ranges sequences ;
|
||||||
|
|
||||||
|
IN: project-euler.164
|
||||||
|
|
||||||
|
! http://projecteuler.net/index.php?section=problems&id=164
|
||||||
|
|
||||||
|
! DESCRIPTION
|
||||||
|
! -----------
|
||||||
|
|
||||||
|
! How many 20 digit numbers n (without any leading zero) exist such
|
||||||
|
! that no three consecutive digits of n have a sum greater than 9?
|
||||||
|
|
||||||
|
! SOLUTION
|
||||||
|
! --------
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: next-keys ( key -- keys )
|
||||||
|
[ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
|
||||||
|
|
||||||
|
: next-table ( assoc -- assoc )
|
||||||
|
H{ } clone swap
|
||||||
|
[ swap next-keys [ pick at+ ] with each ] assoc-each ;
|
||||||
|
|
||||||
|
: init-table ( -- assoc )
|
||||||
|
9 [1,b] [ 1array 1 ] H{ } map>assoc ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: euler164 ( -- n )
|
||||||
|
init-table 19 [ next-table ] times values sum ;
|
||||||
|
|
@ -0,0 +1,26 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>Edit Item</t:title>
|
||||||
|
|
||||||
|
<t:form action="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 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:form action="delete" class="inline">
|
||||||
|
<t:edit component="id" />
|
||||||
|
<button type="submit" class="link-button link">Delete</button>
|
||||||
|
</t:form>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,45 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
|
||||||
|
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
||||||
|
|
||||||
|
<html xmlns="http://www.w3.org/1999/xhtml">
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<head>
|
||||||
|
<t:write-title />
|
||||||
|
|
||||||
|
<t:style>
|
||||||
|
body, button {
|
||||||
|
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
|
||||||
|
color:#444;
|
||||||
|
}
|
||||||
|
|
||||||
|
a, .link {
|
||||||
|
color: #222;
|
||||||
|
border-bottom:1px dotted #666;
|
||||||
|
text-decoration:none;
|
||||||
|
}
|
||||||
|
|
||||||
|
a:hover, .link:hover {
|
||||||
|
border-bottom:1px solid #66a;
|
||||||
|
}
|
||||||
|
|
||||||
|
.error { color: #a00; }
|
||||||
|
|
||||||
|
.field-label {
|
||||||
|
text-align: right;
|
||||||
|
}
|
||||||
|
</t:style>
|
||||||
|
|
||||||
|
<t:write-style />
|
||||||
|
</head>
|
||||||
|
|
||||||
|
<body>
|
||||||
|
<t:call-next-template />
|
||||||
|
</body>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
||||||
|
</html>
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>My Todo List</t:title>
|
||||||
|
|
||||||
|
<table class="todo-list">
|
||||||
|
<tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
|
||||||
|
<t:view component="list" />
|
||||||
|
</table>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<tr>
|
||||||
|
<td>
|
||||||
|
<t:view component="summary" />
|
||||||
|
</td>
|
||||||
|
<td>
|
||||||
|
<t:view component="priority" />
|
||||||
|
</td>
|
||||||
|
<td>
|
||||||
|
<t:a href="view" query="id">View</t:a>
|
||||||
|
</td>
|
||||||
|
<td>
|
||||||
|
<t:a href="edit" query="id">Edit</t:a>
|
||||||
|
</td>
|
||||||
|
</tr>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,41 @@
|
||||||
|
.big-field-label {
|
||||||
|
vertical-align: top;
|
||||||
|
}
|
||||||
|
|
||||||
|
.description {
|
||||||
|
border: 1px dashed #ccc;
|
||||||
|
background-color: #f5f5f5;
|
||||||
|
padding: 5px;
|
||||||
|
font-size: 150%;
|
||||||
|
color: #000000;
|
||||||
|
}
|
||||||
|
|
||||||
|
.link-button {
|
||||||
|
padding: 0px;
|
||||||
|
background: none;
|
||||||
|
border: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navbar {
|
||||||
|
background-color: #eeeeee;
|
||||||
|
padding: 5px;
|
||||||
|
border: 1px solid #ccc;
|
||||||
|
}
|
||||||
|
|
||||||
|
.inline {
|
||||||
|
display: inline;
|
||||||
|
}
|
||||||
|
|
||||||
|
pre {
|
||||||
|
font-size: 75%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.todo-list {
|
||||||
|
border-style: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.todo-list td, .todo-list th {
|
||||||
|
border-width: 1px;
|
||||||
|
padding: 2px;
|
||||||
|
border-style: solid;
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,113 @@
|
||||||
|
! Copyright (c) 2008 Slava Pestov
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors kernel locals sequences
|
||||||
|
db db.types db.tuples
|
||||||
|
http.server.components http.server.components.farkup
|
||||||
|
http.server.forms http.server.templating.chloe
|
||||||
|
http.server.boilerplate http.server.crud http.server.auth
|
||||||
|
http.server.actions http.server.db
|
||||||
|
http.server ;
|
||||||
|
IN: webapps.todo
|
||||||
|
|
||||||
|
TUPLE: todo uid id priority summary description ;
|
||||||
|
|
||||||
|
todo "TODO"
|
||||||
|
{
|
||||||
|
{ "uid" "UID" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "id" "ID" +native-id+ }
|
||||||
|
{ "priority" "PRIORITY" INTEGER +not-null+ }
|
||||||
|
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||||
|
{ "description" "DESCRIPTION" { VARCHAR 256 } }
|
||||||
|
} define-persistent
|
||||||
|
|
||||||
|
: init-todo-table todo ensure-table ;
|
||||||
|
|
||||||
|
: <todo> ( id -- todo )
|
||||||
|
todo new
|
||||||
|
swap >>id
|
||||||
|
uid >>uid ;
|
||||||
|
|
||||||
|
: todo-template ( name -- template )
|
||||||
|
"resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
|
||||||
|
|
||||||
|
: <todo-form> ( -- form )
|
||||||
|
"todo" <form>
|
||||||
|
"view-todo" todo-template >>view-template
|
||||||
|
"edit-todo" todo-template >>edit-template
|
||||||
|
"todo-summary" todo-template >>summary-template
|
||||||
|
"id" <integer>
|
||||||
|
hidden >>renderer
|
||||||
|
add-field
|
||||||
|
"summary" <string>
|
||||||
|
t >>required
|
||||||
|
add-field
|
||||||
|
"priority" <integer>
|
||||||
|
t >>required
|
||||||
|
0 >>default
|
||||||
|
0 >>min-value
|
||||||
|
10 >>max-value
|
||||||
|
add-field
|
||||||
|
"description" <farkup>
|
||||||
|
add-field ;
|
||||||
|
|
||||||
|
: <todo-list-form> ( -- form )
|
||||||
|
"todo-list" <form>
|
||||||
|
"todo-list" todo-template >>view-template
|
||||||
|
"list" <todo-form> +plain+ <list>
|
||||||
|
add-field ;
|
||||||
|
|
||||||
|
TUPLE: todo-responder < dispatcher ;
|
||||||
|
|
||||||
|
:: <todo-responder> ( -- responder )
|
||||||
|
[let | todo-form [ <todo-form> ]
|
||||||
|
list-form [ <todo-list-form> ]
|
||||||
|
ctor [ [ <todo> ] ] |
|
||||||
|
todo-responder 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
|
||||||
|
<boilerplate>
|
||||||
|
"todo" todo-template >>template
|
||||||
|
] ;
|
||||||
|
|
||||||
|
! What follows below is somewhat akin to a 'deployment descriptor'
|
||||||
|
! for the todo application. The <todo-responder> can be integrated
|
||||||
|
! into an existing web app that provides session management and
|
||||||
|
! login facilities, or <todo-app> can be used to run a
|
||||||
|
! self-contained todo instance.
|
||||||
|
USING: namespaces io.files io.sockets
|
||||||
|
db.sqlite smtp
|
||||||
|
http.server.sessions
|
||||||
|
http.server.auth.login
|
||||||
|
http.server.auth.providers.db
|
||||||
|
http.server.sessions.storage.db ;
|
||||||
|
|
||||||
|
: test-db "todo.db" resource-path sqlite-db ;
|
||||||
|
|
||||||
|
: <todo-app> ( -- responder )
|
||||||
|
<todo-responder>
|
||||||
|
<login>
|
||||||
|
users-in-db >>users
|
||||||
|
allow-registration
|
||||||
|
allow-password-recovery
|
||||||
|
allow-edit-profile
|
||||||
|
<boilerplate>
|
||||||
|
"page" todo-template >>template
|
||||||
|
<url-sessions>
|
||||||
|
sessions-in-db >>sessions
|
||||||
|
test-db <db-persistence> ;
|
||||||
|
|
||||||
|
: init-todo ( -- )
|
||||||
|
"factorcode.org" 25 <inet> smtp-server set-global
|
||||||
|
"todo@factorcode.org" lost-password-from set-global
|
||||||
|
|
||||||
|
test-db [
|
||||||
|
init-todo-table
|
||||||
|
init-users-table
|
||||||
|
init-sessions-table
|
||||||
|
] with-db
|
||||||
|
|
||||||
|
<dispatcher>
|
||||||
|
<todo-app> "todo" add-responder
|
||||||
|
main-responder set-global ;
|
||||||
|
|
@ -0,0 +1,26 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<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:if code="http.server.auth.login:allow-edit-profile?">
|
||||||
|
| <t:a href="edit-profile">Edit Profile</t:a>
|
||||||
|
</t:if>
|
||||||
|
|
||||||
|
<t:form action="logout" class="inline">
|
||||||
|
| <button type="submit" class="link-button link">Logout</button>
|
||||||
|
</t:form>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<h1><t:write-title /></h1>
|
||||||
|
|
||||||
|
<t:call-next-template />
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -0,0 +1,23 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>View Item</t:title>
|
||||||
|
|
||||||
|
<table>
|
||||||
|
<tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr>
|
||||||
|
<tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr>
|
||||||
|
</table>
|
||||||
|
|
||||||
|
<div class="description">
|
||||||
|
<t:view component="description" />
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<t:a href="edit" query="id">Edit</t:a>
|
||||||
|
|
|
||||||
|
<t:form action="delete" class="inline">
|
||||||
|
<t:edit component="id" />
|
||||||
|
<button class="link-button link">Delete</button>
|
||||||
|
</t:form>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -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 ;
|
||||||
|
|
|
||||||
|
|
@ -36,9 +36,13 @@ TAGS>
|
||||||
f \ modes set-global ;
|
f \ modes set-global ;
|
||||||
|
|
||||||
MEMO: (load-mode) ( name -- rule-sets )
|
MEMO: (load-mode) ( name -- rule-sets )
|
||||||
modes at mode-file
|
modes at [
|
||||||
"extra/xmode/modes/" prepend
|
mode-file
|
||||||
resource-path utf8 <file-reader> parse-mode ;
|
"extra/xmode/modes/" prepend
|
||||||
|
resource-path utf8 <file-reader> parse-mode
|
||||||
|
] [
|
||||||
|
"text" (load-mode)
|
||||||
|
] if* ;
|
||||||
|
|
||||||
SYMBOL: rule-sets
|
SYMBOL: rule-sets
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue