diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor index dcf62e1117..dc3d970fbf 100644 --- a/core/grouping/grouping-tests.factor +++ b/core/grouping/grouping-tests.factor @@ -10,3 +10,5 @@ IN: grouping.tests 2 over set-length >array ] unit-test + +[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index c12d43160c..caf46e5480 100644 --- a/core/grouping/grouping.factor +++ b/core/grouping/grouping.factor @@ -56,7 +56,7 @@ M: clumps set-length M: clumps group@ [ n>> over + ] [ seq>> ] bi ; -TUPLE: sliced-clumps < groups ; +TUPLE: sliced-clumps < clumps ; : ( seq n -- clumps ) sliced-clumps new-groups ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1dc47432d3..2ec9f2de54 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -117,14 +117,18 @@ $nl { $subsection parse-tokens } ; ARTICLE: "parsing-words" "Parsing words" -"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." +"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." $nl "Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:" { $code ": hello \"Hello world\" print ; parsing" } -"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser." +$nl +"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +$nl +"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later." $nl "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" -{ $link staging-violation } +{ $subsection staging-violation } "Tools for implementing parsing words:" { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 1e7d9cb622..de36d661aa 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -39,18 +39,13 @@ IN: dns.server zones sort-largest-first [ name-in-domain? ] with find nip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! fill-authority +! name->authority ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fill-authority ( message -- message ) - [ ] - [ message-query name>> name->zone NS IN query boa matching-rrs ] - [ answer-section>> ] - tri - diff >>authority-section ; +: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! fill-additional +! extract-names ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : rr->rdata-names ( rr -- names/f ) @@ -61,12 +56,33 @@ IN: dns.server } cond ; +: extract-rdata-names ( message -- names ) + [ answer-section>> ] [ authority-section>> ] bi append + [ rr->rdata-names ] map concat ; + +: extract-names ( message -- names ) + [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-authority +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-authority ( message -- message ) + dup + extract-names [ name->authority ] map concat prune + over answer-section>> diff + >>authority-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-additional +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ; + : fill-additional ( message -- message ) dup - [ answer-section>> ] [ authority-section>> ] bi append - [ rr->rdata-names ] map concat - [ A IN query boa matching-rrs ] map concat prune - over answer-section>> diff + extract-rdata-names [ name->rrs-a ] map concat prune + over answer-section>> diff >>additional-section ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -90,10 +106,6 @@ DEFER: query->rrs ! have-answers ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : have-answers ( message -- message/f ) -! dup message-query query->rrs ! message rrs/f -! [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ; - : have-answers ( message -- message/f ) dup message-query query->rrs [ empty? ] diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 1cef8e24e5..a281687096 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -29,14 +29,10 @@ SYMBOL: rest CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest init display validate submit ; +TUPLE: action rest authorize init display validate submit ; : new-action ( class -- action ) - new - [ ] >>init - [ <400> ] >>display - [ ] >>validate - [ <400> ] >>submit ; + new [ ] >>init [ ] >>validate [ ] >>authorize ; inline : ( -- action ) action new-action ; @@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ; : handle-get ( action -- response ) '[ - , - [ init>> call ] - [ drop flashed-variables restore-flash ] - [ display>> call ] - tri + , dup display>> [ + { + [ init>> call ] + [ authorize>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + } cleave + ] [ drop <400> ] if ] with-exit-continuation ; : validation-failed ( -- * ) request get method>> "POST" = [ f ] [ <400> ] if exit-with ; : (handle-post) ( action -- response ) - [ validate>> call ] [ submit>> call ] bi ; + '[ + , dup submit>> [ + [ validate>> call ] + [ authorize>> call ] + [ submit>> call ] + tri + ] [ drop <400> ] if + ] with-exit-continuation ; : param ( name -- value ) params get at ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index d0c4e00953..a1d2bf47c3 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ; TUPLE: protected < filter-responder description capabilities ; +: ( responder -- protected ) + protected new + swap >>responder ; + : users ( -- provider ) login get users>> ; @@ -85,13 +89,17 @@ M: user-saver dispose "invalid username or password" validation-error validation-failed ; +SYMBOL: description +SYMBOL: capabilities + +: flashed-variables { description capabilities } ; + : ( -- action ) [ - protected fget [ - [ description>> "description" set-value ] - [ capabilities>> words>strings "capabilities" set-value ] bi - ] when* + flashed-variables restore-flash + description get "description" set-value + capabilities get words>strings "capabilities" set-value ] >>init { login "login" } >>template @@ -200,7 +208,10 @@ M: user-saver dispose drop URL" $login" end-aside - ] >>submit ; + ] >>submit + + + "edit your profile" >>description ; ! ! ! Password recovery @@ -316,32 +327,36 @@ SYMBOL: lost-password-from ] >>submit ; ! ! ! Authentication logic -: ( responder -- protected ) - protected new - swap >>responder ; - : show-login-page ( -- response ) begin-aside - URL" $login/login" { protected } ; + protected get description>> description set + protected get capabilities>> capabilities set + URL" $login/login" flashed-variables ; -: check-capabilities ( responder user -- ? ) - [ capabilities>> ] bi@ subset? ; +: login-required ( -- * ) + show-login-page exit-with ; + +: have-capability? ( capability -- ? ) + logged-in-user get capabilities>> member? ; + +: check-capabilities ( responder user/f -- ? ) + dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ; M: protected call-responder* ( path responder -- response ) dup protected set - uid dup [ - users get-user 2dup check-capabilities [ - [ logged-in-user set ] [ save-user-after ] bi - call-next-method - ] [ - 3drop show-login-page - ] if - ] [ - 3drop show-login-page - ] if ; + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop show-login-page ] if ; + +: init-user ( -- ) + uid [ + users get-user + [ logged-in-user set ] + [ save-user-after ] bi + ] when* ; M: login call-responder* ( path responder -- response ) dup login set + init-user call-next-method ; : ( responder -- responder' ) @@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response ) ! ! ! Configuration : allow-edit-profile ( login -- login ) - - "edit your profile" >>description - - "edit-profile" add-responder ; + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 99ccf33eec..cdee2821b6 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -97,15 +97,22 @@ SYMBOL: exit-continuation dup empty? [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; -CHLOE: atom - [ children>string ] - [ "href" required-attr ] - [ "query" optional-attr parse-query-attr ] tri - - swap >>query - swap >>path - adjust-url relative-to-request - add-atom-feed ; +: a-url-path ( tag -- string ) + [ "href" required-attr ] [ "rest" optional-attr value ] bi + [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; + +: a-url ( tag -- url ) + dup "value" optional-attr + [ value ] [ + + swap + [ a-url-path >>path ] + [ "query" optional-attr parse-query-attr >>query ] + bi + adjust-url relative-to-request + ] ?if ; + +CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ; CHLOE: write-atom drop write-atom-feeds ; @@ -114,23 +121,11 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; : link-attrs ( tag -- ) + #! Side-effects current namespace. '[ , _ link-attr ] each-responder ; : a-start-tag ( tag -- ) - [ - - swap >>query - swap >>path - adjust-url relative-to-request =href - a> - ] with-scope ; + [ ] with-scope ; CHLOE: a [ a-start-tag ] @@ -158,11 +153,12 @@ CHLOE: a [ [
] [ form-magic ] bi diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 81ada558f3..aa11dd6798 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -7,7 +7,7 @@ IN: http.tests : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 -POST http://foo/bar HTTP/1.1 +POST /bar HTTP/1.1 Some-Header: 1 Some-Header: 2 Content-Length: 4 @@ -18,7 +18,7 @@ blah [ TUPLE{ request - url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } + url: TUPLE{ url path: "/bar" } method: "POST" version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } @@ -49,14 +49,14 @@ read-request-test-1' 1array [ ] unit-test STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.1 +HEAD /bar HTTP/1.1 Host: www.sex.com ; [ TUPLE{ request - url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" } + url: TUPLE{ url host: "www.sex.com" path: "/bar" } method: "HEAD" version: "1.1" header: H{ { "host" "www.sex.com" } } diff --git a/extra/http/http.factor b/extra/http/http.factor index d7fc1b766e..521c18c703 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.server io.sockets.secure -io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings.iana io.encodings.binary io.encodings.8-bit unicode.case unicode.categories qualified @@ -142,7 +141,6 @@ cookies ; request new "1.1" >>version - "http" >>protocol H{ } clone >>query >>url H{ } clone >>header @@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ; : extract-host ( request -- request ) [ ] [ url>> ] [ "host" header parse-host ] tri [ >>host ] [ >>port ] bi* - ensure-port drop ; : extract-cookies ( request -- request ) @@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; -: detect-protocol ( request -- request ) - dup url>> remote-address get secure? "https" "http" ? >>protocol drop ; - : read-request ( -- request ) read-method @@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ; read-request-version read-request-header read-post-data - detect-protocol extract-host extract-cookies ; diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor index 3cd01345aa..c1d2eaa63a 100644 --- a/extra/http/server/redirection/redirection.factor +++ b/extra/http/server/redirection/redirection.factor @@ -1,10 +1,14 @@ ! 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 diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 792757b182..376889b46b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,16 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -tools.vocabs math +combinators tools.vocabs math io io.server +io.sockets +io.sockets.secure io.encodings io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited io.timeouts -fry logging calendar +fry logging calendar urls http http.server.responses html.elements @@ -66,7 +68,7 @@ main-responder global [ <404> or ] change-at [ utf8 [ development-mode get - [ http-error. ] [ drop "Response error" throw ] if + [ http-error. ] [ drop "Response error" rethrow ] if ] with-encoded-output ] recover ] if @@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE : dispatch-request ( request -- response ) url>> path>> split-path main-responder get call-responder ; +: prepare-request ( request -- request ) + [ + local-address get + [ secure? "https" "http" ? >>protocol ] + [ port>> '[ , or ] change-port ] + bi + ] change-url ; + +: valid-request? ( request -- ? ) + url>> port>> local-address get port>> = ; + : do-request ( request -- response ) '[ , - [ init-request ] - [ log-request ] - [ dispatch-request ] tri + { + [ init-request ] + [ prepare-request ] + [ log-request ] + [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ] + } cleave ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor index 033ba3cbfb..0e37e41a76 100644 --- a/extra/io/pools/pools.factor +++ b/extra/io/pools/pools.factor @@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ; dup check-disposed dup expired>> expired? [ ALIEN: 31337 >>expired - connections>> [ delete-all ] [ dispose-each ] bi + connections>> delete-all ] [ drop ] if ; : ( class -- pool ) @@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn ) dup check-pool [ make-connection ] keep return-connection ; : acquire-connection ( pool -- conn ) + dup check-pool [ dup connections>> empty? ] [ dup new-connection ] [ ] while connections>> pop ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 359b9c6fb4..c855fba6be 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files io.streams.duplex logging continuations destructors kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar threads concurrency.combinators -assocs fry ; +assocs fry accessors ; IN: io.server SYMBOL: servers @@ -15,9 +15,10 @@ SYMBOL: remote-address LOG: accepted-connection NOTICE -: with-connection ( client remote quot -- ) +: with-connection ( client remote local quot -- ) '[ , [ remote-address set ] [ accepted-connection ] bi + , local-address set @ ] with-stream ; inline @@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> '[ , , , with-connection ] "Client" spawn drop + [ [ accept ] [ addr>> ] bi ] dip + '[ , , , , with-connection ] "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) @@ -59,7 +61,7 @@ LOG: received-datagram NOTICE : datagram-loop ( quot datagram -- ) [ - [ receive dup received-datagram >r swap call r> ] keep + [ receive dup received-datagram [ swap call ] dip ] keep pick [ send ] [ 3drop ] if ] 2keep datagram-loop ; inline diff --git a/extra/io/streams/duplex/duplex.factor b/extra/io/streams/duplex/duplex.factor index 02d7ab61be..51b4b8d860 100755 --- a/extra/io/streams/duplex/duplex.factor +++ b/extra/io/streams/duplex/duplex.factor @@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener accessors delegate delegate.protocols ; IN: io.streams.duplex -! We ensure that the stream can only be closed once, to preserve -! integrity of duplex I/O ports. - TUPLE: duplex-stream in out ; C: duplex-stream diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 8dbf7db690..100d4226b7 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,24 +1,33 @@ ! 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 ; @@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ; 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 ; @@ -79,19 +88,16 @@ M: comment entity-url [ [ date>> ] compare invert-comparison ] sort ; : validate-author ( -- ) - { { "author" [ [ v-username ] v-optional ] } } validate-params ; + { { "author" [ v-username ] } } validate-params ; : list-posts ( -- posts ) f "author" value >>author - select-tuples [ dup id>> f count-tuples >>comments ] map + select-tuples [ dup id>> f f count-tuples >>comments ] map reverse-chronological-order ; : ( -- action ) - [ - list-posts "posts" set-value - ] >>init - + [ list-posts "posts" set-value ] >>init { blogs "list-posts" } >>template ; : ( -- action ) @@ -100,21 +106,24 @@ M: comment entity-url [ list-posts ] >>entries [ list-posts-url ] >>url ; -: ( -- action ) +: ( -- action ) + "author" >>rest + [ validate-author list-posts "posts" set-value ] >>init - { blogs "user-posts" } >>template ; -: ( -- action ) + { blogs "posts-by" } >>template ; + +: ( -- 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 ; : ( -- action ) @@ -125,6 +134,7 @@ M: comment entity-url : ( -- action ) + "id" >>rest [ @@ -147,6 +157,7 @@ M: comment entity-url : ( -- action ) + [ validate-post uid "author" set-value @@ -160,38 +171,76 @@ M: comment entity-url [ insert-tuple ] [ entity-url ] bi ] >>submit - { blogs "new-post" } >>template ; + { blogs "new-post" } >>template + + + "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 select-tuple from-object ; : ( -- action ) - [ - validate-integer-id - "id" value select-tuple from-object - ] >>init + + "id" >>rest + + [ do-post-action ] >>init + + [ do-post-action validate-post ] >>validate + + [ "author" value authorize-author ] >>authorize [ - validate-integer-id - validate-post - ] >>validate - - [ - "id" value select-tuple - dup { "title" "content" } deposit-slots + "id" value + dup { "title" "author" "date" "content" } deposit-slots [ update-tuple ] [ entity-url ] bi ] >>submit - { blogs "edit-post" } >>template ; - + { blogs "edit-post" } >>template + + + "edit a blog post" >>description ; + +: delete-post ( id -- ) + [ delete-tuples ] [ f delete-tuples ] bi ; + : ( -- 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 + ] >>submit + + + "delete a blog post" >>description ; + +: ( -- action ) + + + [ validate-author ] >>validate + + [ "author" value authorize-author ] >>authorize + [ - "id" value delete-tuples - "author" value user-posts-url - ] >>submit ; + [ + f "author" value >>author select-tuples [ id>> delete-post ] each + f f "author" value >>author delete-tuples + ] with-transaction + "author" value posts-by-url + ] >>submit + + + "delete a blog post" >>description ; : validate-comment ( -- ) { @@ -213,41 +262,44 @@ M: comment entity-url uid >>author now >>date [ insert-tuple ] [ entity-url ] bi - ] >>submit ; - + ] >>submit + + + "make a comment" >>description ; + : ( -- action ) + [ validate-integer-id { { "parent" [ v-integer ] } } validate-params ] >>validate + + [ + "parent" value select-tuple + author>> authorize-author + ] >>authorize + [ f "id" value delete-tuples "parent" value view-post-url - ] >>submit ; - + ] >>submit + + + "delete a comment" >>description ; + : ( -- dispatcher ) blogs new-dispatcher "" add-responder "posts.atom" add-responder - "by" add-responder - "by.atom" add-responder + "by" add-responder + "by.atom" add-responder "post" add-responder "post.atom" add-responder - - "make a new blog post" >>description - "new-post" add-responder - - "edit a blog post" >>description - "edit-post" add-responder - - "delete a blog post" >>description - "delete-post" add-responder - - "make a comment" >>description - "new-comment" add-responder - - "delete a comment" >>description - "delete-comment" add-responder + "new-post" add-responder + "edit-post" add-responder + "delete-post" add-responder + "new-comment" add-responder + "delete-comment" add-responder { blogs "blogs-common" } >>template ; diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml index da88a78ab0..4522f8606b 100644 --- a/extra/webapps/blogs/edit-post.xml +++ b/extra/webapps/blogs/edit-post.xml @@ -15,13 +15,13 @@
Post by - + on | - View Post + View Post | Delete Post
diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml index 9c9685fe74..94a5a69775 100644 --- a/extra/webapps/blogs/list-posts.xml +++ b/extra/webapps/blogs/list-posts.xml @@ -7,7 +7,7 @@

