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

Working on planet factor rewrite

db4
Slava Pestov 2008-04-22 21:08:27 -05:00
parent f9ce5dd6c3
commit 6e89f7b085
18 changed files with 236 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -363,7 +363,7 @@ M: login call-responder ( path responder -- response )
: <login> ( responder -- auth ) : <login> ( responder -- auth )
login new-dispatcher login new-dispatcher
swap <protected> >>default swap >>default
<login-action> <login-boilerplate> "login" add-responder <login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ; no-users >>users ;

2
extra/http/server/boilerplate/boilerplate.factor
View File

@ -48,7 +48,7 @@ SYMBOL: next-template
: call-next-template ( -- ) : call-next-template ( -- )
next-template get write ; next-template get write ;
M: f call-template drop call-next-template ; M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- ) : with-boilerplate ( body template -- )
[ [

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

@ -280,6 +280,22 @@ TUPLE: date < string ;
M: date component-string M: date component-string
drop timestamp>string ; drop timestamp>string ;
! Link components
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
SINGLETON: link-renderer
M: link-renderer render-view*
drop <a dup link-href =href a> link-title write </a> ;
TUPLE: link < string ;
: <link> ( id -- component )
link new-string
link-renderer >>renderer ;
! List components ! List components
SYMBOL: +plain+ SYMBOL: +plain+
SYMBOL: +ordered+ SYMBOL: +ordered+
@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer C: <list-renderer> list-renderer
: render-plain-list ( seq quot component -- ) : render-plain-list ( seq component quot -- )
swap '[ , @ ] each ; inline '[ , component>> renderer>> @ ] each ; inline
: render-li-list ( seq component quot -- )
'[ <li> @ </li> ] render-plain-list ; inline
: render-ordered-list ( seq quot component -- ) : render-ordered-list ( seq quot component -- )
swap <ol> '[ <li> , @ </li> ] each </ol> ; inline <ol> render-li-list </ol> ; inline
: render-unordered-list ( seq quot component -- ) : render-unordered-list ( seq quot component -- )
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline <ul> render-li-list </ul> ; inline
: render-list ( value renderer quot -- ) : render-list ( value renderer quot -- )
swap [ component>> ] [ type>> ] bi { over type>> {
{ +plain+ [ render-plain-list ] } { +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] } { +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] } { +unordered+ [ render-unordered-list ] }

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

@ -78,4 +78,4 @@ M: form render-view*
dup view-template>> render-form ; dup view-template>> render-form ;
M: form render-edit* M: form render-edit*
dup edit-template>> render-form ; nip dup edit-template>> render-form ;

29
extra/http/server/server.factor
View File

@ -160,23 +160,30 @@ drop
SYMBOL: development-mode SYMBOL: development-mode
: http-error. ( error -- )
"Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
] simple-page ;
: <500> ( error -- response ) : <500> ( error -- response )
500 "Internal server error" <trivial-response> 500 "Internal server error" <trivial-response>
swap '[ swap '[ , http-error. ] >>body ;
, "Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
] simple-page
] >>body ;
: do-response ( response -- ) : do-response ( response -- )
dup write-response dup write-response
request get method>> "HEAD" = request get method>> "HEAD" =
[ drop ] [ write-response-body ] if ; [ drop ] [
'[
, write-response-body
] [
http-error.
] recover
] if ;
LOG: httpd-hit NOTICE LOG: httpd-hit NOTICE

3
extra/http/server/templating/chloe/chloe.factor
View File

@ -153,6 +153,7 @@ SYMBOL: tags
{ "form" [ form-tag ] } { "form" [ form-tag ] }
{ "error" [ error-tag ] } { "error" [ error-tag ] }
{ "if" [ if-tag ] } { "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] } { "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ] [ "Unknown chloe tag: " swap append throw ]
} case ; } case ;
@ -189,7 +190,7 @@ SYMBOL: tags
] if ] if
] with-scope ; ] with-scope ;
M: chloe call-template M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ; path>> utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template INSTANCE: chloe template

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

