From: Slava Pestov Date: Wed, 9 Jul 2008 22:04:20 +0000 (-0500) Subject: Debugging web framework and cleaning things up X-Git-Tag: 0.94~2866 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=874b123bb06759de6aa4910f2b217e1cbca4e75f Debugging web framework and cleaning things up --- diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 4b431c83bc..6448fcdf07 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -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 ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index 9f1411188c..6d41c637c6 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -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 ) diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index ae042f05bd..0c21c9f18d 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -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 ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor index e03fca99a5..da6acece61 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.factor +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -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 diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 93b3a7ad73..77915f1083 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -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 diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index ce533bce64..9246780a94 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -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' ) 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 ; diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor index ae9458f4ac..1a9784f147 100644 --- a/extra/furnace/auth/login/permits/permits.factor +++ b/extra/furnace/auth/login/permits/permits.factor @@ -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 diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 2bb97e7c14..59f71b1524 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -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 ; diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index 2149e4fcd7..16d61487e3 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -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 ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 242e193013..45aa55f050 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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 ) diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor index 88d621b573..83941cd08f 100644 --- a/extra/furnace/redirection/redirection.factor +++ b/extra/furnace/redirection/redirection.factor @@ -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 : if-secure ( quot -- ) - >r request get url>> protocol>> "http" = - [ request get url>> ] + >r url get protocol>> "http" = + [ url get ] r> if ; inline M: secure-only call-responder* diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5590a9e55e..31711f54e9 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -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? ; diff --git a/extra/furnace/syndication/syndication.factor b/extra/furnace/syndication/syndication.factor index 7f60bcc746..31a978aef3 100644 --- a/extra/furnace/syndication/syndication.factor +++ b/extra/furnace/syndication/syndication.factor @@ -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 ; diff --git a/extra/http/http.factor b/extra/http/http.factor index bf55cdebfa..90b8b86921 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor index bc6e1148c3..746741c894 100644 --- a/extra/http/parsers/parsers.factor +++ b/extra/http/parsers/parsers.factor @@ -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 diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 3a13b6de39..354ebd8f70 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -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 diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 2da2695992..405d96d1f5 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -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 ) diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor index c1d2eaa63a..314c09e33d 100644 --- a/extra/http/server/redirection/redirection.factor +++ b/extra/http/server/redirection/redirection.factor @@ -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 ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 6733bb8a41..436d626578 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 83fcf6f4a9..98510e45fd 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -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 + url get clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 10e0ab54c0..972c09f9b8 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -160,13 +160,13 @@ M: comment entity-url [ validate-post - logged-in-user get username>> "author" set-value + username "author" set-value ] >>validate [ f dup { "title" "content" } to-object - logged-in-user get username>> >>author + username >>author now >>date [ insert-tuple ] [ entity-url ] 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 "content" value >>content - logged-in-user get username>> >>author + username >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0fb7e7dc89..e726c4ed36 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -32,7 +32,7 @@ todo "TODO" : ( id -- todo ) todo new swap >>id - logged-in-user get username>> >>uid ; + username >>uid ; : ( -- action ) diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 1515c4924a..7004871df3 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -4,26 +4,4 @@ Recent Changes -
- - - - - - - - - - - - - - - - - -
ArticleDateBy
- -
- diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 9d65531eb0..75cb4a29fb 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -13,7 +13,7 @@ New revision: - + Created on by . diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 057b7f8f71..90843a7140 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -4,12 +4,17 @@ Edit: - +

+

+ Describe this revision: + +

+

diff --git a/extra/webapps/wiki/revisions-common.xml b/extra/webapps/wiki/revisions-common.xml new file mode 100644 index 0000000000..6cf331532a --- /dev/null +++ b/extra/webapps/wiki/revisions-common.xml @@ -0,0 +1,33 @@ + + + + +
+ + + + + + + + + + + + + + + + + + + + + +
ArticleDateByDescriptionRollback
Rollback
+ +
+ + + + diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 0e1af75a8f..68f377e70b 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -4,24 +4,6 @@ Revisions of -
- - - - - - - - - - - - - - -
RevisionByRollback
Rollback
-
-

View Differences

diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 6f6ada2dbd..8035c24e24 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -8,14 +8,4 @@ Edits by -
    - -
  • - - on - -
    • -     -
- diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 7d2c7869b5..38d9d39d55 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -8,6 +8,12 @@ -

This revision created on by .

+

+ This revision created on by + + () + + +

diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 5cddcee628..dea79670a3 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -47,15 +47,17 @@ - - - - - - - - - + + + + + + + + + + + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 3c87f3cd49..623c8aabe5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -47,7 +47,7 @@ article "ARTICLES" { :
( 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 ; +: ( responder -- responder' ) + + { wiki "page-common" } >>template ; + : ( -- action ) [ "Front Page" view-url ] >>display ; @@ -100,7 +105,9 @@ M: revision feed-entry-url id>> revision-url ; ] [ edit-url ] ?if - ] >>display ; + ] >>display + + ; : ( -- 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 + + ; : ( -- action ) @@ -144,28 +153,47 @@ M: revision feed-entry-url id>> revision-url ; [ validate-title - "title" value
select-tuple [ - revision>> select-tuple from-object - ] when* + + "title" value
select-tuple + [ revision>> select-tuple ] + [ f "title" value >>title ] + if* + + [ title>> "title" set-value ] + [ content>> "content" set-value ] + bi ] >>init { wiki "edit" } >>template + ; + +: ( -- action ) + [ validate-title - { { "content" [ v-required ] } } validate-params + + { + { "content" [ v-required ] } + { "description" [ [ v-one-line ] v-optional ] } + } validate-params f "title" value >>title now >>date - logged-in-user get username>> >>author + username >>author "content" value >>content + "description" value >>description [ add-revision ] [ title>> view-url ] bi ] >>submit "edit wiki articles" >>description ; +: ( responder -- responder ) + + { wiki "revisions-common" } >>template ; + : list-revisions ( -- seq ) f "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 + + + ; : ( -- 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* ; + : ( -- action ) [ validate-integer-id ] >>validate [ - "id" value select-tuple clone f >>id - [ add-revision ] [ title>> view-url ] bi - ] >>submit ; + "id" value select-tuple + f >>id + now >>date + username >>author + [ rollback-description ] change-description + [ add-revision ] + [ title>> revisions-url ] bi + ] >>submit + + + "rollback wiki articles" >>description ; : list-changes ( -- seq ) f select-tuples @@ -211,8 +253,10 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) - [ list-changes "changes" set-value ] >>init - { wiki "changes" } >>template ; + [ list-changes "revisions" set-value ] >>init + { wiki "changes" } >>template + + ; : ( -- action ) @@ -237,6 +281,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + [ { { "old-id" [ v-integer ] } @@ -246,14 +291,18 @@ M: revision feed-entry-url id>> revision-url ; "old-id" "new-id" [ value 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 + + ; : ( -- 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 + + ; : ( -- action ) @@ -290,24 +341,21 @@ M: revision feed-entry-url id>> revision-url ; [ "author" value user-edits-url ] >>url [ list-user-edits ] >>entries ; -: ( responder -- responder' ) - - { wiki "page-common" } >>template ; - : init-sidebar ( -- ) "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when* "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ; : ( -- dispatcher ) wiki new-dispatcher - "" add-responder - "view" add-responder - "revision" add-responder + "" add-responder + "view" add-responder + "revision" add-responder "random" add-responder - "revisions" add-responder + "revisions" add-responder "revisions.atom" add-responder - "diff" add-responder - "edit" add-responder + "diff" add-responder + "edit" add-responder + "submit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder