Web framework work in progress

db4
Slava Pestov 2008-04-20 04:19:06 -05:00
parent d1f37ab5ec
commit e2a185f1f4
19 changed files with 557 additions and 36 deletions

View File

@ -1,7 +1,8 @@
! 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
io io.streams.string arrays
html.elements
http
http.server
http.server.templating ;
@ -28,6 +29,18 @@ SYMBOL: style
: write-style ( -- )
style get >string write ;
SYMBOL: atom-feed
: set-atom-feed ( title url -- )
2array atom-feed get >box ;
: write-atom-feed ( -- )
atom-feed get value>> [
<link "alternate" =rel "application/atom+xml" =type
[ first =title ] [ second =href ] bi
link/>
] when* ;
SYMBOL: nested-template?
SYMBOL: next-template
@ -40,6 +53,7 @@ M: f call-template drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
atom-feed get [ <box> atom-feed set ] unless
style get [ SBUF" " clone style set ] unless
[
@ -54,5 +68,8 @@ M: f call-template drop call-next-template ;
] with-scope ; inline
M: boilerplate call-responder
[ responder>> call-responder clone ] [ template>> ] bi
[ [ with-boilerplate ] 2curry ] curry change-body ;
tuck responder>> call-responder
dup "content-type" header "text/html" = [
clone swap template>>
[ [ with-boilerplate ] 2curry ] curry change-body
] [ nip ] if ;

View File

@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
[ ] [ "password" <password> "p" set ] unit-test
[ ] [ "pub-date" <date> "d" set ] unit-test

View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements http.server.validators accessors namespaces
kernel io math.parser assocs classes words classes.tuple arrays
sequences splitting mirrors hashtables fry combinators
continuations math ;
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math
calendar.format html.elements
http.server.validators ;
IN: http.server.components
! Renderer protocol
@ -59,9 +60,14 @@ SYMBOL: values
: values-tuple values get mirror-object ;
: render-view-or-summary ( component -- value renderer )
[ id>> value ] [ component-string ] [ renderer>> ] tri ;
: render-view ( component -- )
[ id>> value ] [ component-string ] [ renderer>> ] tri
render-view* ;
render-view-or-summary render-view* ;
: render-summary ( component -- )
render-view-or-summary render-summary* ;
<PRIVATE
@ -147,6 +153,17 @@ TUPLE: email < string ;
M: email validate*
call-next-method dup empty? [ v-email ] unless ;
! URL fields
TUPLE: url < string ;
: <url> ( id -- component )
url new-string
5 >>min-length
60 >>max-length ;
M: url validate*
call-next-method dup empty? [ v-url ] unless ;
! Don't send passwords back to the user
TUPLE: password-renderer < field ;
@ -206,20 +223,20 @@ M: captcha validate*
drop v-captcha ;
! Text areas
TUPLE: textarea-renderer rows cols ;
TUPLE: text-renderer rows cols ;
: new-textarea-renderer ( class -- renderer )
: new-text-renderer ( class -- renderer )
new
60 >>cols
20 >>rows ;
: <textarea-renderer> ( -- renderer )
textarea-renderer new-textarea-renderer ;
: <text-renderer> ( -- renderer )
text-renderer new-text-renderer ;
M: textarea-renderer render-view*
M: text-renderer render-view*
drop write ;
M: textarea-renderer render-edit*
M: text-renderer render-edit*
<textarea
[ rows>> [ number>string =rows ] when* ]
[ cols>> [ number>string =cols ] when* ] bi
@ -234,11 +251,35 @@ TUPLE: text < string ;
: new-text ( id class -- component )
new-string
f >>one-line
<textarea-renderer> >>renderer ;
<text-renderer> >>renderer ;
: <text> ( id -- component )
text new-text ;
! HTML text component
TUPLE: html-text-renderer < text-renderer ;
: <html-text-renderer> ( -- renderer )
html-text-renderer new-text-renderer ;
M: html-text-renderer render-view*
drop write ;
TUPLE: html-text < text ;
: <html-text> ( id -- component )
html-text new-text
<html-text-renderer> >>renderer ;
! Date component
TUPLE: date < string ;
: <date> ( id -- component )
date new-string ;
M: date component-string
drop timestamp>string ;
! List components
SYMBOL: +plain+
SYMBOL: +ordered+
@ -248,21 +289,27 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer
: render-list ( value component -- )
[ render-summary* ] curry each ;
: render-plain-list ( seq quot component -- )
swap '[ , @ ] each ; inline
: render-ordered-list ( value component -- )
[ <li> render-summary* </li> ] curry each ;
: render-ordered-list ( seq quot component -- )
swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
: render-unordered-list ( value component -- )
[ <li> render-summary* </li> ] curry each ;
: render-unordered-list ( seq quot component -- )
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
: render-list ( value renderer quot -- )
swap [ component>> ] [ type>> ] bi {
{ +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] }
} case ; inline
M: list-renderer render-view*
[ component>> ] [ type>> ] bi {
{ +plain+ [ render-list ] }
{ +ordered+ [ <ol> render-ordered-list </ol> ] }
{ +unordered+ [ <ul> render-unordered-list </ul> ] }
} case ;
[ render-view* ] render-list ;
M: list-renderer render-summary*
[ render-summary* ] render-list ;
TUPLE: list < component ;

View File

@ -4,10 +4,10 @@ USING: splitting kernel io sequences farkup accessors
http.server.components ;
IN: http.server.components.farkup
TUPLE: farkup-renderer < textarea-renderer ;
TUPLE: farkup-renderer < text-renderer ;
: <farkup-renderer>
farkup-renderer new-textarea-renderer ;
: <farkup-renderer> ( -- renderer )
farkup-renderer new-text-renderer ;
M: farkup-renderer render-view*
drop string-lines "\n" join convert-farkup write ;

View File

@ -15,7 +15,8 @@ components ;
M: form init V{ } clone >>components ;
: <form> ( id -- form )
form f new-component ;
form f new-component
dup >>renderer ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
@ -68,6 +69,8 @@ M: form init V{ } clone >>components ;
tri*
] with-scope ;
M: form component-string drop ;
M: form render-summary*
dup summary-template>> render-form ;

View File

@ -1,6 +1,6 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays
io.files io.encodings.utf8 html.elements unicode.case
io io.files io.encodings.utf8 html.elements unicode.case
tuple-syntax xml xml.data xml.writer xml.utilities
http.server
http.server.auth
@ -54,6 +54,19 @@ SYMBOL: tags
: write-style-tag ( tag -- )
drop <style> write-style </style> ;
: atom-tag ( tag -- )
[ "title" required-attr ]
[ "href" required-attr ]
bi set-atom-feed ;
: write-atom-tag ( tag -- )
drop
"head" tags get member? [
write-atom-feed
] [
atom-feed get value>> second write
] if ;
: component-attr ( tag -- name )
"component" required-attr ;
@ -63,15 +76,20 @@ SYMBOL: tags
: edit-tag ( tag -- )
component-attr component render-edit ;
: summary-tag ( tag -- )
component-attr component render-summary ;
: 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
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if link>string =href
a> ;
: process-tag-children ( tag -- )
@ -126,8 +144,11 @@ SYMBOL: tags
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "atom" [ atom-tag ] }
{ "write-atom" [ write-atom-tag ] }
{ "view" [ view-tag ] }
{ "edit" [ edit-tag ] }
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }

View File

@ -21,3 +21,9 @@ accessors ;
[ "slava@factorcodeorg" v-email ]
[ "invalid e-mail" = ] must-fail-with
[ "http://www.factorcode.org" ]
[ "http://www.factorcode.org" v-url ] unit-test
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with

View File

@ -65,7 +65,12 @@ C: <validation-error> validation-error
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;
: v-url ( str -- str )
"URL"
R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
: v-captcha ( str -- str )

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
</t:chloe>

View File

@ -0,0 +1,40 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Edit Blog</t:title>
<t:form action="edit-blog">
<t:edit component="id" />
<table>
<tr>
<th class="field-label">Blog name:</th>
<td><t:edit component="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
<td><t:edit component="www-url" /></td>
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td><t:edit component="atom-url" /></td>
</tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
<t:a href="view" query="id">View</t:a>
|
<t:form action="delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>

View File

@ -0,0 +1,10 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<p class="news">
<strong><t:view component="title" /></strong> <br/>
<t:a value="link" class="more">Read More...</t:a>
</p>
</t:chloe>

View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title"><t:view component="title" /></h2>
<p class="posting-body"> <t:view component="description" /> </p>
<p class="posting-date"> <t:view component="pub-date" /> </p>
</t:chloe>

View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:summary component="postings" />
</t:chloe>

View File