@ -76,7 +76,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml C: <fhtml> fhtml
M: fhtml call-template ( filename -- ) M: fhtml call-template* ( filename -- )
'[ '[
, path>> [ , path>> [
"quiet" on "quiet" on

17
extra/http/server/templating/templating.factor
View File

@ -1,10 +1,21 @@
USING: accessors kernel fry io.encodings.utf8 io.files USING: accessors kernel fry io io.encodings.utf8 io.files
http http.server ; http http.server debugger prettyprint continuations ;
IN: http.server.templating IN: http.server.templating
MIXIN: template MIXIN: template
GENERIC: call-template ( template -- ) GENERIC: call-template* ( template -- )
ERROR: template-error template error ;
M: template-error error.
"Error while processing template " write
[ template>> pprint ":" print nl ]
[ error>> error. ]
bi ;
: call-template ( template -- )
[ call-template* ] [ template-error ] recover ;
M: template write-response-body* call-template ; M: template write-response-body* call-template ;

38
extra/webapps/factor-website/factor-website.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences io.files io.sockets
db.sqlite smtp namespaces db
http.server.db
http.server.sessions
http.server.auth.login
http.server.auth.providers.db
http.server.sessions.storage.db
http.server.boilerplate
http.server.templating.chloe ;
IN: webapps.factor-website
: factor-template ( path -- template )
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
: test-db "todo.db" resource-path sqlite-db ;
: <factor-boilerplate> ( responder -- responder' )
<login>
users-in-db >>users
allow-registration
allow-password-recovery
allow-edit-profile
<boilerplate>
"page" factor-template >>template
<url-sessions>
sessions-in-db >>sessions
test-db <db-persistence> ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
test-db [
init-sessions-table
init-users-table
] with-db ;

33
extra/webapps/planet/page.xml → extra/webapps/factor-website/page.xml
View File

@ -10,34 +10,24 @@
<head> <head>
<t:write-title /> <t:write-title />
<t:write-atom />
<t:style> <t:style>
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
.link-button { .link-button {
padding: 0px; padding: 0px;
background: none; background: none;
border: none; border: none;
} }
.inline {
display: inline;
}
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
a, .link { a, .link {
color: #222; color: #222;
border-bottom:1px dotted #666; border-bottom:1px dotted #666;
text-decoration:none; text-decoration:none;
} }
h1 a {
border: none;
}
a:hover, .link:hover { a:hover, .link:hover {
border-bottom:1px solid #66a; border-bottom:1px solid #66a;
} }
@ -47,15 +37,22 @@
.field-label { .field-label {
text-align: right; text-align: right;
} }
.inline {
display: inline;
}
.navbar {
background-color: #eee;
padding: 5px;
border: 1px solid #ccc;
}
</t:style> </t:style>
<t:write-style /> <t:write-style />
</head> </head>
<body> <body>
<h1><t:a href="planet"><t:write-title /></t:a></h1>
<t:call-next-template /> <t:call-next-template />
</body> </body>

13
extra/webapps/planet/admin.xml Normal file
View File

@ -0,0 +1,13 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor Administration</t:title>
<t:summary component="blogroll" />
<p>
<t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
</p>
</t:chloe>

14
extra/webapps/planet/entry.xml
View File

@ -2,8 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2 class="posting-title"><t:view component="title" /></h2> <h2 class="posting-title">
<p class="posting-body"> <t:view component="description" /> </p> <t:a value="link"><t:view component="title" /></t:a>
<p class="posting-date"> <t:view component="pub-date" /> </p> </h2>
<p class="posting-body">
<t:view component="description" />
</p>
<p class="posting-date">
<t:a value="link"><t:view component="pub-date" /></t:a>
</p>
</t:chloe> </t:chloe>

94
extra/webapps/planet/planet.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math USING: kernel accessors sequences sorting locals math
calendar alarms logging concurrency.combinators calendar alarms logging concurrency.combinators namespaces
db.types db.tuples db db.types db.tuples db
rss xml.writer rss xml.writer
http.server http.server
@ -10,11 +10,22 @@ http.server.forms
http.server.actions http.server.actions
http.server.boilerplate http.server.boilerplate
http.server.templating.chloe http.server.templating.chloe
http.server.components ; http.server.components
http.server.auth.login
webapps.factor-website ;
IN: webapps.planet IN: webapps.planet
TUPLE: planet-factor < dispatcher postings ;
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
TUPLE: blog id name www-url atom-url ; TUPLE: blog id name www-url atom-url ;
M: blog link-title name>> ;
M: blog link-href www-url>> ;
blog "BLOGS" blog "BLOGS"
{ {
{ "id" "ID" INTEGER +native-id+ } { "id" "ID" INTEGER +native-id+ }
@ -29,8 +40,8 @@ blog "BLOGS"
blog new blog new
swap >>id ; swap >>id ;
: planet-template ( name -- template ) : blogroll ( -- seq )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ; f <blog> select-tuples [ [ name>> ] compare ] sort ;
: <entry-form> ( -- form ) : <entry-form> ( -- form )
"entry" <form> "entry" <form>
@ -44,7 +55,7 @@ blog "BLOGS"
"blog" <form> "blog" <form>
"edit-blog" planet-template >>edit-template "edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template "view-blog" planet-template >>view-template
"blog-summary" planet-template >>summary-template "blog-admin-link" planet-template >>summary-template
"id" <integer> "id" <integer>
hidden >>renderer hidden >>renderer
add-field add-field
@ -60,15 +71,27 @@ blog "BLOGS"
: <planet-factor-form> ( -- form ) : <planet-factor-form> ( -- form )
"planet-factor" <form> "planet-factor" <form>
"planet" planet-template >>view-template "postings" planet-template >>view-template
"mini-planet" planet-template >>summary-template "postings-summary" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field "postings" <entry-form> +plain+ <list> add-field
"blogroll" "blog" <link> +unordered+ <list> add-field ;
: <admin-form> ( -- form )
"admin" <form>
"admin" planet-template >>view-template
"blogroll" <blog-form> +unordered+ <list> add-field ; "blogroll" <blog-form> +unordered+ <list> add-field ;
: blogroll ( -- seq ) :: <edit-blogroll-action> ( planet -- action )
f <blog> select-tuples [ [ name>> ] compare ] sort ; [let | form [ <admin-form> ] |
<action>
[
blank-values
TUPLE: planet-factor < dispatcher postings ; blogroll "blogroll" set-value
form view-form
] >>display
] ;
:: <planet-action> ( planet -- action ) :: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] | [let | form [ <planet-factor-form> ] |
@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
feed new feed new
"[ planet-factor ]" >>title "[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link "http://planet.factorcode.org" >>link
planet postings>> 30 safe-head >>entries ; planet postings>> 16 safe-head >>entries ;
:: <feed-action> ( planet -- action ) :: <feed-action> ( planet -- action )
<action> <action>
@ -117,7 +140,8 @@ TUPLE: planet-factor < dispatcher postings ;
: update-cached-postings ( planet -- ) : update-cached-postings ( planet -- )
"webapps.planet" [ "webapps.planet" [
blogroll fetch-blogroll sort-entries >>postings drop blogroll fetch-blogroll sort-entries 8 safe-head
>>postings drop
] with-logging ; ] with-logging ;
:: <update-action> ( planet -- action ) :: <update-action> ( planet -- action )
@ -127,16 +151,11 @@ TUPLE: planet-factor < dispatcher postings ;
"" f <temporary-redirect> "" f <temporary-redirect>
] >>display ; ] >>display ;
: start-update-task ( planet -- ) :: <planet-factor-admin> ( planet-factor -- responder )
[ update-cached-postings ] curry 10 minutes every drop ;
:: <planet-factor> ( -- responder )
[let | blog-form [ <blog-form> ] [let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] | blog-ctor [ [ <blog> ] ] |
planet-factor new-dispatcher <dispatcher>
dup <planet-action> >>default planet-factor <edit-blogroll-action> >>default
dup <feed-action> "feed.xml" add-responder
dup <update-action> "update" add-responder
! Administrative CRUD ! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder blog-ctor "" <delete-action> "delete-blog" add-responder
@ -144,30 +163,25 @@ TUPLE: planet-factor < dispatcher postings ;
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ; ] ;
USING: namespaces io.files io.sockets : <planet-factor> ( -- responder )
db.sqlite smtp planet-factor new-dispatcher
http.server.db dup <planet-action> >>default
http.server.sessions dup <feed-action> "feed.xml" add-responder
http.server.auth.login dup <update-action> "update" add-responder
http.server.auth.providers.db dup <planet-factor-admin> <protected> "admin" add-responder
http.server.sessions.storage.db ; <boilerplate>
"planet" planet-template >>template ;
: test-db "planet.db" resource-path sqlite-db ;
: <planet-app> ( -- responder ) : <planet-app> ( -- responder )
<planet-factor> <planet-factor> <factor-boilerplate> ;
<boilerplate>
"page" planet-template >>template : start-update-task ( planet -- )
! <url-sessions> [ update-cached-postings ] curry 10 minutes every drop ;
! sessions-in-db >>sessions
test-db <db-persistence> ;
: init-planet ( -- ) : init-planet ( -- )
! test-db [ test-db [
! init-blog-table init-blog-table
! init-users-table ] with-db
! init-sessions-table
! ] with-db
<dispatcher> <dispatcher>
<planet-app> "planet" add-responder <planet-app> "planet" add-responder

42
extra/webapps/planet/planet.xml
View File

@ -2,36 +2,30 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title> <t:comment>
<t:atom title="Planet Factor - Atom" href="feed.xml" /> <t:atom title="Planet Factor - Atom" href="feed.xml" />
</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" /> <t:style include="resource:extra/webapps/planet/planet.css" />
<table width="100%" cellpadding="10"> <div class="navbar">
<tr> <t:a href="list">Front Page</t:a>
<td> <t:view component="postings" /> </td> | <t:a href="feed.xml">Atom Feed</t:a>
<td valign="top" width="25%" class="infobox"> | <t:a href="admin">Admin</t:a>
<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:comment>
<t:if code="http.server.auth.login:allow-edit-profile?">
| <t:a href="edit-profile">Edit Profile</t:a>
</t:if>
<t:summary component="blogroll" /> <t:form action="logout" class="inline">
| <button type="submit" class="link-button link">Logout</button>
</t:form>
</t:comment>
</div>
Admin: <t:a href="edit-blog">Add Blog</t:a> <h1><t:write-title /></h1>
|
<t:a href="update">Update</t:a> <t:call-next-template />
</td>
</tr>
</table>
</t:chloe> </t:chloe>

19
extra/webapps/planet/postings.xml Normal file
View File

@ -0,0 +1,19 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Planet Factor</t:title>
<table width="100%" cellpadding="10">
<tr>
<td> <t:view component="postings" /> </td>
<td valign="top" width="25%" class="infobox">
<h2>Blogroll</h2>
<t:summary component="blogroll" />
</td>
</tr>
</table>
</t:chloe>

45
extra/webapps/todo/page.xml
View File

@ -1,45 +0,0 @@
<?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>

16
extra/webapps/todo/todo.css
View File

@ -10,22 +10,6 @@
color: #000000; color: #000000;
} }
.link-button {
padding: 0px;
background: none;
border: none;
}
.navbar {
background-color: #eeeeee;
padding: 5px;
border: 1px solid #ccc;
}
.inline {
display: inline;
}
pre { pre {
font-size: 75%; font-size: 75%;
} }

34
extra/webapps/todo/todo.factor
View File

@ -1,12 +1,13 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals sequences USING: accessors kernel locals sequences namespaces
db db.types db.tuples db db.types db.tuples
http.server.components http.server.components.farkup http.server.components http.server.components.farkup
http.server.forms http.server.templating.chloe http.server.forms http.server.templating.chloe
http.server.boilerplate http.server.crud http.server.auth http.server.boilerplate http.server.crud http.server.auth
http.server.actions http.server.db http.server.actions http.server.db
http.server ; http.server
webapps.factor-website ;
IN: webapps.todo IN: webapps.todo
TUPLE: todo uid id priority summary description ; TUPLE: todo uid id priority summary description ;
@ -71,37 +72,10 @@ TUPLE: todo-responder < dispatcher ;
"todo" todo-template >>template "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-app> ( -- responder )
<todo-responder> <todo-responder> <protected> <factor-boilerplate> ;
<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 ( -- ) : init-todo ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
test-db [ test-db [
init-todo-table init-todo-table
init-users-table init-users-table