- +

@@ -18,13 +18,13 @@
Post by - + on | - + comments. diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/posts-by.xml similarity index 77% rename from extra/webapps/blogs/user-posts.xml rename to extra/webapps/blogs/posts-by.xml index 95fae23b34..d94b598fc0 100644 --- a/extra/webapps/blogs/user-posts.xml +++ b/extra/webapps/blogs/posts-by.xml @@ -2,7 +2,7 @@ - + Recent Posts by @@ -13,7 +13,7 @@

- +

@@ -24,13 +24,13 @@
Post by - + on | - + comments. diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 23bf513946..55bdd2e806 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -2,11 +2,11 @@ - + : - + Recent Posts by @@ -18,13 +18,13 @@
Post by - + on | - Edit Post + Edit Post | Delete Post
@@ -33,7 +33,7 @@

- Comment by on : + Comment by on :

diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 2fbe5b4816..f6b604c06d 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -19,6 +19,10 @@ IN: webapps.pastebin TUPLE: pastebin < dispatcher ; +SYMBOL: can-delete-pastes? + +can-delete-pastes? define-capability + ! ! ! ! DOMAIN MODEL ! ! ! @@ -170,13 +174,20 @@ M: annotation entity-url : ( -- action ) + [ validate-integer-id ] >>validate [ - "id" value delete-tuples - "id" value f delete-tuples + [ + "id" value delete-tuples + "id" value f delete-tuples + ] with-transaction URL" $pastebin/list" - ] >>submit ; + ] >>submit + + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities ; ! ! ! ! ANNOTATIONS @@ -199,6 +210,7 @@ M: annotation entity-url : ( -- action ) + [ { { "id" [ v-number ] } } validate-params ] >>validate [ @@ -206,11 +218,11 @@ M: annotation entity-url [ delete-tuples ] [ parent>> paste-url ] bi - ] >>submit ; + ] >>submit -SYMBOL: can-delete-pastes? - -can-delete-pastes? define-capability + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities ; : ( -- responder ) pastebin new-dispatcher @@ -219,13 +231,9 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - - "delete pastes" >>description - { can-delete-pastes? } >>capabilities "delete-paste" add-responder + "delete-paste" add-responder "new-annotation" add-responder - - "delete annotations" >>description - { can-delete-pastes? } >>capabilities "delete-annotation" add-responder + "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3e780132b4..888d4bd145 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -18,6 +18,10 @@ IN: webapps.planet 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 ; @@ -30,8 +34,8 @@ blog "BLOGS" { { "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 ; @@ -40,7 +44,7 @@ posting "POSTINGS" { { "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 @@ -134,6 +138,7 @@ posting "POSTINGS" : ( -- action ) + { planet-factor "new-blog" } >>template [ validate-blog ] >>validate @@ -150,9 +155,10 @@ posting "POSTINGS" ] tri ] >>submit ; - + : ( -- action ) + [ validate-integer-id "id" value select-tuple from-object @@ -184,20 +190,16 @@ posting "POSTINGS" "update" add-responder "new-blog" add-responder "edit-blog" add-responder - "delete-blog" add-responder ; - -SYMBOL: can-administer-planet-factor? - -can-administer-planet-factor? define-capability + "delete-blog" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities ; : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder - - "administer Planet Factor" >>description - { can-administer-planet-factor? } >>capabilities - "admin" add-responder + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml index e19c531d3d..9b2ae930fb 100644 --- a/extra/webapps/wiki/articles.xml +++ b/extra/webapps/wiki/articles.xml @@ -7,7 +7,7 @@

  • - +
diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 5b3e9de2c4..1515c4924a 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -4,16 +4,26 @@ Recent Changes -
    - -
  • - - on - - by - -
    • -     -
+
+ + + + + + + + + + + + + + + + + +
ArticleDateBy
+ +
diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 35afe51b66..9d65531eb0 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -8,13 +8,13 @@ Old revision: - Created on by . + Created on by . New revision: - Created on by . + Created on by . diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml index 675cb8cd65..0d029946f8 100644 --- a/extra/webapps/wiki/page-common.xml +++ b/extra/webapps/wiki/page-common.xml @@ -2,16 +2,16 @@ - + Revisions of
- Latest - | Revisions - | Edit + Latest + | Revisions + | Edit | Delete
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 2a909e6ab3..97a051cd96 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -8,14 +8,14 @@ - + - - + + @@ -24,7 +24,7 @@

View Differences

- +
RevisionAuthorBy Rollback
Rollback
@@ -51,6 +51,6 @@
Old revision:
- + diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 6f22982f12..6f6ada2dbd 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -2,7 +2,7 @@ - + Edits by @@ -11,9 +11,9 @@
  • - + on - +
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 30dfb71270..7d2c7869b5 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -8,6 +8,6 @@
-

This revision created on by .

+

This revision created on by .

diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 21a983fc7b..18130f5144 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar -namespaces splitting sequences sorting math.order +namespaces splitting sequences sorting math.order present html.components syndication http.server http.server.dispatchers @@ -15,23 +15,26 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki -: view-url ( title -- url ) - "$wiki/view/" prepend >url ; +: wiki-url ( rest path -- url ) + [ "$wiki/" % % "/" % % ] "" make + swap >>path ; -: edit-url ( title -- url ) - "$wiki/edit" >url swap "title" set-query-param ; +: view-url ( title -- url ) "view" wiki-url ; -: revisions-url ( title -- url ) - "$wiki/revisions" >url swap "title" set-query-param ; +: edit-url ( title -- url ) "edit" wiki-url ; -: revision-url ( id -- url ) - "$wiki/revision" >url swap "id" set-query-param ; +: revisions-url ( title -- url ) "revisions" wiki-url ; -: user-edits-url ( author -- url ) - "$wiki/user-edits" >url swap "author" set-query-param ; +: revision-url ( id -- url ) "revision" wiki-url ; + +: user-edits-url ( author -- url ) "user-edits" wiki-url ; TUPLE: wiki < dispatcher ; +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + TUPLE: article title revision ; article "ARTICLES" { @@ -82,11 +85,11 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest [ validate-title - "view?title=" relative-link-prefix set ] >>init [ @@ -100,11 +103,14 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + + "id" >>rest + [ validate-integer-id "id" value select-tuple from-object - "view?title=" relative-link-prefix set + URL" $wiki/view/" adjust-url present relative-link-prefix set ] >>init { wiki "view" } >>template ; @@ -121,6 +127,9 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + + "title" >>rest + [ validate-title "title" value
select-tuple [ @@ -129,7 +138,7 @@ M: revision feed-entry-url id>> revision-url ; ] >>init { wiki "edit" } >>template - + [ validate-title { { "content" [ v-required ] } } validate-params @@ -140,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ; logged-in-user get username>> >>author "content" value >>content [ add-revision ] [ title>> view-url ] bi - ] >>submit ; + ] >>submit + + + "edit wiki articles" >>description ; : list-revisions ( -- seq ) f "title" value >>title select-tuples @@ -148,21 +160,32 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + + "title" >>rest + [ validate-title list-revisions "revisions" set-value ] >>init + { wiki "revisions" } >>template ; : ( -- action ) + + "title" >>rest + [ validate-title ] >>init + [ "Revisions of " "title" value append ] >>title + [ "title" value revisions-url ] >>url + [ list-revisions ] >>entries ; : ( -- action ) + [ validate-integer-id ] >>validate [ @@ -171,13 +194,12 @@ M: revision feed-entry-url id>> revision-url ; ] >>submit ; : list-changes ( -- seq ) - "id" value select-tuples + f select-tuples reverse-chronological-order ; : ( -- action ) [ list-changes "changes" set-value ] >>init - { wiki "changes" } >>template ; : ( -- action ) @@ -188,13 +210,18 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + [ validate-title ] >>validate [ "title" value
delete-tuples f "title" value >>title delete-tuples URL" $wiki" - ] >>submit ; + ] >>submit + + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities ; : ( -- action ) @@ -218,6 +245,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + [ f
select-tuples [ [ title>> ] compare ] sort @@ -232,23 +260,24 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + + "author" >>rest + [ validate-author list-user-edits "user-edits" set-value ] >>init + { wiki "user-edits" } >>template ; : ( -- action ) + "author" >>rest [ validate-author ] >>init [ "Edits by " "author" value append ] >>title [ "author" value user-edits-url ] >>url [ list-user-edits ] >>entries ; -SYMBOL: can-delete-wiki-articles? - -can-delete-wiki-articles? define-capability - : ( responder -- responder' ) { wiki "page-common" } >>template ; @@ -261,18 +290,13 @@ can-delete-wiki-articles? define-capability "revisions" add-responder "revisions.atom" add-responder "diff" add-responder - - "edit wiki articles" >>description - "edit" add-responder + "edit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder "changes" add-responder "user-edits.atom" add-responder "changes.atom" add-responder - - "delete wiki articles" >>description - { can-delete-wiki-articles? } >>capabilities - "delete" add-responder + "delete" add-responder { wiki "wiki-common" } >>template ;