diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ca49b550b0..c875475278 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : value-at ( value assoc -- key/f ) swap [ = nip ] curry assoc-find 2drop ; +: push-at ( value key assoc -- ) + [ ?push ] change-at ; + : zip ( keys values -- alist ) 2array flip ; inline diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 03961c2db6..b41cf9c4a5 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -38,7 +38,7 @@ IN: bit-arrays.tests [ t ] [ 100 [ - drop 100 [ drop 2 random zero? ] map + drop 100 [ 2 random zero? ] replicate dup >bit-array >array = ] all? ] unit-test diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 28e899d08b..05c254f225 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -204,7 +204,7 @@ UNION: z1 b1 c1 ; 10 [ [ ] [ - 20 [ drop random-op ] map >quotation + 20 [ random-op ] [ ] replicate-as [ infer effect-in [ random-class ] times ] keep call drop @@ -238,8 +238,8 @@ UNION: z1 b1 c1 ; 20 [ [ t ] [ - 20 [ drop random-boolean-op ] [ ] map-as dup . - [ infer effect-in [ drop random-boolean ] map dup . ] keep + 20 [ random-boolean-op ] [ ] replicate-as dup . + [ infer effect-in [ random-boolean ] replicate dup . ] keep [ >r [ ] each r> call ] 2keep 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/inference/backend/backend.factor b/core/inference/backend/backend.factor index 8966a38496..f8b071e803 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ; 1 #drop node, pop-d dup value-literal >r value-recursion r> ; -: value-vector ( n -- vector ) [ drop ] V{ } map-as ; +: value-vector ( n -- vector ) [ ] V{ } replicate-as ; : add-inputs ( seq stack -- n stack ) tuck [ length ] bi@ - dup 0 > @@ -162,7 +162,7 @@ TUPLE: too-many-r> ; dup ensure-values #>r over 0 pick node-inputs - over [ drop pop-d ] map reverse [ push-r ] each + over [ pop-d ] replicate reverse [ push-r ] each 0 pick pick node-outputs node, drop ; @@ -171,7 +171,7 @@ TUPLE: too-many-r> ; dup check-r> #r> 0 pick pick node-inputs - over [ drop pop-r ] map reverse [ push-d ] each + over [ pop-r ] replicate reverse [ push-d ] each over 0 pick node-outputs node, drop ; diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index a2e9f88135..d4905a1718 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -13,7 +13,7 @@ SYMBOL: def-use used-by empty? ; : uses-values ( node seq -- ) - [ def-use get [ ?push ] change-at ] with each ; + [ def-use get push-at ] with each ; : defs-values ( seq -- ) #! If there is no value, set it to a new empty vector, @@ -132,5 +132,4 @@ M: #r> kill-node* #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - nest-def-use keys - def-use get [ [ t swap ?push ] change-at ] curry each ; + nest-def-use keys def-use get [ t -rot push-at ] curry each ; 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/core/sequences/sequences.factor b/core/sequences/sequences.factor index 4854ff8001..cb33552693 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -361,6 +361,12 @@ PRIVATE> : map ( seq quot -- newseq ) over map-as ; inline +: replicate ( seq quot -- newseq ) + [ drop ] prepose map ; inline + +: replicate-as ( seq quot exemplar -- newseq ) + >r [ drop ] prepose r> map-as ; inline + : change-each ( seq quot -- ) over map-into ; inline diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index a56c41b620..17ec2d7cd1 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? + 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 44e1d8859f..d10f1603f1 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -98,7 +98,7 @@ unit-test [ ] [ [ 4 [ - 100 [ drop "obdurak" clone ] map + 100 [ "obdurak" clone ] replicate gc dup [ 1234 0 rot set-string-nth diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 8f64265771..7f4abe3222 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -26,7 +26,7 @@ IN: vectors.tests [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 [ drop 100 random ] map >vector + 100 [ 100 random ] V{ } map-as dup >array >vector = ] unit-test diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index c3e487a9fc..1c89c1eb16 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -17,9 +17,6 @@ IN: assocs.lib : replace-at ( assoc value key -- assoc ) >r >r dup r> 1vector r> rot set-at ; -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : peek-at* ( assoc key -- obj ? ) swap at* dup [ >r peek r> ] when ; @@ -32,7 +29,7 @@ IN: assocs.lib : multi-assoc-each ( assoc quot -- ) [ with each ] curry assoc-each ; inline -: insert ( value variable -- ) namespace insert-at ; +: insert ( value variable -- ) namespace push-at ; : generate-key ( assoc -- str ) >r 32 random-bits >hex r> diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 0480235dfe..c64d1e4872 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -24,7 +24,7 @@ M: color-preview model-changed [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) - 3 [ drop 0 0 0 255 ] map + 3 [ 0 0 0 255 ] replicate dup [ range-model ] map swap [ [ gadget, ] each ] make-filled-pile ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 807aeda74a..5c3f3e13e6 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -195,3 +195,12 @@ M: db ( tuple class groups -- statement ) ] { { } { } { } } nmake >r >r parse-sql 4drop r> r> maybe-make-retryable do-select ; + +: create-index ( index-name table-name columns -- ) + [ + >r >r "create index " % % r> " on " % % r> "(" % + "," join % ")" % + ] "" make sql-command ; + +: drop-index ( index-name -- ) + [ "drop index " % % ] "" make sql-command ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c375dcf874..4f1e950b01 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs -sequences arrays vectors definitions prettyprint combinators.lib -math hashtables sets ; +sequences arrays vectors definitions prettyprint +math hashtables sets macros namespaces ; IN: delegate : protocol-words ( protocol -- words ) @@ -23,7 +23,15 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi + [ + nip + [ + over second saver % + % + dup second restorer % + first , + ] [ ] make + ] 3bi define ; : change-word-prop ( word prop quot -- ) 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/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor index a3a5075820..4249aea2d9 100644 --- a/extra/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math +USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; IN: gap-buffer.cursortree @@ -21,7 +21,7 @@ TUPLE: right-cursor ; : cursor-index ( cursor -- i ) cursor-i ; -: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ; : remove-cursor ( cursortree cursor -- ) tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 00a8e287e6..eef2463019 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -114,7 +114,7 @@ M: help-error error. H{ } clone [ [ >r >r dup >link where dup - [ first r> at r> [ ?push ] change-at ] + [ first r> at r> push-at ] [ r> r> 2drop 2drop ] if ] 2curry each diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 6ca596f503..433aedbc9a 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -151,7 +151,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template 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/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 06a3ec8dd2..3efef66ae3 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -15,7 +15,7 @@ IN: io.files.unique [ 10 random CHAR: 0 + ] [ random-letter ] if ; : random-name ( n -- string ) - [ drop random-ch ] "" map-as ; + [ random-ch ] "" replicate-as ; : unique-length ( -- n ) 10 ; inline : unique-retries ( -- n ) 10 ; inline diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index b519752e79..72beb473ed 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings io.backend io.ports io.streams.duplex -io splitting grouping sequences sequences.lib namespaces kernel +io splitting grouping sequences namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; IN: io.pipes 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-tests.factor b/extra/io/server/server-tests.factor index 86cfe35bc1..965a70718b 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -2,6 +2,6 @@ IN: io.server.tests USING: tools.test io.server io.server.private kernel ; { 2 0 } [ [ ] server-loop ] must-infer-as -{ 2 0 } [ [ ] with-connection ] must-infer-as +{ 3 0 } [ [ ] with-connection ] must-infer-as { 1 0 } [ [ ] swap datagram-loop ] must-infer-as { 2 0 } [ [ ] with-datagrams ] must-infer-as 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/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 67856a0570..8e76be2632 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ; GENERIC: add-input-callback ( thread fd mx -- ) -: add-callback ( thread fd assoc -- ) - [ ?push ] change-at ; - -M: mx add-input-callback reads>> add-callback ; +M: mx add-input-callback reads>> push-at ; GENERIC: add-output-callback ( thread fd mx -- ) -M: mx add-output-callback writes>> add-callback ; +M: mx add-output-callback writes>> push-at ; GENERIC: remove-input-callbacks ( fd mx -- callbacks ) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 7b636609b0..b56473a0a9 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -142,7 +142,7 @@ DEFER: (d) ! Computing a basis : graded ( seq -- seq ) - dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map + dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate [ dup length pick nth push ] reduce ; : nth-basis-elt ( generators n -- elt ) diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor index 3aa10a0687..7d9a9ffd27 100755 --- a/extra/lcs/lcs-tests.factor +++ b/extra/lcs/lcs-tests.factor @@ -2,6 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test lcs ; +\ lcs must-infer +\ diff must-infer +\ levenshtein must-infer + [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor index 06c33505ca..4b0fb53f5e 100755 --- a/extra/lcs/lcs.factor +++ b/extra/lcs/lcs.factor @@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ; [ 1- ] change-i [ 1- ] change-j ; : inserted? ( state -- ? ) - [ j>> 0 > ] - [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ; + { + [ j>> 0 > ] + [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ] + } 1&& ; : do-insert ( state -- state ) dup new-nth insert boa , [ 1- ] change-j ; : deleted? ( state -- ? ) - [ i>> 0 > ] - [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ; + { + [ i>> 0 > ] + [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ] + } 1&& ; : do-delete ( state -- state ) dup old-nth delete boa , [ 1- ] change-i ; diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 8c93d4f7e6..49de5dbc03 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -17,9 +17,6 @@ IN: project-euler.150 : partial-sum-infimum ( seq -- seq ) 0 0 rot [ (partial-sum-infimum) ] each drop ; inline -: generate ( n quot -- seq ) - [ drop ] prepose map ; inline - : map-infimum ( seq quot -- min ) [ min ] compose 0 swap reduce ; inline @@ -30,7 +27,7 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; + 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ; PRIVATE> diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 265cd5b592..ed4c337a92 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -131,10 +131,6 @@ MACRO: firstn ( n -- ) [ find drop [ head-slice ] when* ] curry [ dup ] prepose keep like ; -: replicate ( seq quot -- newseq ) - #! quot: ( -- obj ) - [ drop ] prepose map ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : short ( seq n -- seq n' ) over length min ; inline -= [ - n n 1- seq exchange - seq quot n 1- insert - ] unless - ] unless ; inline -PRIVATE> - -: insertion-sort ( seq quot -- ) - ! quot is a transformation on elements - over length [ insert ] 2with each ; inline - : if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline diff --git a/extra/sorting/insertion/authors.txt b/extra/sorting/insertion/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/sorting/insertion/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/sorting/insertion/insertion.factor b/extra/sorting/insertion/insertion.factor new file mode 100644 index 0000000000..3a46eb83fd --- /dev/null +++ b/extra/sorting/insertion/insertion.factor @@ -0,0 +1,16 @@ +USING: locals sequences kernel math ; +IN: sorting.insertion + += [ + n n 1- seq exchange + seq quot n 1- insert + ] unless + ] unless ; inline +PRIVATE> + +: insertion-sort ( seq quot -- ) + ! quot is a transformation on elements + over length [ insert ] with with each ; inline diff --git a/extra/sorting/insertion/summary.txt b/extra/sorting/insertion/summary.txt new file mode 100644 index 0000000000..a71be797d9 --- /dev/null +++ b/extra/sorting/insertion/summary.txt @@ -0,0 +1 @@ +Insertion sort diff --git a/extra/sorting/insertion/tags.txt b/extra/sorting/insertion/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sorting/insertion/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index af005b4abe..1feaf46017 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str ) ] if next ; : expect-string ( string -- ) - dup [ drop get-char next ] map 2dup = + dup [ get-char next ] replicate 2dup = [ 2drop ] [ expected ] if ; : init-parser ( -- ) diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor index 2779e190c9..6e0ce05eaa 100644 --- a/extra/strings/lib/lib-tests.factor +++ b/extra/strings/lib/lib-tests.factor @@ -5,4 +5,4 @@ IN: temporary [ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test -[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test +[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index e1d88e479d..6ecca05ec8 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -30,5 +30,4 @@ IN: strings.lib alphanumeric-chars random ; : random-alphanumeric-string ( length -- str ) - [ drop random-alphanumeric-char ] map "" like ; - + [ random-alphanumeric-char ] "" replicate-as ; diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 3e38f60627..c0fe59a529 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -8,7 +8,7 @@ IN: ui.gadgets.frames ! gadgets gets left-over space. TUPLE: frame ; -: ( -- grid ) 9 [ drop ] map 3 group ; +: ( -- grid ) 9 [ ] replicate 3 group ; : @center 1 1 ; : @left 0 1 ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 23dfc16e78..b70d79b872 100755 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) - [ (extend)? ] - [ "Other_Grapheme_Extend" property? ] or? ; + { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ; : grapheme-class ( ch -- class ) { @@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ; } cond ; : init-grapheme-table ( -- table ) - graphemes [ drop graphemes f ] map ; + graphemes [ graphemes f ] replicate ; SYMBOL: table diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor index f71a58be85..216f80c79d 100755 --- a/extra/unicode/collation/collation.factor +++ b/extra/unicode/collation/collation.factor @@ -58,8 +58,7 @@ ducet insert-helpers HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ; : illegal? ( char -- ? ) - [ "Noncharacter_Code_Point" property? ] - [ category "Cs" = ] or? ; + { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ; : derive-weight ( char -- weights ) first dup illegal? diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index e3dd15558b..5fb769e499 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,7 +1,7 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting grouping arrays math.parser hash2 math.order byte-arrays words namespaces words compiler.units parser -io.encodings.ascii values interval-maps ascii sets assocs.lib +io.encodings.ascii values interval-maps ascii sets combinators.lib combinators locals math.ranges sorting ; IN: unicode.data @@ -62,7 +62,7 @@ VALUE: properties dup [ swap (chain-decomposed) ] curry assoc-map ; : first* ( seq -- ? ) - second [ empty? ] [ first ] or? ; + second { [ empty? ] [ first ] } 1|| ; : (process-decomposed) ( data -- alist ) 5 swap (process-data) @@ -107,7 +107,7 @@ VALUE: properties :: fill-ranges ( table -- table ) name-map >alist sort-values keys - [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter + [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter 2 group [ [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi [ swap table ?set-nth ] curry each @@ -151,7 +151,7 @@ C: code-point : properties>intervals ( properties -- assoc[str,interval] ) dup values prune [ f ] H{ } map>assoc - [ [ insert-at ] curry assoc-each ] keep + [ [ push-at ] curry assoc-each ] keep [ ] assoc-map ; : load-properties ( -- assoc ) diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 576c5a7e20..3b64cf577f 100755 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -1,5 +1,5 @@ USING: sequences namespaces unicode.data kernel math arrays -locals combinators.lib sequences.lib combinators.lib ; +locals combinators.lib sorting.insertion combinators.lib ; IN: unicode.normalize ! Conjoining Jamo behavior 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/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index afdacf9add..d408c645f3 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -26,7 +26,7 @@ short-url "SHORT_URLS" { 3append ; foldable : random-url ( -- string ) - 1 6 [a,b] random [ drop letter-bank random ] "" map-as ; + 1 6 [a,b] random [ letter-bank random ] "" replicate-as ; : insert-short-url ( short-url -- short-url ) '[ , dup random-url >>short insert-tuple ] 10 retry ; 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 ; diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor old mode 100644 new mode 100755 index 4833a7412a..4202ed4c56 --- a/extra/windows/com/com.factor +++ b/extra/windows/com/com.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types windows.com.syntax windows.ole32 -windows.types continuations kernel alien.syntax ; +windows.types continuations kernel alien.syntax libc ; IN: windows.com LIBRARY: ole32 @@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; : com-query-interface ( interface iid -- interface' ) - f - [ IUnknown::QueryInterface ole32-error ] keep - *void* ; + "void*" heap-size [ + [ IUnknown::QueryInterface ole32-error ] keep *void* + ] with-malloc ; : com-add-ref ( interface -- interface ) [ IUnknown::AddRef drop ] keep ; inline diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 972a75ecb9..6d6aa078e8 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -1,11 +1,12 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel -sequences.lib namespaces windows.ole32 libc +sequences.lib namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators -math combinators.lib words compiler.units destructors ; +math combinators.lib words compiler.units destructors fry +math.parser ; IN: windows.com.wrapper -TUPLE: com-wrapper vtbls freed? ; +TUPLE: com-wrapper vtbls disposed ; byte-array ] % + [ find-com-interface-definition family-tree [ iid>> ] map ] dip + 1quotation [ 2array ] curry map + ] map-index concat + [ drop f ] suffix ; + +: (make-query-interface) ( interfaces -- quot ) + (query-interface-cases) + '[ + swap 16 memory>byte-array + , case [ - >r find-com-interface-definition family-tree - r> 1quotation [ >r iid>> r> 2array ] curry map - ] map-index concat - [ drop f ] suffix , - \ case , - "void*" heap-size - [ * rot com-add-ref 0 rot set-void*-nth S_OK ] - curry , - [ nip f 0 rot set-void*-nth E_NOINTERFACE ] , - \ if* , - ] [ ] make ; + "void*" heap-size * rot com-add-ref + 0 rot set-void*-nth S_OK + ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if* + ] ; : (make-add-ref) ( interfaces -- quot ) - length "void*" heap-size * [ swap + length "void*" heap-size * '[ + , swap 0 over ulong-nth 1+ [ 0 rot set-ulong-nth ] keep - ] curry ; + ] ; : (make-release) ( interfaces -- quot ) - length "void*" heap-size * [ over + length "void*" heap-size * '[ + , over 0 over ulong-nth 1- [ 0 rot set-ulong-nth ] keep dup zero? [ swap (free-wrapped-object) ] [ nip ] if - ] curry ; + ] ; : (make-iunknown-methods) ( interfaces -- quots ) [ (make-query-interface) ] @@ -60,32 +75,48 @@ unless : (thunk) ( n -- quot ) dup 0 = [ drop [ ] ] - [ "void*" heap-size neg * [ swap ] curry ] + [ "void*" heap-size neg * '[ , swap ] ] if ; -: (thunked-quots) ( quots iunknown-methods thunk -- quots' ) - [ [ swap 2array ] curry map swap ] keep - [ com-unwrap ] compose [ swap 2array ] curry map append ; +: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) + [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ] + [ '[ , [ swap 2array ] curry map ] ] bi bi* + swap append ; -: compile-alien-callback ( return parameters abi quot -- alien ) +: compile-alien-callback ( word return parameters abi quot -- alien ) [ alien-callback ] 4 ncurry - [ gensym [ swap (( -- alien )) define-declared ] keep ] + [ [ (( -- alien )) define-declared ] pick slip ] with-compilation-unit execute ; -: (make-vtbl) ( interface-name quots iunknown-methods n -- ) +: (byte-array-to-malloced-buffer) ( byte-array -- alien ) + [ byte-length malloc ] [ over byte-array>memory ] bi ; + +: (callback-word) ( function-name interface-name counter -- word ) + [ "::" rot 3append "-callback-" ] dip number>string 3append + "windows.com.wrapper.callbacks" create ; + +: (finish-thunk) ( param-count thunk quot -- thunked-quot ) + [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] + dip compose ; + +: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl ) (thunk) (thunked-quots) - swap find-com-interface-definition family-tree-functions [ - [ return>> ] [ parameters>> [ first ] map ] bi - dup length 1- roll [ - first dup empty? - [ 2drop [ ] ] - [ swap [ ndip ] 2curry ] - if - ] [ second ] bi compose + swap [ find-com-interface-definition family-tree-functions ] + keep (next-vtbl-counter) '[ + swap [ + [ name>> , , (callback-word) ] + [ return>> ] [ + parameters>> + [ [ first ] map ] + [ length ] bi + ] tri + ] [ + first2 (finish-thunk) + ] bi* "stdcall" swap compile-alien-callback - ] 2map >c-void*-array [ byte-length malloc ] keep - over byte-array>memory ; + ] 2map >c-void*-array + (byte-array-to-malloced-buffer) ; : (make-vtbls) ( implementations -- vtbls ) dup [ first ] map (make-iunknown-methods) @@ -102,11 +133,10 @@ PRIVATE> : ( implementations -- wrapper ) (make-vtbls) f com-wrapper boa ; -M: com-wrapper dispose - t >>freed? +M: com-wrapper dispose* vtbls>> [ free ] each ; : com-wrap ( object wrapper -- wrapped-object ) - dup (malloc-wrapped-object) >r vtbls>> r> + [ vtbls>> ] [ (malloc-wrapped-object) ] bi [ [ set-void*-nth ] curry each-index ] keep [ +wrapped-objects+ get-global set-at ] keep ; diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index df5580fc68..daaeac70a4 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset ) rule-set-imports push ; : inverted-index ( hashes key index -- ) - [ swapd [ ?push ] change-at ] 2curry each ; + [ swapd push-at ] 2curry each ; : ?push-all ( seq1 seq2 -- seq1+seq2 ) [