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

Debugging web framework and cleaning things up

db4
Slava Pestov 2008-07-09 17:04:20 -05:00
parent 095a3e984c
commit 874b123bb0
31 changed files with 217 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/furnace/actions/actions.factor
View File

@ -110,7 +110,7 @@ M: action call-responder* ( path action -- response )
} case ;
M: action modify-form
drop request get url>> revalidate-url-key hidden-form-field ;
drop url get revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;

17
extra/furnace/asides/asides.factor
View File

@ -1,10 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser urls combinators
html.elements html.templates.chloe.syntax db.types db.tuples
http http.server http.server.filters
furnace furnace.cache furnace.sessions furnace.redirection ;
assocs hashtables math.parser urls combinators
logging db.types db.tuples
html.elements
html.templates.chloe.syntax
http
http.server
http.server.filters
furnace
furnace.cache
furnace.sessions
furnace.redirection ;
IN: furnace.asides
TUPLE: aside < server-state session method url post-data ;
@ -44,6 +51,8 @@ TUPLE: asides < server-state-manager ;
url>> path>> split-path
asides get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging
ERROR: end-aside-in-get-error ;
: get-aside ( id -- aside )

30
extra/furnace/auth/auth.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry
destructors combinators fry logging
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2
html.forms
@ -18,7 +18,11 @@ IN: furnace.auth
SYMBOL: logged-in-user
: logged-in? ( -- ? ) logged-in-user get >boolean ;
: logged-in? ( -- ? )
logged-in-user get >boolean ;
: username ( -- string/f )
logged-in-user get dup [ username>> ] when ;
GENERIC: init-user-profile ( responder -- )
@ -30,9 +34,6 @@ M: dispatcher init-user-profile
M: filter-responder init-user-profile
responder>> init-user-profile ;
: have-capability? ( capability -- ? )
logged-in-user get capabilities>> member? ;
: profile ( -- assoc ) logged-in-user get profile>> ;
: user-changed ( -- )
@ -59,6 +60,8 @@ TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( realm -- response )
GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username )
: login-required ( -- * ) realm get login-required* exit-with ;
@ -87,9 +90,16 @@ M: user-saver dispose
: init-user ( user -- )
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
\ init-user DEBUG add-input-logging
M: realm call-responder* ( path responder -- response )
dup realm set
dup logged-in-username dup [ users get-user ] when init-user
logged-in? [
dup init-realm
dup logged-in-username
dup [ users get-user ] when
init-user
] unless
call-next-method ;
: encode-password ( string salt -- bytes )
@ -122,18 +132,18 @@ TUPLE: protected < filter-responder description capabilities ;
protected new
swap >>responder ;
: check-capabilities ( responder user/f -- ? )
{
: have-capabilities? ( capabilities -- ? )
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ [ capabilities>> ] bi@ subset? ]
[ capabilities>> subset? ]
} cond ;
M: protected call-responder* ( path responder -- response )
'[
, ,
dup protected set
dup logged-in-user get check-capabilities
dup capabilities>> have-capabilities?
[ call-next-method ] [ 2drop realm get login-required* ] if
] if-secure-realm ;

4
extra/furnace/auth/features/edit-profile/edit-profile.factor
View File

