\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest init display validate submit ;\r
+TUPLE: action rest authorize init display validate submit ;\r
\r
: new-action ( class -- action )\r
- new\r
- [ ] >>init\r
- [ <400> ] >>display\r
- [ ] >>validate\r
- [ <400> ] >>submit ;\r
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
\r
: <action> ( -- action )\r
action new-action ;\r
\r
: handle-get ( action -- response )\r
'[\r
- ,\r
- [ init>> call ]\r
- [ drop flashed-variables restore-flash ]\r
- [ display>> call ]\r
- tri\r
+ , dup display>> [\r
+ {\r
+ [ init>> call ]\r
+ [ authorize>> call ]\r
+ [ drop flashed-variables restore-flash ]\r
+ [ display>> call ]\r
+ } cleave\r
+ ] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
: validation-failed ( -- * )\r
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
\r
: (handle-post) ( action -- response )\r
- [ validate>> call ] [ submit>> call ] bi ;\r
+ '[\r
+ , dup submit>> [\r
+ [ validate>> call ]\r
+ [ authorize>> call ]\r
+ [ submit>> call ]\r
+ tri\r
+ ] [ drop <400> ] if\r
+ ] with-exit-continuation ;\r
\r
: param ( name -- value )\r
params get at ;\r
\r
TUPLE: protected < filter-responder description capabilities ;\r
\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
+\r
: users ( -- provider )\r
login get users>> ;\r
\r
"invalid username or password" validation-error\r
validation-failed ;\r
\r
+SYMBOL: description\r
+SYMBOL: capabilities\r
+\r
+: flashed-variables { description capabilities } ;\r
+\r
: <login-action> ( -- action )\r
<page-action>\r
[\r
- protected fget [\r
- [ description>> "description" set-value ]\r
- [ capabilities>> words>strings "capabilities" set-value ] bi\r
- ] when*\r
+ flashed-variables restore-flash\r
+ description get "description" set-value\r
+ capabilities get words>strings "capabilities" set-value\r
] >>init\r
\r
{ login "login" } >>template\r
drop\r
\r
URL" $login" end-aside\r
- ] >>submit ;\r
+ ] >>submit\r
+\r
+ <protected>\r
+ "edit your profile" >>description ;\r
\r
! ! ! Password recovery\r
\r
] >>submit ;\r
\r
! ! ! Authentication logic\r
-: <protected> ( responder -- protected )\r
- protected new\r
- swap >>responder ;\r
-\r
: show-login-page ( -- response )\r
begin-aside\r
- URL" $login/login" { protected } <flash-redirect> ;\r
+ protected get description>> description set\r
+ protected get capabilities>> capabilities set\r
+ URL" $login/login" flashed-variables <flash-redirect> ;\r
+\r
+: login-required ( -- * )\r
+ show-login-page exit-with ;\r
\r
-: check-capabilities ( responder user -- ? )\r
- [ capabilities>> ] bi@ subset? ;\r
+: have-capability? ( capability -- ? )\r
+ logged-in-user get capabilities>> member? ;\r
+\r
+: check-capabilities ( responder user/f -- ? )\r
+ dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;\r
\r
M: protected call-responder* ( path responder -- response )\r
dup protected set\r
- uid dup [\r
- users get-user 2dup check-capabilities [\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
- ] [\r
- 3drop show-login-page\r
- ] if\r
- ] [\r
- 3drop show-login-page\r
- ] if ;\r
+ dup logged-in-user get check-capabilities\r
+ [ call-next-method ] [ 2drop show-login-page ] if ;\r
+\r
+: init-user ( -- )\r
+ uid [\r
+ users get-user\r
+ [ logged-in-user set ]\r
+ [ save-user-after ] bi\r
+ ] when* ;\r
\r
M: login call-responder* ( path responder -- response )\r
dup login set\r
+ init-user\r
call-next-method ;\r
\r
: <login-boilerplate> ( responder -- responder' )\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected>\r
- "edit your profile" >>description\r
- <login-boilerplate>\r
- "edit-profile" add-responder ;\r
+ <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
<register-action> <login-boilerplate>\r
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
- dup "value" optional-attr [ ] [
+ dup "value" optional-attr
+ [ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
- ] ?if
- adjust-url relative-to-request ;
+ adjust-url relative-to-request
+ ] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces
+USING: kernel accessors combinators namespaces strings
logging urls http http.server http.server.responses ;
IN: http.server.redirection
-: relative-to-request ( url -- url' )
+GENERIC: relative-to-request ( url -- url' )
+
+M: string relative-to-request ;
+
+M: url relative-to-request
request get url>>
clone
f >>query
[
utf8 [
development-mode get
- [ http-error. ] [ drop "Response error" throw ] if
+ [ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output
] recover
] if
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db.types db.tuples calendar
-http.server.dispatchers
-furnace furnace.actions furnace.auth.login furnace.boilerplate
-furnace.sessions furnace.syndication ;
+urls validators html.components db db.types db.tuples calendar
+present http.server.dispatchers
+furnace
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.sessions
+furnace.syndication ;
IN: webapps.blogs
TUPLE: blogs < dispatcher ;
+SYMBOL: can-administer-blogs?
+
+can-administer-blogs? define-capability
+
: view-post-url ( id -- url )
- number>string "$blogs/post/" prepend >url ;
+ present "$blogs/post/" prepend >url ;
: view-comment-url ( parent id -- url )
[ view-post-url ] dip >>anchor ;
: list-posts-url ( -- url )
- URL" $blogs/" ;
+ "$blogs/" >url ;
-: user-posts-url ( author -- url )
+: posts-by-url ( author -- url )
"$blogs/by/" prepend >url ;
TUPLE: entity id author date content ;
TUPLE: post < entity title comments ;
M: post feed-entry-title
- [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+ [ author>> ] [ title>> ] bi ": " swap 3append ;
M: post entity-url
id>> view-post-url ;
[ [ date>> ] compare invert-comparison ] sort ;
: validate-author ( -- )
- { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+ { { "author" [ v-username ] } } validate-params ;
: list-posts ( -- posts )
f <post> "author" value >>author
- select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+ select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
reverse-chronological-order ;
: <list-posts-action> ( -- action )
<page-action>
- [
- list-posts "posts" set-value
- ] >>init
-
+ [ list-posts "posts" set-value ] >>init
{ blogs "list-posts" } >>template ;
: <list-posts-feed-action> ( -- action )
[ list-posts ] >>entries
[ list-posts-url ] >>url ;
-: <user-posts-action> ( -- action )
+: <posts-by-action> ( -- action )
<page-action>
+
"author" >>rest
+
[
validate-author
list-posts "posts" set-value
] >>init
- { blogs "user-posts" } >>template ;
-: <user-posts-feed-action> ( -- action )
+ { blogs "posts-by" } >>template ;
+
+: <posts-by-feed-action> ( -- action )
<feed-action>
[ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries
- [ "author" value user-posts-url ] >>url ;
+ [ "author" value posts-by-url ] >>url ;
: <post-feed-action> ( -- action )
<feed-action>
: <view-post-action> ( -- action )
<page-action>
+
"id" >>rest
[
: <new-post-action> ( -- action )
<page-action>
+
[
validate-post
uid "author" set-value
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "new-post" } >>template ;
+ { blogs "new-post" } >>template
+
+ <protected>
+ "make a new blog post" >>description ;
+
+: authorize-author ( author -- )
+ uid = can-administer-blogs? have-capability? or
+ [ login-required ] unless ;
+
+: do-post-action ( -- )
+ validate-integer-id
+ "id" value <post> select-tuple from-object ;
: <edit-post-action> ( -- action )
<page-action>
+
"id" >>rest
- [
- validate-integer-id
- "id" value <post> select-tuple from-object
- ] >>init
+ [ do-post-action ] >>init
- [
- validate-integer-id
- validate-post
- ] >>validate
+ [ do-post-action validate-post ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
[
- "id" value <post> select-tuple
- dup { "title" "content" } deposit-slots
+ "id" value <post>
+ dup { "title" "author" "date" "content" } deposit-slots
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "edit-post" } >>template ;
-
+ { blogs "edit-post" } >>template
+
+ <protected>
+ "edit a blog post" >>description ;
+
+: delete-post ( id -- )
+ [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
+
: <delete-post-action> ( -- action )
<action>
+
+ [ do-post-action ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- validate-integer-id
- { { "author" [ v-username ] } } validate-params
- ] >>validate
+ [ "id" value delete-post ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
+
+: <delete-author-action> ( -- action )
+ <action>
+
+ [ validate-author ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- "id" value <post> delete-tuples
- "author" value user-posts-url <redirect>
- ] >>submit ;
+ [
+ f <post> "author" value >>author select-tuples [ id>> delete-post ] each
+ f f <comment> "author" value >>author delete-tuples
+ ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
: validate-comment ( -- )
{
uid >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "make a comment" >>description ;
+
: <delete-comment-action> ( -- action )
<action>
+
[
validate-integer-id
{ { "parent" [ v-integer ] } } validate-params
] >>validate
+
+ [
+ "parent" value <post> select-tuple
+ author>> authorize-author
+ ] >>authorize
+
[
f "id" value <comment> delete-tuples
"parent" value view-post-url <redirect>
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "delete a comment" >>description ;
+
: <blogs> ( -- dispatcher )
blogs new-dispatcher
<list-posts-action> "" add-responder
<list-posts-feed-action> "posts.atom" add-responder
- <user-posts-action> "by" add-responder
- <user-posts-feed-action> "by.atom" add-responder
+ <posts-by-action> "by" add-responder
+ <posts-by-feed-action> "by.atom" add-responder
<view-post-action> "post" add-responder
<post-feed-action> "post.atom" add-responder
- <new-post-action> <protected>
- "make a new blog post" >>description
- "new-post" add-responder
- <edit-post-action> <protected>
- "edit a blog post" >>description
- "edit-post" add-responder
- <delete-post-action> <protected>
- "delete a blog post" >>description
- "delete-post" add-responder
- <new-comment-action> <protected>
- "make a comment" >>description
- "new-comment" add-responder
- <delete-comment-action> <protected>
- "delete a comment" >>description
- "delete-comment" add-responder
+ <new-post-action> "new-post" add-responder
+ <edit-post-action> "edit-post" add-responder
+ <delete-post-action> "delete-post" add-responder
+ <new-comment-action> "new-comment" add-responder
+ <delete-comment-action> "delete-comment" add-responder
<boilerplate>
{ blogs "blogs-common" } >>template ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$blogs/by" t:rest="author">
+ Recent Posts by <t:label t:name="author" />
+ </t:atom>
+
+ <t:title>
+ Recent Posts by <t:label t:name="author" />
+ </t:title>
+
+ <t:bind-each t:name="posts">
+
+ <h2 class="post-title">
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </p>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/by" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="comments" />
+ comments.
+ </t:a>
+ </div>
+
+ </t:bind-each>
+
+</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:atom t:href="$blogs/by" t:rest="author">
- Recent Posts by <t:label t:name="author" />
- </t:atom>
-
- <t:title>
- Recent Posts by <t:label t:name="author" />
- </t:title>
-
- <t:bind-each t:name="posts">
-
- <h2 class="post-title">
- <t:a t:href="$blogs/post" t:rest="id">
- <t:label t:name="title" />
- </t:a>
- </h2>
-
- <p class="posting-body">
- <t:farkup t:name="content" />
- </p>
-
- <div class="posting-footer">
- Post by
- <t:a t:href="$blogs/by" t:rest="author">
- <t:label t:name="author" />
- </t:a>
- on
- <t:label t:name="date" />
- |
- <t:a t:href="$blogs/post" t:rest="id">
- <t:label t:name="comments" />
- comments.
- </t:a>
- </div>
-
- </t:bind-each>
-
-</t:chloe>
<hr/>
<p class="comment-header">
- Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+ <a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
</p>
<p class="posting-body">
TUPLE: pastebin < dispatcher ;
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
! ! !
! DOMAIN MODEL
! ! !
: <delete-paste-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
[
- "id" value <paste> delete-tuples
- "id" value f <annotation> delete-tuples
+ [
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ ] with-transaction
URL" $pastebin/list" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities ;
! ! !
! ANNOTATIONS
: <delete-annotation-action> ( -- action )
<action>
+
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
- ] >>submit ;
+ ] >>submit
-SYMBOL: can-delete-pastes?
-
-can-delete-pastes? define-capability
+ <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> <protected>
- "delete pastes" >>description
- { can-delete-pastes? } >>capabilities "delete-paste" add-responder
+ <delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> <protected>
- "delete annotations" >>description
- { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
+ <delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
TUPLE: planet-factor < dispatcher ;
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
- { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
- { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" URL +not-null+ }
+ { "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent
TUPLE: posting < entry id ;
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
- { "url" "LINK" { VARCHAR 256 } +not-null+ }
+ { "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
: <new-blog-action> ( -- action )
<page-action>
+
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
]
tri
] >>submit ;
-
+
: <edit-blog-action> ( -- action )
<page-action>
+
[
validate-integer-id
"id" value <blog> select-tuple from-object
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
- <delete-blog-action> "delete-blog" add-responder ;
-
-SYMBOL: can-administer-planet-factor?
-
-can-administer-planet-factor? define-capability
+ <delete-blog-action> "delete-blog" add-responder
+ <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
- <planet-factor-admin> <protected>
- "administer Planet Factor" >>description
- { can-administer-planet-factor? } >>capabilities
- "admin" add-responder
+ <planet-factor-admin> "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;
TUPLE: wiki < dispatcher ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
TUPLE: article title revision ;
article "ARTICLES" {
: <view-article-action> ( -- action )
<action>
+
"title" >>rest
+
[
validate-title
] >>init
+
[
"title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-object
: <view-revision-action> ( -- action )
<page-action>
+
"id" >>rest
+
[
validate-integer-id
"id" value <revision>
select-tuple from-object
URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
+
{ wiki "view" } >>template ;
: add-revision ( revision -- )
: <edit-article-action> ( -- action )
<page-action>
+
"title" >>rest
+
[
validate-title
"title" value <article> select-tuple [
revision>> <revision> select-tuple from-object
] when*
] >>init
+
{ wiki "edit" } >>template
+
[
validate-title
{ { "content" [ v-required ] } } validate-params
logged-in-user get username>> >>author
"content" value >>content
[ add-revision ] [ title>> view-url <redirect> ] bi
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "edit wiki articles" >>description ;
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
: <list-revisions-action> ( -- action )
<page-action>
+
"title" >>rest
+
[
validate-title
list-revisions "revisions" set-value
] >>init
+
{ wiki "revisions" } >>template ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
+
"title" >>rest
+
[ validate-title ] >>init
+
[ "Revisions of " "title" value append ] >>title
+
[ "title" value revisions-url ] >>url
+
[ list-revisions ] >>entries ;
: <rollback-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
+
[
"id" value <revision> select-tuple clone f >>id
[ add-revision ] [ title>> view-url <redirect> ] bi
: <delete-action> ( -- action )
<action>
+
[ validate-title ] >>validate
+
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
URL" $wiki" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities ;
: <diff-action> ( -- action )
<page-action>
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
+
{ wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
<page-action>
+
[
f <article> select-tuples
[ [ title>> ] compare ] sort
"articles" set-value
] >>init
+
{ wiki "articles" } >>template ;
: list-user-edits ( -- seq )
: <user-edits-action> ( -- action )
<page-action>
+
"author" >>rest
+
[
validate-author
list-user-edits "user-edits" set-value
] >>init
+
{ wiki "user-edits" } >>template ;
: <user-edits-feed-action> ( -- action )
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
-SYMBOL: can-delete-wiki-articles?
-
-can-delete-wiki-articles? define-capability
-
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
- <edit-article-action> <article-boilerplate> <protected>
- "edit wiki articles" >>description
- "edit" add-responder
+ <edit-article-action> <article-boilerplate> "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
<user-edits-feed-action> "user-edits.atom" add-responder
<list-changes-feed-action> "changes.atom" add-responder
- <delete-action> <protected>
- "delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities
- "delete" add-responder
+ <delete-action> "delete" add-responder
<boilerplate>
{ wiki "wiki-common" } >>template ;
projects / factor.git / commitdiff