@ -0,0 +1,64 @@
<?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:write-atom />
<t:style>
.link-button {
padding: 0px;
background: none;
border: none;
}
.inline {
display: inline;
}
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;
}
h1 a {
border: 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>
<h1><t:a href="planet"><t:write-title /></t:a></h1>
<t:call-next-template />
</body>
</t:chloe>
</html>

View File

@ -0,0 +1,30 @@
h1.planet-title {
font-size:300%;
}
.posting-title {
background-color:#f5f5f5;
}
pre, code {
color:#000000;
font-size:120%;
}
.infobox {
border-left: 1px solid #C1DAD7;
}
.posting-date {
text-align: right;
font-size:90%;
}
a.more {
display:block;
padding:0 0 5px 0;
color:#333;
text-decoration:none;
text-align:right;
border:none;
}

View File

@ -0,0 +1,174 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math
calendar alarms logging concurrency.combinators
db.types db.tuples db
rss xml.writer
http.server
http.server.crud
http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
http.server.components ;
IN: webapps.planet
TUPLE: blog id name www-url atom-url ;
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
{ "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
} define-persistent
: init-blog-table blog ensure-table ;
: <blog> ( id -- todo )
blog new
swap >>id ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
: <entry-form> ( -- form )
"entry" <form>
"entry" planet-template >>view-template
"entry-summary" planet-template >>summary-template
"title" <string> add-field
"description" <html-text> add-field
"pub-date" <date> add-field ;
: <blog-form> ( -- form )
"blog" <form>
"edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template
"blog-summary" planet-template >>summary-template
"id" <integer>
hidden >>renderer
add-field
"name" <string>
t >>required
add-field
"www-url" <url>
t >>required
add-field
"atom-url" <url>
t >>required
add-field ;
: <planet-factor-form> ( -- form )
"planet-factor" <form>
"planet" planet-template >>view-template
"mini-planet" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field
"blogroll" <blog-form> +unordered+ <list> add-field ;
: blogroll ( -- seq )
f <blog> select-tuples [ [ name>> ] compare ] sort ;
TUPLE: planet-factor < dispatcher postings ;
:: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] |
<action>
[
blank-values
planet postings>> "postings" set-value
blogroll "blogroll" set-value
form view-form
] >>display
] ;
: safe-head ( seq n -- seq' )
over length min head ;
:: planet-feed ( planet -- feed )
feed new
"[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link
planet postings>> 30 safe-head >>entries ;
:: <feed-action> ( planet -- action )
<action>
[
"text/xml" <content>
[ planet planet-feed feed>xml write-xml ] >>body
] >>display ;
: <posting> ( name entry -- entry' )
clone [ ": " swap 3append ] change-title ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
dup
[ atom-url>> fetch-feed ] parallel-map
[ >r name>> r> [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ pub-date>> ] compare ] sort <reversed> ;
: update-cached-postings ( planet -- )
"webapps.planet" [
blogroll fetch-blogroll sort-entries >>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
<action>
[
planet update-cached-postings
"" f <temporary-redirect>
] >>display ;
: start-update-task ( planet -- )
[ update-cached-postings ] curry 10 minutes every drop ;
:: <planet-factor> ( -- responder )
[let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] |
planet-factor new-dispatcher
dup <planet-action> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" add-responder
! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder
blog-form blog-ctor <view-action> "view-blog" add-responder
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ;
USING: namespaces io.files io.sockets
db.sqlite smtp
http.server.db
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.sessions.storage.db ;
: test-db "planet.db" resource-path sqlite-db ;
: <planet-app> ( -- responder )
<planet-factor>
<boilerplate>
"page" planet-template >>template
! <url-sessions>
! sessions-in-db >>sessions
test-db <db-persistence> ;
: init-planet ( -- )
! test-db [
! init-blog-table
! init-users-table
! init-sessions-table
! ] with-db
<dispatcher>
<planet-app> "planet" add-responder
main-responder set-global ;

View File

@ -0,0 +1,37 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title>
<t:atom title="Planet Factor - Atom" href="feed.xml" />
<t:style include="resource:extra/webapps/planet/planet.css" />
<table width="100%" cellpadding="10">
<tr>
<td> <t:view component="postings" /> </td>
<td valign="top" width="25%" class="infobox">
<p>
<strong>planet-factor</strong> is an Atom feed aggregator that collects the
contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
<img src="http://planet.lisp.org/feed-icon-14x14.png" />
<a href="feed.xml"> Syndicate </a>
</p>
<h2>Blogroll</h2>
<t:summary component="blogroll" />
Admin: <t:a href="edit-blog">Add Blog</t:a>
|
<t:a href="update">Update</t:a>
</td>
</tr>
</table>
</t:chloe>

View File

@ -0,0 +1,41 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>View Blog</t:title>
<table>
<tr>
<th class="field-label">Blog name:</th>
<td><t:view component="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
<td>
<t:a value="www-url">
<t:view component="www-url" />
</t:a>
</td>
</tr>
<tr>
<th class="field-label">Atom feed:</th>
<td>
<t:a value="atom-url">
<t:view component="atom-url" />
</t:a>
</td>
</tr>
</table>
<t:a href="edit-blog" query="id">Edit</t:a>
|
<t:form action="delete-blog" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>