@ -22,7 +22,7 @@ IN: furnace.auth.features.edit-profile
{ realm "features/edit-profile/edit-profile" } >>template
[
logged-in-user get username>> "username" set-value
username "username" set-value
{
{ "realname" [ [ v-one-line ] v-optional ] }
@ -34,7 +34,7 @@ IN: furnace.auth.features.edit-profile
{ "password" "new-password" "verify-password" }
[ value empty? not ] contains? [
"password" value logged-in-user get username>> check-login
"password" value username check-login
[ "incorrect password" validation-error ] unless
same-password-twice

2
extra/furnace/auth/features/recover-password/recover-password.factor
View File

@ -11,7 +11,7 @@ IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from
: current-host ( -- string )
request get url>> host>> host-name or ;
url get host>> host-name or ;
: new-password-url ( user -- url )
URL" recover-3" clone

12
extra/furnace/auth/login/login.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences math.parser
calendar validators urls html.forms
calendar validators urls logging html.forms
http http.server http.server.dispatchers
furnace
furnace.auth
@ -25,10 +25,8 @@ SYMBOL: permit-id
TUPLE: login-realm < realm timeout domain ;
M: login-realm call-responder*
[ name>> client-permit-id permit-id set ]
[ call-next-method ]
bi ;
M: login-realm init-realm
name>> client-permit-id permit-id set ;
M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ;
@ -47,11 +45,15 @@ M: login-realm modify-form ( responder -- )
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
\ put-permit-cookie DEBUG add-input-logging
: successful-login ( user -- response )
[ username>> make-permit permit-id set ] [ init-user ] bi
URL" $realm" end-aside
put-permit-cookie ;
\ successful-login DEBUG add-input-logging
: logout ( -- )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;

6
extra/furnace/auth/login/permits/permits.factor
View File

@ -1,7 +1,5 @@
USING: accessors namespaces combinators.lib kernel
db.tuples db.types
furnace.auth furnace.sessions furnace.cache
combinators.short-circuit ;
USING: accessors namespaces kernel combinators.short-circuit
db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
IN: furnace.auth.login.permits

5
extra/furnace/boilerplate/boilerplate.factor
View File

@ -1,13 +1,12 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.order namespaces combinators.lib
USING: accessors kernel math.order namespaces furnace combinators.short-circuit
html.forms
html.templates
html.templates.chloe
locals
http.server
http.server.filters
furnace combinators.short-circuit ;
http.server.filters ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ;

2
extra/furnace/flash/flash.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs assocs.lib kernel sequences accessors
USING: namespaces assocs kernel sequences accessors
urls db.types db.tuples math.parser fry
http http.server http.server.filters http.server.redirection
furnace furnace.cache furnace.sessions furnace.redirection ;

2
extra/furnace/furnace.factor
View File

@ -86,7 +86,7 @@ M: object modify-form drop ;
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
request get url>>
url get
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
: cookie-client-state ( key request -- value/f )

6
extra/furnace/redirection/redirection.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
io.servers.connection
io.servers.connection urls
http http.server http.server.redirection http.server.filters
furnace ;
IN: furnace.redirection
@ -33,8 +33,8 @@ TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only
: if-secure ( quot -- )
>r request get url>> protocol>> "http" =
[ request get url>> <secure-redirect> ]
>r url get protocol>> "http" =
[ url get <secure-redirect> ]
r> if ; inline
M: secure-only call-responder*

4
extra/furnace/sessions/sessions.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences continuations
fry calendar combinators combinators.lib destructors alarms
fry calendar combinators combinators.short-circuit destructors alarms
io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache combinators.short-circuit ;
furnace furnace.cache ;
IN: furnace.sessions
TUPLE: session < server-state namespace user-agent client changed? ;

2
extra/furnace/syndication/syndication.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry sequences.lib
USING: accessors kernel sequences fry
combinators syndication
http.server.responses http.server.redirection
furnace furnace.actions ;

7
extra/http/http.factor
View File

@ -114,10 +114,13 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
]
} case ;
: check-cookie-value ( string -- string )
[ "Cookie value must not be f" throw ] unless* ;
: (unparse-cookie) ( cookie -- strings )
[
dup name>> check-cookie-string >lower
over value>> unparse-cookie-value
over value>> check-cookie-value unparse-cookie-value
"$path" over path>> unparse-cookie-value
"$domain" over domain>> unparse-cookie-value
drop
@ -129,7 +132,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
: unparse-set-cookie ( cookie -- string )
[
dup name>> check-cookie-string >lower
over value>> unparse-cookie-value
over value>> check-cookie-value unparse-cookie-value
"path" over path>> unparse-cookie-value
"domain" over domain>> unparse-cookie-value
"expires" over expires>> unparse-cookie-value

2
extra/http/parsers/parsers.factor
View File

@ -1,4 +1,4 @@
USING: combinators.short-circuit math math.order math.parser kernel combinators.lib
USING: combinators.short-circuit math math.order math.parser kernel
sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces ascii ;
IN: http.parsers

8
extra/http/server/cgi/cgi.factor
View File

@ -14,10 +14,10 @@ IN: http.server.cgi
[ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi
request get url>> path>> "SCRIPT_NAME" set
url get path>> "SCRIPT_NAME" set
request get url>> host>> "SERVER_NAME" set
request get url>> port>> number>string "SERVER_PORT" set
url get host>> "SERVER_NAME" set
url get port>> number>string "SERVER_PORT" set
"" "PATH_INFO" set
"" "REMOTE_HOST" set
"" "REMOTE_ADDR" set
@ -26,7 +26,7 @@ IN: http.server.cgi
"" "REMOTE_IDENT" set
request get method>> "REQUEST_METHOD" set
request get url>> query>> assoc>query "QUERY_STRING" set
url get query>> assoc>query "QUERY_STRING" set
request get "cookie" header "HTTP_COOKIE" set
request get "user-agent" header "HTTP_USER_AGENT" set

4
extra/http/server/dispatchers/dispatchers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences assocs accessors splitting
unicode.case http http.server http.server.responses ;
unicode.case urls http http.server http.server.responses ;
IN: http.server.dispatchers
TUPLE: dispatcher default responders ;
@ -35,7 +35,7 @@ TUPLE: vhost-dispatcher default responders ;
>lower "www." ?head drop "." ?tail drop ;
: find-vhost ( dispatcher -- responder )
request get url>> host>> canonical-host over responders>> at*
url get host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )

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

@ -9,7 +9,7 @@ GENERIC: relative-to-request ( url -- url' )
M: string relative-to-request ;
M: url relative-to-request
request get url>>
url get
clone
f >>query
swap derive-url ensure-port ;

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

@ -81,8 +81,7 @@ GENERIC: write-full-response ( request response -- )
: ensure-domain ( cookie -- cookie )
[
request get url>>
host>> dup "localhost" =
url get host>> dup "localhost" =
[ drop ] [ or ] if
] change-domain ;
@ -189,7 +188,7 @@ LOG: httpd-header NOTICE
"/" split harvest ;
: init-request ( request -- )
request set
[ request set ] [ url>> url set ] bi
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
@ -224,7 +223,7 @@ LOG: httpd-benchmark DEBUG
: ?benchmark ( quot -- )
benchmark? get [
[ benchmark ] [ first ] bi request get url>> rot 3array
[ benchmark ] [ first ] bi url get rot 3array
httpd-benchmark
] [ call ] if ; inline
@ -235,7 +234,7 @@ M: http-server handle-client*
[
64 1024 * limit-input
?refresh-all
read-request
[ read-request ] ?benchmark
[ do-request ] ?benchmark
[ do-response ] ?benchmark
] with-destructors ;

4
extra/http/server/static/static.factor
View File

@ -82,12 +82,12 @@ TUPLE: file-responder root hook special allow-listings ;
"index.html" append-path dup exists? [ drop f ] unless ;
: serve-directory ( filename -- response )
request get url>> path>> "/" tail? [
url get path>> "/" tail? [
dup
find-index [ serve-file ] [ list-directory ] ?if
] [
drop
request get url>> clone [ "/" append ] change-path <permanent-redirect>
url get clone [ "/" append ] change-path <permanent-redirect>
] if ;
: serve-object ( filename -- response )

12
extra/webapps/blogs/blogs.factor
View File

@ -160,13 +160,13 @@ M: comment entity-url
[
validate-post
logged-in-user get username>> "author" set-value
username "author" set-value
] >>validate
[
f <post>
dup { "title" "content" } to-object
logged-in-user get username>> >>author
username >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
@ -177,8 +177,8 @@ M: comment entity-url
"make a new blog post" >>description ;
: authorize-author ( author -- )
logged-in-user get username>> =
can-administer-blogs? have-capability? or
username =
{ can-administer-blogs? } have-capabilities? or
[ login-required ] unless ;
: do-post-action ( -- )
@ -254,13 +254,13 @@ M: comment entity-url
[
validate-comment
logged-in-user get username>> "author" set-value
username "author" set-value
] >>validate
[
"parent" value f <comment>
"content" value >>content
logged-in-user get username>> >>author
username >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit

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

@ -32,7 +32,7 @@ todo "TODO"
: <todo> ( id -- todo )
todo new
swap >>id
logged-in-user get username>> >>uid ;
username >>uid ;
: <view-action> ( -- action )
<page-action>

22
extra/webapps/wiki/changes.xml
View File

@ -4,26 +4,4 @@
<t:title>Recent Changes</t:title>
<div class="revisions">
<table>
<tr>
<th>Article</th>
<th>Date</th>
<th>By</th>
</tr>
<t:bind-each t:name="changes">
<tr>
<td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
<td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
<td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
</tr>
</t:bind-each>
</table>
</div>
</t:chloe>

2
extra/webapps/wiki/diff.xml
View File

@ -13,7 +13,7 @@
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind t:name="old">
<t:bind t:name="new">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>

7
extra/webapps/wiki/edit.xml
View File

@ -4,12 +4,17 @@
<t:title>Edit: <t:label t:name="title" /></t:title>
<t:form t:action="$wiki/edit" t:for="title">
<t:form t:action="$wiki/submit" t:for="title">
<p>
<t:textarea t:name="content" t:rows="30" t:cols="80" />
</p>
<p>
Describe this revision:
<t:field t:name="description" t:size="60" />
</p>
<p>
<input type="submit" value="Save" />
</p>

33
extra/webapps/wiki/revisions-common.xml Normal file
View File

@ -0,0 +1,33 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<div class="revisions">
<table>
<tr>
<th>Article</th>
<th>Date</th>
<th>By</th>
<th>Description</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
<td> <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a> </td>
<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /> </t:a></td>
<td> <t:label t:name="description" /> </td>
<td> <t:button class="link link-button" t:action="$wiki/rollback" t:for="id">Rollback</t:button> </td>
</tr>
</t:bind-each>
</table>
</div>
<t:call-next-template />
</t:chloe>

18
extra/webapps/wiki/revisions.xml
View File

@ -4,24 +4,6 @@
<t:title>Revisions of <t:label t:name="title" /></t:title>
<div class="revisions">
<table>
<tr>
<th>Revision</th>
<th>By</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
<td> <t:button t:action="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
</table>
</div>
<h2>View Differences</h2>
<t:form t:action="$wiki/diff" t:method="get">

10
extra/webapps/wiki/user-edits.xml
View File

@ -8,14 +8,4 @@
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
<t:bind-each t:name="user-edits">
<li>
<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li>
</t:bind-each>
</ul>
</t:chloe>

8
extra/webapps/wiki/view.xml
View File

@ -8,6 +8,12 @@
<t:farkup t:name="content" />
</div>
<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
<p>
<em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>
<t:if t:value="description">
(<t:label t:name="description" />)
</t:if>
</em>
</p>
</t:chloe>

20
extra/webapps/wiki/wiki-common.xml
View File

@ -47,15 +47,17 @@
</t:if>
</tr>
<tr>
<td>
<t:bind t:name="footer">
<small>
<t:farkup t:name="content" />
</small>
</t:bind>
</td>
</tr>
<t:if t:value="footer">
<tr>
<td>
<t:bind t:name="footer">
<small>
<t:farkup t:name="content" />
</small>
</t:bind>
</td>
</tr>
</t:if>
</table>
</t:chloe>

106
extra/webapps/wiki/wiki.factor
View File

@ -47,7 +47,7 @@ article "ARTICLES" {
: <article> ( title -- article ) article new swap >>title ;
TUPLE: revision id title author date content ;
TUPLE: revision id title author date content description ;
revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
@ -55,6 +55,7 @@ revision "REVISIONS" {
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ }
{ "description" "DESCRIPTION" TEXT }
} define-persistent
M: revision feed-entry-title
@ -76,6 +77,10 @@ M: revision feed-entry-url id>> revision-url ;
: validate-author ( -- )
{ { "author" [ v-username ] } } validate-params ;
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
: <main-article-action> ( -- action )
<action>
[ "Front Page" view-url <redirect> ] >>display ;
@ -100,7 +105,9 @@ M: revision feed-entry-url id>> revision-url ;
] [
edit-url <redirect>
] ?if
] >>display ;
] >>display
<article-boilerplate> ;
: <view-revision-action> ( -- action )
<page-action>
@ -114,7 +121,9 @@ M: revision feed-entry-url id>> revision-url ;
URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
{ wiki "view" } >>template
<article-boilerplate> ;
: <random-article-action> ( -- action )
<action>
@ -144,28 +153,47 @@ M: revision feed-entry-url id>> revision-url ;
[
validate-title
"title" value <article> select-tuple [
revision>> <revision> select-tuple from-object
] when*
"title" value <article> select-tuple
[ revision>> <revision> select-tuple ]
[ f <revision> "title" value >>title ]
if*
[ title>> "title" set-value ]
[ content>> "content" set-value ]
bi
] >>init
{ wiki "edit" } >>template
<article-boilerplate> ;
: <submit-article-action> ( -- action )
<action>
[
validate-title
{ { "content" [ v-required ] } } validate-params
{
{ "content" [ v-required ] }
{ "description" [ [ v-one-line ] v-optional ] }
} validate-params
f <revision>
"title" value >>title
now >>date
logged-in-user get username>> >>author
username >>author
"content" value >>content
"description" value >>description
[ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit
<protected>
"edit wiki articles" >>description ;
: <revisions-boilerplate> ( responder -- responder )
<boilerplate>
{ wiki "revisions-common" } >>template ;
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
reverse-chronological-order ;
@ -180,7 +208,10 @@ M: revision feed-entry-url id>> revision-url ;
list-revisions "revisions" set-value
] >>init
{ wiki "revisions" } >>template ;
{ wiki "revisions" } >>template
<revisions-boilerplate>
<article-boilerplate> ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
@ -195,15 +226,26 @@ M: revision feed-entry-url id>> revision-url ;
[ list-revisions ] >>entries ;
: rollback-description ( description -- description' )
[ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
: <rollback-action> ( -- action )
<action>
[ validate-integer-id ] >>validate
[
"id" value <revision> select-tuple clone f >>id
[ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
"id" value <revision> select-tuple
f >>id
now >>date
username >>author
[ rollback-description ] change-description
[ add-revision ]
[ title>> revisions-url <redirect> ] bi
] >>submit
<protected>
"rollback wiki articles" >>description ;
: list-changes ( -- seq )
f <revision> select-tuples
@ -211,8 +253,10 @@ M: revision feed-entry-url id>> revision-url ;
: <list-changes-action> ( -- action )
<page-action>
[ list-changes "changes" set-value ] >>init
{ wiki "changes" } >>template ;
[ list-changes "revisions" set-value ] >>init
{ wiki "changes" } >>template
<revisions-boilerplate> ;
: <list-changes-feed-action> ( -- action )
<feed-action>
@ -237,6 +281,7 @@ M: revision feed-entry-url id>> revision-url ;
: <diff-action> ( -- action )
<page-action>
[
{
{ "old-id" [ v-integer ] }
@ -246,14 +291,18 @@ M: revision feed-entry-url id>> revision-url ;
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
[ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
[ "new" [ from-object ] nest-form ] bi*
over title>> "title" set-value
[ "old" [ from-object ] nest-form ]
[ "new" [ from-object ] nest-form ]
bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
{ wiki "diff" } >>template ;
{ wiki "diff" } >>template
<article-boilerplate> ;
: <list-articles-action> ( -- action )
<page-action>
@ -277,10 +326,12 @@ M: revision feed-entry-url id>> revision-url ;
[
validate-author
list-user-edits "user-edits" set-value
list-user-edits "revisions" set-value
] >>init
{ wiki "user-edits" } >>template ;
{ wiki "user-edits" } >>template
<revisions-boilerplate> ;
: <user-edits-feed-action> ( -- action )
<feed-action>
@ -290,24 +341,21 @@ M: revision feed-entry-url id>> revision-url ;
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
: init-sidebar ( -- )
"Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
"Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
<view-article-action> <article-boilerplate> "view" add-responder
<view-revision-action> <article-boilerplate> "revision" add-responder
<main-article-action> "" add-responder
<view-article-action> "view" add-responder
<view-revision-action> "revision" add-responder
<random-article-action> "random" add-responder
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-action> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
<edit-article-action> <article-boilerplate> "edit" add-responder
<diff-action> "diff" add-responder
<edit-article-action> "edit" add-responder
<submit-article-action> "submit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder