Working on planet factor rewrite
Slava Pestov
parent
f9ce5dd6c3
commit
6e89f7b085
|
|
@ -363,7 +363,7 @@ M: login call-responder ( path responder -- response )
|
|||
|
||||
: <login> ( responder -- auth )
|
||||
login new-dispatcher
|
||||
swap <protected> >>default
|
||||
swap >>default
|
||||
<login-action> <login-boilerplate> "login" add-responder
|
||||
<logout-action> <login-boilerplate> "logout" add-responder
|
||||
no-users >>users ;
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ SYMBOL: next-template
|
|||
: call-next-template ( -- )
|
||||
next-template get write ;
|
||||
|
||||
M: f call-template drop call-next-template ;
|
||||
M: f call-template* drop call-next-template ;
|
||||
|
||||
: with-boilerplate ( body template -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -280,6 +280,22 @@ TUPLE: date < string ;
|
|||
M: date component-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
|
||||
SYMBOL: +plain+
|
||||
SYMBOL: +ordered+
|
||||
|
|
@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
|
|||
|
||||
C: <list-renderer> list-renderer
|
||||
|
||||
: render-plain-list ( seq quot component -- )
|
||||
swap '[ , @ ] each ; inline
|
||||
: render-plain-list ( seq component quot -- )
|
||||
'[ , component>> renderer>> @ ] each ; inline
|
||||
|
||||
: render-li-list ( seq component quot -- )
|
||||
'[ <li> @ </li> ] render-plain-list ; inline
|
||||
|
||||
: 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 -- )
|
||||
swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
|
||||
<ul> render-li-list </ul> ; inline
|
||||
|
||||
: render-list ( value renderer quot -- )
|
||||
swap [ component>> ] [ type>> ] bi {
|
||||
over type>> {
|
||||
{ +plain+ [ render-plain-list ] }
|
||||
{ +ordered+ [ render-ordered-list ] }
|
||||
{ +unordered+ [ render-unordered-list ] }
|
||||
|
|
|
|||
|
|
@ -78,4 +78,4 @@ M: form render-view*
|
|||
dup view-template>> render-form ;
|
||||
|
||||
M: form render-edit*
|
||||
dup edit-template>> render-form ;
|
||||
nip dup edit-template>> render-form ;
|
||||
|
|
|
|||
|
|
@ -160,23 +160,30 @@ drop
|
|||
|
||||
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 "Internal server error" <trivial-response>
|
||||
swap '[
|
||||
, "Internal server error" [
|
||||
development-mode get [
|
||||
[ print-error nl :c ] with-html-stream
|
||||
] [
|
||||
500 "Internal server error"
|
||||
trivial-response-body
|
||||
] if
|
||||
] simple-page
|
||||
] >>body ;
|
||||
swap '[ , http-error. ] >>body ;
|
||||
|
||||
: do-response ( response -- )
|
||||
dup write-response
|
||||
request get method>> "HEAD" =
|
||||
[ drop ] [ write-response-body ] if ;
|
||||
[ drop ] [
|
||||
'[
|
||||
, write-response-body
|
||||
] [
|
||||
http-error.
|
||||
] recover
|
||||
] if ;
|
||||
|
||||
LOG: httpd-hit NOTICE
|
||||
|
||||
|
|
|
|||
|
|
@ -153,6 +153,7 @@ SYMBOL: tags
|
|||
{ "form" [ form-tag ] }
|
||||
{ "error" [ error-tag ] }
|
||||
{ "if" [ if-tag ] }
|
||||
{ "comment" [ drop ] }
|
||||
{ "call-next-template" [ drop call-next-template ] }
|
||||
[ "Unknown chloe tag: " swap append throw ]
|
||||
} case ;
|
||||
|
|
@ -189,7 +190,7 @@ SYMBOL: tags
|
|||
] if
|
||||
] with-scope ;
|
||||
|
||||
M: chloe call-template
|
||||
M: chloe call-template*
|
||||
path>> utf8 <file-reader> read-xml process-chloe ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ TUPLE: fhtml path ;
|
|||
|
||||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template ( filename -- )
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[
|
||||
, path>> [
|
||||
"quiet" on
|
||||
|
|
|
|||
|
|
@ -1,10 +1,21 @@
|
|||
USING: accessors kernel fry io.encodings.utf8 io.files
|
||||
http http.server ;
|
||||
USING: accessors kernel fry io io.encodings.utf8 io.files
|
||||
http http.server debugger prettyprint continuations ;
|
||||
IN: http.server.templating
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -10,52 +10,49 @@
|
|||
<head>
|
||||
<t:write-title />
|
||||
|
||||
<t:write-atom />
|
||||
|
||||
<t:style>
|
||||
body, button {
|
||||
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
|
||||
color:#444;
|
||||
}
|
||||
|
||||
.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;
|
||||
}
|
||||
|
||||
.inline {
|
||||
display: inline;
|
||||
}
|
||||
|
||||
.navbar {
|
||||
background-color: #eee;
|
||||
padding: 5px;
|
||||
border: 1px solid #ccc;
|
||||
}
|
||||
</t:style>
|
||||
|
||||
<t:write-style />
|
||||
</head>
|
||||
|
||||
<body>
|
||||
|
||||
<h1><t:a href="planet"><t:write-title /></t:a></h1>
|
||||
|
||||
<t:call-next-template />
|
||||
</body>
|
||||
|
||||
|
|
@ -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>
|
||||
|
|
@ -2,8 +2,16 @@
|
|||
|
||||
<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>
|
||||
<h2 class="posting-title">
|
||||
<t:a value="link"><t:view component="title" /></t:a>
|
||||
</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>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
calendar alarms logging concurrency.combinators namespaces
|
||||
db.types db.tuples db
|
||||
rss xml.writer
|
||||
http.server
|
||||
|
|
@ -10,11 +10,22 @@ http.server.forms
|
|||
http.server.actions
|
||||
http.server.boilerplate
|
||||
http.server.templating.chloe
|
||||
http.server.components ;
|
||||
http.server.components
|
||||
http.server.auth.login
|
||||
webapps.factor-website ;
|
||||
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 ;
|
||||
|
||||
M: blog link-title name>> ;
|
||||
|
||||
M: blog link-href www-url>> ;
|
||||
|
||||
blog "BLOGS"
|
||||
{
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
|
|
@ -29,8 +40,8 @@ blog "BLOGS"
|
|||
blog new
|
||||
swap >>id ;
|
||||
|
||||
: planet-template ( name -- template )
|
||||
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
|
||||
: blogroll ( -- seq )
|
||||
f <blog> select-tuples [ [ name>> ] compare ] sort ;
|
||||
|
||||
: <entry-form> ( -- form )
|
||||
"entry" <form>
|
||||
|
|
@ -44,7 +55,7 @@ blog "BLOGS"
|
|||
"blog" <form>
|
||||
"edit-blog" planet-template >>edit-template
|
||||
"view-blog" planet-template >>view-template
|
||||
"blog-summary" planet-template >>summary-template
|
||||
"blog-admin-link" planet-template >>summary-template
|
||||
"id" <integer>
|
||||
hidden >>renderer
|
||||
add-field
|
||||
|
|
@ -60,15 +71,27 @@ blog "BLOGS"
|
|||
|
||||
: <planet-factor-form> ( -- form )
|
||||
"planet-factor" <form>
|
||||
"planet" planet-template >>view-template
|
||||
"mini-planet" planet-template >>summary-template
|
||||
"postings" planet-template >>view-template
|
||||
"postings-summary" planet-template >>summary-template
|
||||
"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 ( -- seq )
|
||||
f <blog> select-tuples [ [ name>> ] compare ] sort ;
|
||||
:: <edit-blogroll-action> ( planet -- action )
|
||||
[let | form [ <admin-form> ] |
|
||||
<action>
|
||||
[
|
||||
blank-values
|
||||
|
||||
TUPLE: planet-factor < dispatcher postings ;
|
||||
blogroll "blogroll" set-value
|
||||
|
||||
form view-form
|
||||
] >>display
|
||||
] ;
|
||||
|
||||
:: <planet-action> ( planet -- action )
|
||||
[let | form [ <planet-factor-form> ] |
|
||||
|
|
@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
|
|||
feed new
|
||||
"[ planet-factor ]" >>title
|
||||
"http://planet.factorcode.org" >>link
|
||||
planet postings>> 30 safe-head >>entries ;
|
||||
planet postings>> 16 safe-head >>entries ;
|
||||
|
||||
:: <feed-action> ( planet -- action )
|
||||
<action>
|
||||
|
|
@ -117,7 +140,8 @@ TUPLE: planet-factor < dispatcher postings ;
|
|||
|
||||
: update-cached-postings ( planet -- )
|
||||
"webapps.planet" [
|
||||
blogroll fetch-blogroll sort-entries >>postings drop
|
||||
blogroll fetch-blogroll sort-entries 8 safe-head
|
||||
>>postings drop
|
||||
] with-logging ;
|
||||
|
||||
:: <update-action> ( planet -- action )
|
||||
|
|
@ -127,16 +151,11 @@ TUPLE: planet-factor < dispatcher postings ;
|
|||
"" f <temporary-redirect>
|
||||
] >>display ;
|
||||
|
||||
: start-update-task ( planet -- )
|
||||
[ update-cached-postings ] curry 10 minutes every drop ;
|
||||
|
||||
:: <planet-factor> ( -- responder )
|
||||
:: <planet-factor-admin> ( 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
|
||||
<dispatcher>
|
||||
planet-factor <edit-blogroll-action> >>default
|
||||
|
||||
! Administrative CRUD
|
||||
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
|
||||
] ;
|
||||
|
||||
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>
|
||||
: <planet-factor> ( -- responder )
|
||||
planet-factor new-dispatcher
|
||||
dup <planet-action> >>default
|
||||
dup <feed-action> "feed.xml" add-responder
|
||||
dup <update-action> "update" add-responder
|
||||
dup <planet-factor-admin> <protected> "admin" add-responder
|
||||
<boilerplate>
|
||||
"page" planet-template >>template
|
||||
! <url-sessions>
|
||||
! sessions-in-db >>sessions
|
||||
test-db <db-persistence> ;
|
||||
"planet" planet-template >>template ;
|
||||
|
||||
: <planet-app> ( -- responder )
|
||||
<planet-factor> <factor-boilerplate> ;
|
||||
|
||||
: start-update-task ( planet -- )
|
||||
[ update-cached-postings ] curry 10 minutes every drop ;
|
||||
|
||||
: init-planet ( -- )
|
||||
! test-db [
|
||||
! init-blog-table
|
||||
! init-users-table
|
||||
! init-sessions-table
|
||||
! ] with-db
|
||||
test-db [
|
||||
init-blog-table
|
||||
] with-db
|
||||
|
||||
<dispatcher>
|
||||
<planet-app> "planet" add-responder
|
||||
|
|
|
|||
|
|
@ -2,36 +2,30 @@
|
|||
|
||||
<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:comment>
|
||||
<t:style include="resource:extra/webapps/planet/planet.css" />
|
||||
|
||||
<table width="100%" cellpadding="10">
|
||||
<tr>
|
||||
<td> <t:view component="postings" /> </td>
|
||||
<div class="navbar">
|
||||
<t:a href="list">Front Page</t:a>
|
||||
| <t:a href="feed.xml">Atom Feed</t:a>
|
||||
|
||||
<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>
|
||||
| <t:a href="admin">Admin</t:a>
|
||||
|
||||
<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>
|
||||
|
|
||||
<t:a href="update">Update</t:a>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
<h1><t:write-title /></h1>
|
||||
|
||||
<t:call-next-template />
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -10,22 +10,6 @@
|
|||
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%;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! 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
|
||||
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 ;
|
||||
http.server
|
||||
webapps.factor-website ;
|
||||
IN: webapps.todo
|
||||
|
||||
TUPLE: todo uid id priority summary description ;
|
||||
|
|
@ -71,37 +72,10 @@ TUPLE: todo-responder < dispatcher ;
|
|||
"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> ;
|
||||
<todo-responder> <protected> <factor-boilerplate> ;
|
||||
|
||||
: 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue