Web framework work in progress
parent
d1f37ab5ec
commit
e2a185f1f4
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -0,0 +1,7 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:summary component="postings" />
|
||||
|
||||
</t:chloe>
|
|
@ -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>
|
|
@ -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;
|
||||
}
|
|
@ -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 ;
|
|
@ -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>
|
|
@ -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>
|
Loading…
Reference in New Issue