: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
- <table>
+ <table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
- <table>
+ <table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
+ <html>
+ <head> <title> swap write </title> </head>
<body> call </body>
</html> ;
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
+ <html>
+ <head>
+ <title> rot write </title>
+ swap call
+ </head>
<body> call </body>
</html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
: assoc>query ( hash -- str )
[
{
- { [ dup number? ] [ number>string ] }
+ { [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
http.server http.server.validators http hashtables namespaces\r
-fry continuations locals ;\r
+fry continuations locals boxes xml.entities html.elements io ;\r
IN: http.server.actions\r
\r
-SYMBOL: +path+\r
-\r
SYMBOL: params\r
\r
+SYMBOL: validation-message\r
+\r
+: render-validation-message ( -- )\r
+ validation-message get value>> [\r
+ <span "error" =class span>\r
+ escape-string write\r
+ </span>\r
+ ] when* ;\r
+\r
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
: validation-failed ( -- * )\r
action get display>> call exit-with ;\r
\r
+: validation-failed-with ( string -- * )\r
+ validation-message get >box\r
+ validation-failed ;\r
+\r
M: action call-responder* ( path action -- response )\r
'[\r
, [ CHAR: / = ] right-trim empty? [\r
, action set\r
request get\r
+ <box> validation-message set\r
[ request-params params set ]\r
[\r
method>> {\r
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
-
<div class="navbar">
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>Edit User</t:title>
- <t:form t:action="$user-admin/edit">
-
- <t:edit t:component="username" />
+ <t:form t:action="$user-admin/edit" t:for="username">
<table>
<p>
<button type="submit" class="link-button link">Update</button>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
- <t:form t:action="$user-admin/delete">
- <t:edit t:component="username" />
-
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
</t:chloe>
<p>
<button type="submit" class="link-button link">Create</button>
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
<p>
<input type="submit" value="Update" />
-
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid password</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
-SYMBOL: login-failed?\r
-\r
TUPLE: login < dispatcher users checksum ;\r
\r
: users ( -- provider )\r
username>> set-uid\r
"$login" end-flow ;\r
\r
+: login-failed "invalid username or password" validation-failed-with ;\r
+\r
:: <login-action> ( -- action )\r
[let | form [ <login-form> ] |\r
<action>\r
\r
form validate-form\r
\r
- "password" value "username" value check-login [\r
- successful-login\r
- ] [\r
- login-failed? on\r
- validation-failed\r
- ] if*\r
+ "password" value "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
] >>submit\r
] ;\r
\r
"email" <email> add-field\r
"captcha" <captcha> add-field ;\r
\r
-SYMBOL: password-mismatch?\r
-SYMBOL: user-exists?\r
+: password-mismatch "passwords do not match" validation-failed-with ;\r
+\r
+: user-exists "username taken" validation-failed-with ;\r
\r
: same-password-twice ( -- )\r
- "new-password" value "verify-password" value = [ \r
- password-mismatch? on\r
- validation-failed\r
- ] unless ;\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
\r
:: <register-action> ( -- action )\r
[let | form [ <register-form> ] |\r
"email" value >>email\r
H{ } clone >>profile\r
\r
- users new-user [\r
- user-exists? on\r
- validation-failed\r
- ] unless*\r
+ users new-user [ user-exists ] unless*\r
\r
successful-login\r
\r
same-password-twice\r
\r
"password" value uid check-login\r
- [ login-failed? on validation-failed ] unless\r
+ [ login-failed ] unless\r
\r
"new-password" value >>encoded-password\r
] unless\r
<p>
<input type="submit" value="Log in" />
+ <t:validation-message />
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid username or password</t:error>
- </t:if>
</p>
</t:form>
<p>
<input type="submit" value="Set password" />
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
<p>
<input type="submit" value="Register" />
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components xml.entities ;
+http.server.components html xml.entities ;
IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ;
swap >>mode ;
M: code-renderer render-view*
- [ string-lines ] [ mode>> value ] bi* htmlize-lines ;
+ [
+ [ string-lines ] [ mode>> value ] bi* htmlize-lines
+ ] with-html-stream ;
: <code> ( id mode -- component )
swap <text>
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry locals combinators continuations math
-calendar.format html.elements xml.entities
+calendar.format html html.elements xml.entities
http.server.validators ;
IN: http.server.components
M: field render-edit*
<input type>> =type =name =value input/> ;
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
-
TUPLE: hidden < field ;
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 html.elements unicode.case
-tuple-syntax xml xml.data xml.writer xml.utilities
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax html html.elements
+multiline xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.flows
+http.server.actions
http.server.components
http.server.sessions
http.server.templating
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-: filter-chloe-attrs ( assoc -- assoc' )
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
: optional-attr ( tag name -- value )
chloe-name swap at ;
+: children>string ( tag -- string )
+ [ [ process-template ] each ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
: form-start-tag ( tag -- )
[
- <form
- "POST" =method
- {
- [ flow-attr ]
- [ session-attr ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs filter-chloe-attrs print-attrs ]
- } cleave
- form>
- hidden-form-field
+ [
+ <form
+ "POST" =method
+ {
+ [ flow-attr ]
+ [ session-attr ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
+ form>
+ ] [
+ hidden-form-field
+ "for" optional-attr [ component render-edit ] when*
+ ] bi
] with-scope ;
: form-tag ( tag -- )
[ drop </form> ]
tri ;
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+ tag-attrs swap update ;
+
+: button-tag ( tag -- )
+ button-tag-markup string>xml delegate
+ {
+ [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
+ [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
+ [ >r children>string 1array r> "button" tag-named set-tag-children ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
+
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
] unless ;
: if-satisfied? ( tag -- ? )
+ t swap
{
- [ "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? ;
+ [ "code" optional-attr [ attr>word execute and ] when* ]
+ [ "var" optional-attr [ attr>var get and ] when* ]
+ [ "svar" optional-attr [ attr>var sget and ] when* ]
+ [ "uvar" optional-attr [ attr>var uget and ] when* ]
+ [ "value" optional-attr [ value and ] when* ]
+ } cleave ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-: error-tag ( tag -- )
+: error-message-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
- { "title" [ children>string set-title ] }
+ { "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
- { "error" [ error-tag ] }
+ { "button" [ button-tag ] }
+ { "error-message" [ error-message-tag ] }
+ { "validation-message" [ drop render-validation-message ] }
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
border: 1px dashed #ccc;
background-color: #f5f5f5;
padding: 5px;
- font-size: 150%;
- color: #000000;
+ color: #000;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
}
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
</table>
- <div class="description">
- <t:view t:component="contents" />
- </div>
+ <pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-annotation" class="inline">
- <t:edit t:component="id" />
- <t:edit t:component="aid" />
- <button class="link-button link">Delete Annotation</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
</t:chloe>
<t:title>New Annotation</t:title>
- <t:form t:action="$pastebin/annotate">
- <t:edit t:component="id" />
+ <t:form t:action="$pastebin/annotate" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
- <td><t:a t:href="view-paste" query="id"><t:view t:component="summary" /></t:a></td>
+ <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
<td><t:view t:component="author" /></td>
<td><t:view t:component="date" /></td>
</tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Pastebin</t:title>
-
- <h2>Paste: <t:view t:component="summary" /></h2>
+ <t:title>Paste: <t:view t:component="summary" /></t:title>
<table>
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
<pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-paste" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete Paste</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
:: <delete-annotation-action> ( ctor next -- action )
<action>
- { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
+ { { "aid" [ v-number ] } } >>post-params
[
- "id" get "aid" get ctor call delete-tuples
-
- "id" get next <id-redirect>
+ f "aid" get ctor call select-tuple
+ [ delete-tuples ] [ id>> next <id-redirect> ] bi
] >>submit ;
:: <new-paste-action> ( form ctor next -- action )
<feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
[ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
- [ <annotation> ] "$pastebin/view-paste"
{ can-delete-pastes? } <delete-annotation-action> <protected> "delete-annotation" add-responder
+ [ <annotation> ] "$pastebin/view-paste"
<delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/edit-blog">
-
- <t:edit t:component="id" />
+ <t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
<table>
</t:form>
- <t:form t:action="$planet-factor/admin/delete-blog" class="inline">
- <t:edit t:component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
<t:title>Edit Item</t:title>
- <t:form t:action="$todo-list/edit">
- <t:edit t:component="id" />
-
+ <t:form t:action="$todo-list/edit" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
<input type="SUBMIT" value="Done" />
</t:form>
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- |
- <t:form t:action="$todo-list/delete" t:class="inline">
- <t:edit t:component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:if t:value="id">
+
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ |
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
+
+ </t:if>
</t:chloe>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
|
- <t:form t:action="$todo-list/delete" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
projects / factor.git / commitdiff