Merge branch 'master' of factorcode.org:/git/factor

db4
Eduardo Cavazos 2008-06-13 03:41:18 -05:00
commit 8c6c4a8f4e
69 changed files with 555 additions and 374 deletions

View File

@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: value-at ( value assoc -- key/f ) : value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ; swap [ = nip ] curry assoc-find 2drop ;
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: zip ( keys values -- alist ) : zip ( keys values -- alist )
2array flip ; inline 2array flip ; inline

View File

@ -38,7 +38,7 @@ IN: bit-arrays.tests
[ t ] [ [ t ] [
100 [ 100 [
drop 100 [ drop 2 random zero? ] map drop 100 [ 2 random zero? ] replicate
dup >bit-array >array = dup >bit-array >array =
] all? ] all?
] unit-test ] unit-test

View File

@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
10 [ 10 [
[ ] [ [ ] [
20 [ drop random-op ] map >quotation 20 [ random-op ] [ ] replicate-as
[ infer effect-in [ random-class ] times ] keep [ infer effect-in [ random-class ] times ] keep
call call
drop drop
@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
20 [ 20 [
[ t ] [ [ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup . 20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep [ infer effect-in [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep [ >r [ ] each r> call ] 2keep

View File

@ -10,3 +10,5 @@ IN: grouping.tests
2 over set-length 2 over set-length
>array >array
] unit-test ] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test

View File

@ -56,7 +56,7 @@ M: clumps set-length
M: clumps group@ M: clumps group@
[ n>> over + ] [ seq>> ] bi ; [ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ; TUPLE: sliced-clumps < clumps ;
: <sliced-clumps> ( seq n -- clumps ) : <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline sliced-clumps new-groups ; inline

View File

@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
1 #drop node, 1 #drop node,
pop-d dup value-literal >r value-recursion r> ; pop-d dup value-literal >r value-recursion r> ;
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ; : value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack ) : add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 > tuck [ length ] bi@ - dup 0 >
@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
dup ensure-values dup ensure-values
#>r #>r
over 0 pick node-inputs 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 0 pick pick node-outputs
node, node,
drop ; drop ;
@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
dup check-r> dup check-r>
#r> #r>
0 pick pick node-inputs 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 over 0 pick node-outputs
node, node,
drop ; drop ;

View File

@ -13,7 +13,7 @@ SYMBOL: def-use
used-by empty? ; used-by empty? ;
: uses-values ( node seq -- ) : uses-values ( node seq -- )
[ def-use get [ ?push ] change-at ] with each ; [ def-use get push-at ] with each ;
: defs-values ( seq -- ) : defs-values ( seq -- )
#! If there is no value, set it to a new empty vector, #! 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 #! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously #! having _some_ usage, so that flushing doesn't erronously
#! flush them away. #! flush them away.
nest-def-use keys nest-def-use keys def-use get [ t -rot push-at ] curry each ;
def-use get [ [ t swap ?push ] change-at ] curry each ;

View File

@ -117,14 +117,18 @@ $nl
{ $subsection parse-tokens } ; { $subsection parse-tokens } ;
ARTICLE: "parsing-words" "Parsing words" 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 $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:" "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" } { $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 $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:" "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:" "Tools for implementing parsing words:"
{ $subsection "reading-ahead" } { $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" } { $subsection "parsing-word-nest" }

View File

@ -361,6 +361,12 @@ PRIVATE>
: map ( seq quot -- newseq ) : map ( seq quot -- newseq )
over map-as ; inline 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 -- ) : change-each ( seq quot -- )
over map-into ; inline over map-into ; inline

View File

@ -11,7 +11,7 @@ unit-test
[ t ] [ [ t ] [
100 [ 100 [
drop 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? ] all?
] unit-test ] unit-test

View File

@ -98,7 +98,7 @@ unit-test
[ ] [ [ ] [
[ [
4 [ 4 [
100 [ drop "obdurak" clone ] map 100 [ "obdurak" clone ] replicate
gc gc
dup [ dup [
1234 0 rot set-string-nth 1234 0 rot set-string-nth

View File

@ -26,7 +26,7 @@ IN: vectors.tests
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [ [ t ] [
100 [ drop 100 random ] map >vector 100 [ 100 random ] V{ } map-as
dup >array >vector = dup >array >vector =
] unit-test ] unit-test

View File

@ -17,9 +17,6 @@ IN: assocs.lib
: replace-at ( assoc value key -- assoc ) : replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ; >r >r dup r> 1vector r> rot set-at ;
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: peek-at* ( assoc key -- obj ? ) : peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ; swap at* dup [ >r peek r> ] when ;
@ -32,7 +29,7 @@ IN: assocs.lib
: multi-assoc-each ( assoc quot -- ) : multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline [ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ; : insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str ) : generate-key ( assoc -- str )
>r 32 random-bits >hex r> >r 32 random-bits >hex r>

View File

@ -24,7 +24,7 @@ M: color-preview model-changed
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ; [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget ) : <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map 3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose> dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ; swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;

View File

@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
] { { } { } { } } nmake ] { { } { } { } } nmake
>r >r parse-sql 4drop r> r> >r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ; <simple-statement> 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 ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs USING: parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint combinators.lib sequences arrays vectors definitions prettyprint
math hashtables sets ; math hashtables sets macros namespaces ;
IN: delegate IN: delegate
: protocol-words ( protocol -- words ) : protocol-words ( protocol -- words )
@ -23,7 +23,15 @@ M: tuple-class group-words
: consult-method ( word class quot -- ) : consult-method ( word class quot -- )
[ drop swap first create-method ] [ 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 ; define ;
: change-word-prop ( word prop quot -- ) : change-word-prop ( word prop quot -- )

View File

@ -29,14 +29,10 @@ SYMBOL: rest
CHLOE: validation-messages drop render-validation-messages ; 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-action ( class -- action )
new new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
[ ] >>init
[ <400> ] >>display
[ ] >>validate
[ <400> ] >>submit ;
: <action> ( -- action ) : <action> ( -- action )
action new-action ; action new-action ;
@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ;
: handle-get ( action -- response ) : handle-get ( action -- response )
'[ '[
, , dup display>> [
[ init>> call ] {
[ drop flashed-variables restore-flash ] [ init>> call ]
[ display>> call ] [ authorize>> call ]
tri [ drop flashed-variables restore-flash ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ; ] with-exit-continuation ;
: validation-failed ( -- * ) : validation-failed ( -- * )
request get method>> "POST" = [ f ] [ <400> ] if exit-with ; request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response ) : (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 ) : param ( name -- value )
params get at ; params get at ;

View File

@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
TUPLE: protected < filter-responder description capabilities ; TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: users ( -- provider ) : users ( -- provider )
login get users>> ; login get users>> ;
@ -85,13 +89,17 @@ M: user-saver dispose
"invalid username or password" validation-error "invalid username or password" validation-error
validation-failed ; validation-failed ;
SYMBOL: description
SYMBOL: capabilities
: flashed-variables { description capabilities } ;
: <login-action> ( -- action ) : <login-action> ( -- action )
<page-action> <page-action>
[ [
protected fget [ flashed-variables restore-flash
[ description>> "description" set-value ] description get "description" set-value
[ capabilities>> words>strings "capabilities" set-value ] bi capabilities get words>strings "capabilities" set-value
] when*
] >>init ] >>init
{ login "login" } >>template { login "login" } >>template
@ -200,7 +208,10 @@ M: user-saver dispose
drop drop
URL" $login" end-aside URL" $login" end-aside
] >>submit ; ] >>submit
<protected>
"edit your profile" >>description ;
! ! ! Password recovery ! ! ! Password recovery
@ -316,32 +327,36 @@ SYMBOL: lost-password-from
] >>submit ; ] >>submit ;
! ! ! Authentication logic ! ! ! Authentication logic
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: show-login-page ( -- response ) : show-login-page ( -- response )
begin-aside begin-aside
URL" $login/login" { protected } <flash-redirect> ; protected get description>> description set
protected get capabilities>> capabilities set
URL" $login/login" flashed-variables <flash-redirect> ;
: check-capabilities ( responder user -- ? ) : login-required ( -- * )
[ capabilities>> ] bi@ subset? ; 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 ) M: protected call-responder* ( path responder -- response )
dup protected set dup protected set
uid dup [ dup logged-in-user get check-capabilities
users get-user 2dup check-capabilities [ [ call-next-method ] [ 2drop show-login-page ] if ;
[ logged-in-user set ] [ save-user-after ] bi
call-next-method : init-user ( -- )
] [ uid [
3drop show-login-page users get-user
] if [ logged-in-user set ]
] [ [ save-user-after ] bi
3drop show-login-page ] when* ;
] if ;
M: login call-responder* ( path responder -- response ) M: login call-responder* ( path responder -- response )
dup login set dup login set
init-user
call-next-method ; call-next-method ;
: <login-boilerplate> ( responder -- responder' ) : <login-boilerplate> ( responder -- responder' )
@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
! ! ! Configuration ! ! ! Configuration
: allow-edit-profile ( login -- login ) : allow-edit-profile ( login -- login )
<edit-profile-action> <protected> <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
"edit your profile" >>description
<login-boilerplate>
"edit-profile" add-responder ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )
<register-action> <login-boilerplate> <register-action> <login-boilerplate>

View File

@ -97,15 +97,22 @@ SYMBOL: exit-continuation
dup empty? dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom : a-url-path ( tag -- string )
[ children>string ] [ "href" required-attr ] [ "rest" optional-attr value ] bi
[ "href" required-attr ] [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
[ "query" optional-attr parse-query-attr ] tri
<url> : a-url ( tag -- url )
swap >>query dup "value" optional-attr
swap >>path [ value ] [
adjust-url relative-to-request <url>
add-atom-feed ; 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 ; CHLOE: write-atom drop write-atom-feeds ;
@ -114,23 +121,11 @@ GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ; M: object link-attr 2drop ;
: link-attrs ( tag -- ) : link-attrs ( tag -- )
#! Side-effects current namespace.
'[ , _ link-attr ] each-responder ; '[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- ) : a-start-tag ( tag -- )
[ [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
<a
dup link-attrs
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if
<url>
swap >>query
swap >>path
adjust-url relative-to-request =href
a>
] with-scope ;
CHLOE: a CHLOE: a
[ a-start-tag ] [ a-start-tag ]
@ -158,11 +153,12 @@ CHLOE: a
[ [
[ [
<form <form
"POST" =method {
[ link-attrs ] [ link-attrs ]
[ "action" required-attr resolve-base-path =action ] [ "method" optional-attr "post" or =method ]
[ tag-attrs non-chloe-attrs-only print-attrs ] [ "action" required-attr resolve-base-path =action ]
tri [ tag-attrs non-chloe-attrs-only print-attrs ]
} cleave
form> form>
] ]
[ form-magic ] bi [ form-magic ] bi

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; sequences quotations ;
IN: gap-buffer.cursortree IN: gap-buffer.cursortree
@ -21,7 +21,7 @@ TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ; : 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 -- ) : remove-cursor ( cursortree cursor -- )
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;

View File

@ -114,7 +114,7 @@ M: help-error error.
H{ } clone [ H{ } clone [
[ [
>r >r dup >link where dup >r >r dup >link where dup
[ first r> at r> [ ?push ] change-at ] [ first r> at r> push-at ]
[ r> r> 2drop 2drop ] [ r> r> 2drop 2drop ]
if if
] 2curry each ] 2curry each

View File

@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [ [ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[ [
"test10" test-template call-template "test10" test-template call-template
] run-template ] run-template

View File

@ -7,7 +7,7 @@ IN: http.tests
: lf>crlf "\n" split "\r\n" join ; : lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1
POST http://foo/bar HTTP/1.1 POST /bar HTTP/1.1
Some-Header: 1 Some-Header: 1
Some-Header: 2 Some-Header: 2
Content-Length: 4 Content-Length: 4
@ -18,7 +18,7 @@ blah
[ [
TUPLE{ request TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } url: TUPLE{ url path: "/bar" }
method: "POST" method: "POST"
version: "1.1" version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } 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 ] unit-test
STRING: read-request-test-2 STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1 HEAD /bar HTTP/1.1
Host: www.sex.com Host: www.sex.com
; ;
[ [
TUPLE{ request 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" method: "HEAD"
version: "1.1" version: "1.1"
header: H{ { "host" "www.sex.com" } } header: H{ { "host" "www.sex.com" } }

View File

@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present math.parser calendar calendar.format present
io io.server io.sockets.secure io io.encodings.iana io.encodings.binary io.encodings.8-bit
io.encodings.iana io.encodings.binary io.encodings.8-bit
unicode.case unicode.categories qualified unicode.case unicode.categories qualified
@ -142,7 +141,6 @@ cookies ;
request new request new
"1.1" >>version "1.1" >>version
<url> <url>
"http" >>protocol
H{ } clone >>query H{ } clone >>query
>>url >>url
H{ } clone >>header H{ } clone >>header
@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
: extract-host ( request -- request ) : extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri [ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi* [ >>host ] [ >>port ] bi*
ensure-port
drop ; drop ;
: extract-cookies ( request -- request ) : extract-cookies ( request -- request )
@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
: parse-content-type ( content-type -- type encoding ) : parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ; ";" 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-request ( -- request )
<request> <request>
read-method read-method
@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
read-request-version read-request-version
read-request-header read-request-header
read-post-data read-post-data
detect-protocol
extract-host extract-host
extract-cookies ; extract-cookies ;

View File

@ -1,10 +1,14 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; logging urls http http.server http.server.responses ;
IN: http.server.redirection 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>> request get url>>
clone clone
f >>query f >>query

View File

@ -2,16 +2,18 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations vocabs.loader destructors assocs debugger continuations
tools.vocabs math combinators tools.vocabs math
io io
io.server io.server
io.sockets
io.sockets.secure
io.encodings io.encodings
io.encodings.utf8 io.encodings.utf8
io.encodings.ascii io.encodings.ascii
io.encodings.binary io.encodings.binary
io.streams.limited io.streams.limited
io.timeouts io.timeouts
fry logging calendar fry logging calendar urls
http http
http.server.responses http.server.responses
html.elements html.elements
@ -66,7 +68,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[ [
utf8 [ utf8 [
development-mode get development-mode get
[ http-error. ] [ drop "Response error" throw ] if [ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output ] with-encoded-output
] recover ] recover
] if ] if
@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
: dispatch-request ( request -- response ) : dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ; 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 ) : do-request ( request -- response )
'[ '[
, ,
[ init-request ] {
[ log-request ] [ init-request ]
[ dispatch-request ] tri [ prepare-request ]
[ log-request ]
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
} cleave
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- ) : ?refresh-all ( -- )

View File

@ -15,7 +15,7 @@ IN: io.files.unique
[ 10 random CHAR: 0 + ] [ random-letter ] if ; [ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string ) : random-name ( n -- string )
[ drop random-ch ] "" map-as ; [ random-ch ] "" replicate-as ;
: unique-length ( -- n ) 10 ; inline : unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline : unique-retries ( -- n ) 10 ; inline

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex 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 destructors math concurrency.combinators accessors
arrays continuations quotations ; arrays continuations quotations ;
IN: io.pipes IN: io.pipes

View File

@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
dup check-disposed dup check-disposed
dup expired>> expired? [ dup expired>> expired? [
ALIEN: 31337 >>expired ALIEN: 31337 >>expired
connections>> [ delete-all ] [ dispose-each ] bi connections>> delete-all
] [ drop ] if ; ] [ drop ] if ;
: <pool> ( class -- pool ) : <pool> ( class -- pool )
@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
dup check-pool [ make-connection ] keep return-connection ; dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn ) : acquire-connection ( pool -- conn )
dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while [ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ; connections>> pop ;

View File

@ -2,6 +2,6 @@ IN: io.server.tests
USING: tools.test io.server io.server.private kernel ; USING: tools.test io.server io.server.private kernel ;
{ 2 0 } [ [ ] server-loop ] must-infer-as { 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 { 1 0 } [ [ ] swap datagram-loop ] must-infer-as
{ 2 0 } [ [ ] with-datagrams ] must-infer-as { 2 0 } [ [ ] with-datagrams ] must-infer-as

View File

@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators debugger quotations calendar threads concurrency.combinators
assocs fry ; assocs fry accessors ;
IN: io.server IN: io.server
SYMBOL: servers SYMBOL: servers
@ -15,9 +15,10 @@ SYMBOL: remote-address
LOG: accepted-connection NOTICE LOG: accepted-connection NOTICE
: with-connection ( client remote quot -- ) : with-connection ( client remote local quot -- )
'[ '[
, [ remote-address set ] [ accepted-connection ] bi , [ remote-address set ] [ accepted-connection ] bi
, local-address set
@ @
] with-stream ; inline ] with-stream ; inline
@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
: accept-loop ( server quot -- ) : 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 ] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- ) : server-loop ( addrspec encoding quot -- )
@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- ) : 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 pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline ] 2keep datagram-loop ; inline

View File

@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener
accessors delegate delegate.protocols ; accessors delegate delegate.protocols ;
IN: io.streams.duplex 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 ; TUPLE: duplex-stream in out ;
C: <duplex-stream> duplex-stream C: <duplex-stream> duplex-stream

View File

@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ;
GENERIC: add-input-callback ( thread fd mx -- ) GENERIC: add-input-callback ( thread fd mx -- )
: add-callback ( thread fd assoc -- ) M: mx add-input-callback reads>> push-at ;
[ ?push ] change-at ;
M: mx add-input-callback reads>> add-callback ;
GENERIC: add-output-callback ( thread fd mx -- ) 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 ) GENERIC: remove-input-callbacks ( fd mx -- callbacks )

View File

@ -142,7 +142,7 @@ DEFER: (d)
! Computing a basis ! Computing a basis
: graded ( seq -- seq ) : 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 ; [ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt ) : nth-basis-elt ( generators n -- elt )

View File

@ -2,6 +2,10 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ; USING: tools.test lcs ;
\ lcs must-infer
\ diff must-infer
\ levenshtein must-infer
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test

View File

@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ;
[ 1- ] change-i [ 1- ] change-j ; [ 1- ] change-i [ 1- ] change-j ;
: inserted? ( state -- ? ) : inserted? ( state -- ? )
[ j>> 0 > ] {
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ; [ j>> 0 > ]
[ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
} 1&& ;
: do-insert ( state -- state ) : do-insert ( state -- state )
dup new-nth insert boa , [ 1- ] change-j ; dup new-nth insert boa , [ 1- ] change-j ;
: deleted? ( state -- ? ) : 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 ) : do-delete ( state -- state )
dup old-nth delete boa , [ 1- ] change-i ; dup old-nth delete boa , [ 1- ] change-i ;

View File

@ -17,9 +17,6 @@ IN: project-euler.150
: partial-sum-infimum ( seq -- seq ) : partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline 0 0 rot [ (partial-sum-infimum) ] each drop ; inline
: generate ( n quot -- seq )
[ drop ] prepose map ; inline
: map-infimum ( seq quot -- min ) : map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline [ min ] compose 0 swap reduce ; inline
@ -30,7 +27,7 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq ) : sums-triangle ( -- seq )
0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE> PRIVATE>

View File

@ -131,10 +131,6 @@ MACRO: firstn ( n -- )
[ find drop [ head-slice ] when* ] curry [ find drop [ head-slice ] when* ] curry
[ dup ] prepose keep like ; [ dup ] prepose keep like ;
: replicate ( seq quot -- newseq )
#! quot: ( -- obj )
[ drop ] prepose map ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE <PRIVATE
@ -244,20 +240,6 @@ PRIVATE>
: short ( seq n -- seq n' ) : short ( seq n -- seq n' )
over length min ; inline over length min ; inline
<PRIVATE
:: insert ( seq quot n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
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 -- ) : if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline [ f like ] 2dip if* ; inline

View File

@ -0,0 +1 @@
Daniel Ehrenberg

View File

@ -0,0 +1,16 @@
USING: locals sequences kernel math ;
IN: sorting.insertion
<PRIVATE
:: insert ( seq quot n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
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

View File

@ -0,0 +1 @@
Insertion sort

View File

@ -0,0 +1 @@
collections

View File

@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str )
] if next ; ] if next ;
: expect-string ( string -- ) : expect-string ( string -- )
dup [ drop get-char next ] map 2dup = dup [ get-char next ] replicate 2dup =
[ 2drop ] [ expected ] if ; [ 2drop ] [ expected ] if ;
: init-parser ( -- ) : init-parser ( -- )

View File

@ -5,4 +5,4 @@ IN: temporary
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test [ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-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

View File

@ -30,5 +30,4 @@ IN: strings.lib
alphanumeric-chars random ; alphanumeric-chars random ;
: random-alphanumeric-string ( length -- str ) : random-alphanumeric-string ( length -- str )
[ drop random-alphanumeric-char ] map "" like ; [ random-alphanumeric-char ] "" replicate-as ;

View File

@ -8,7 +8,7 @@ IN: ui.gadgets.frames
! gadgets gets left-over space. ! gadgets gets left-over space.
TUPLE: frame ; TUPLE: frame ;
: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ; : <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ; : @center 1 1 ;
: @left 0 1 ; : @left 0 1 ;

View File

@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
CATEGORY: (extend) Me Mn ; CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? ) : extend? ( ch -- ? )
[ (extend)? ] { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
[ "Other_Grapheme_Extend" property? ] or? ;
: grapheme-class ( ch -- class ) : grapheme-class ( ch -- class )
{ {
@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ;
} cond ; } cond ;
: init-grapheme-table ( -- table ) : init-grapheme-table ( -- table )
graphemes [ drop graphemes f <array> ] map ; graphemes [ graphemes f <array> ] replicate ;
SYMBOL: table SYMBOL: table

View File

@ -58,8 +58,7 @@ ducet insert-helpers
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ; HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
: illegal? ( char -- ? ) : illegal? ( char -- ? )
[ "Noncharacter_Code_Point" property? ] { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
[ category "Cs" = ] or? ;
: derive-weight ( char -- weights ) : derive-weight ( char -- weights )
first dup illegal? first dup illegal?

View File

@ -1,7 +1,7 @@
USING: assocs math kernel sequences io.files hashtables USING: assocs math kernel sequences io.files hashtables
quotations splitting grouping arrays math.parser hash2 math.order quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser 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 ; combinators.lib combinators locals math.ranges sorting ;
IN: unicode.data IN: unicode.data
@ -62,7 +62,7 @@ VALUE: properties
dup [ swap (chain-decomposed) ] curry assoc-map ; dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? ) : first* ( seq -- ? )
second [ empty? ] [ first ] or? ; second { [ empty? ] [ first ] } 1|| ;
: (process-decomposed) ( data -- alist ) : (process-decomposed) ( data -- alist )
5 swap (process-data) 5 swap (process-data)
@ -107,7 +107,7 @@ VALUE: properties
:: fill-ranges ( table -- table ) :: fill-ranges ( table -- table )
name-map >alist sort-values keys name-map >alist sort-values keys
[ [ "first>" tail? ] [ "last>" tail? ] or? ] filter [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [ 2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each [ swap table ?set-nth ] curry each
@ -151,7 +151,7 @@ C: <code-point> code-point
: properties>intervals ( properties -- assoc[str,interval] ) : properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc dup values prune [ f ] H{ } map>assoc
[ [ insert-at ] curry assoc-each ] keep [ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ; [ <interval-set> ] assoc-map ;
: load-properties ( -- assoc ) : load-properties ( -- assoc )

View File

@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays 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 IN: unicode.normalize
! Conjoining Jamo behavior ! Conjoining Jamo behavior

View File

@ -1,24 +1,33 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser USING: kernel accessors sequences sorting math.order math.parser
urls validators html.components db.types db.tuples calendar urls validators html.components db db.types db.tuples calendar
http.server.dispatchers present http.server.dispatchers
furnace furnace.actions furnace.auth.login furnace.boilerplate furnace
furnace.sessions furnace.syndication ; furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate
furnace.sessions
furnace.syndication ;
IN: webapps.blogs IN: webapps.blogs
TUPLE: blogs < dispatcher ; TUPLE: blogs < dispatcher ;
SYMBOL: can-administer-blogs?
can-administer-blogs? define-capability
: view-post-url ( id -- url ) : view-post-url ( id -- url )
number>string "$blogs/post/" prepend >url ; present "$blogs/post/" prepend >url ;
: view-comment-url ( parent id -- url ) : view-comment-url ( parent id -- url )
[ view-post-url ] dip >>anchor ; [ view-post-url ] dip >>anchor ;
: list-posts-url ( -- url ) : list-posts-url ( -- url )
URL" $blogs/" ; "$blogs/" >url ;
: user-posts-url ( author -- url ) : posts-by-url ( author -- url )
"$blogs/by/" prepend >url ; "$blogs/by/" prepend >url ;
TUPLE: entity id author date content ; TUPLE: entity id author date content ;
@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ;
TUPLE: post < entity title comments ; TUPLE: post < entity title comments ;
M: post feed-entry-title M: post feed-entry-title
[ author>> ] [ drop ": " ] [ title>> ] tri 3append ; [ author>> ] [ title>> ] bi ": " swap 3append ;
M: post entity-url M: post entity-url
id>> view-post-url ; id>> view-post-url ;
@ -79,19 +88,16 @@ M: comment entity-url
[ [ date>> ] compare invert-comparison ] sort ; [ [ date>> ] compare invert-comparison ] sort ;
: validate-author ( -- ) : validate-author ( -- )
{ { "author" [ [ v-username ] v-optional ] } } validate-params ; { { "author" [ v-username ] } } validate-params ;
: list-posts ( -- posts ) : list-posts ( -- posts )
f <post> "author" value >>author f <post> "author" value >>author
select-tuples [ dup id>> f <comment> count-tuples >>comments ] map select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
reverse-chronological-order ; reverse-chronological-order ;
: <list-posts-action> ( -- action ) : <list-posts-action> ( -- action )
<page-action> <page-action>
[ [ list-posts "posts" set-value ] >>init
list-posts "posts" set-value
] >>init
{ blogs "list-posts" } >>template ; { blogs "list-posts" } >>template ;
: <list-posts-feed-action> ( -- action ) : <list-posts-feed-action> ( -- action )
@ -100,21 +106,24 @@ M: comment entity-url
[ list-posts ] >>entries [ list-posts ] >>entries
[ list-posts-url ] >>url ; [ list-posts-url ] >>url ;
: <user-posts-action> ( -- action ) : <posts-by-action> ( -- action )
<page-action> <page-action>
"author" >>rest "author" >>rest
[ [
validate-author validate-author
list-posts "posts" set-value list-posts "posts" set-value
] >>init ] >>init
{ blogs "user-posts" } >>template ;
: <user-posts-feed-action> ( -- action ) { blogs "posts-by" } >>template ;
: <posts-by-feed-action> ( -- action )
<feed-action> <feed-action>
[ validate-author ] >>init [ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title [ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries [ list-posts ] >>entries
[ "author" value user-posts-url ] >>url ; [ "author" value posts-by-url ] >>url ;
: <post-feed-action> ( -- action ) : <post-feed-action> ( -- action )
<feed-action> <feed-action>
@ -125,6 +134,7 @@ M: comment entity-url
: <view-post-action> ( -- action ) : <view-post-action> ( -- action )
<page-action> <page-action>
"id" >>rest "id" >>rest
[ [
@ -147,6 +157,7 @@ M: comment entity-url
: <new-post-action> ( -- action ) : <new-post-action> ( -- action )
<page-action> <page-action>
[ [
validate-post validate-post
uid "author" set-value uid "author" set-value
@ -160,38 +171,76 @@ M: comment entity-url
[ insert-tuple ] [ entity-url <redirect> ] bi [ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit ] >>submit
{ blogs "new-post" } >>template ; { blogs "new-post" } >>template
<protected>
"make a new blog post" >>description ;
: authorize-author ( author -- )
uid = can-administer-blogs? have-capability? or
[ login-required ] unless ;
: do-post-action ( -- )
validate-integer-id
"id" value <post> select-tuple from-object ;
: <edit-post-action> ( -- action ) : <edit-post-action> ( -- action )
<page-action> <page-action>
[
validate-integer-id "id" >>rest
"id" value <post> select-tuple from-object
] >>init [ do-post-action ] >>init
[ do-post-action validate-post ] >>validate
[ "author" value authorize-author ] >>authorize
[ [
validate-integer-id "id" value <post>
validate-post dup { "title" "author" "date" "content" } deposit-slots
] >>validate
[
"id" value <post> select-tuple
dup { "title" "content" } deposit-slots
[ update-tuple ] [ entity-url <redirect> ] bi [ update-tuple ] [ entity-url <redirect> ] bi
] >>submit ] >>submit
{ blogs "edit-post" } >>template ; { blogs "edit-post" } >>template
<protected>
"edit a blog post" >>description ;
: delete-post ( id -- )
[ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
: <delete-post-action> ( -- action ) : <delete-post-action> ( -- action )
<action> <action>
[ do-post-action ] >>validate
[ "author" value authorize-author ] >>authorize
[ [
validate-integer-id [ "id" value delete-post ] with-transaction
{ { "author" [ v-username ] } } validate-params "author" value posts-by-url <redirect>
] >>validate ] >>submit
<protected>
"delete a blog post" >>description ;
: <delete-author-action> ( -- action )
<action>
[ validate-author ] >>validate
[ "author" value authorize-author ] >>authorize
[ [
"id" value <post> delete-tuples [
"author" value user-posts-url <redirect> f <post> "author" value >>author select-tuples [ id>> delete-post ] each
] >>submit ; f f <comment> "author" value >>author delete-tuples
] with-transaction
"author" value posts-by-url <redirect>
] >>submit
<protected>
"delete a blog post" >>description ;
: validate-comment ( -- ) : validate-comment ( -- )
{ {
@ -213,41 +262,44 @@ M: comment entity-url
uid >>author uid >>author
now >>date now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi [ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit ; ] >>submit
<protected>
"make a comment" >>description ;
: <delete-comment-action> ( -- action ) : <delete-comment-action> ( -- action )
<action> <action>
[ [
validate-integer-id validate-integer-id
{ { "parent" [ v-integer ] } } validate-params { { "parent" [ v-integer ] } } validate-params
] >>validate ] >>validate
[
"parent" value <post> select-tuple
author>> authorize-author
] >>authorize
[ [
f "id" value <comment> delete-tuples f "id" value <comment> delete-tuples
"parent" value view-post-url <redirect> "parent" value view-post-url <redirect>
] >>submit ; ] >>submit
<protected>
"delete a comment" >>description ;
: <blogs> ( -- dispatcher ) : <blogs> ( -- dispatcher )
blogs new-dispatcher blogs new-dispatcher
<list-posts-action> "" add-responder <list-posts-action> "" add-responder
<list-posts-feed-action> "posts.atom" add-responder <list-posts-feed-action> "posts.atom" add-responder
<user-posts-action> "by" add-responder <posts-by-action> "by" add-responder
<user-posts-feed-action> "by.atom" add-responder <posts-by-feed-action> "by.atom" add-responder
<view-post-action> "post" add-responder <view-post-action> "post" add-responder
<post-feed-action> "post.atom" add-responder <post-feed-action> "post.atom" add-responder
<new-post-action> <protected> <new-post-action> "new-post" add-responder
"make a new blog post" >>description <edit-post-action> "edit-post" add-responder
"new-post" add-responder <delete-post-action> "delete-post" add-responder
<edit-post-action> <protected> <new-comment-action> "new-comment" add-responder
"edit a blog post" >>description <delete-comment-action> "delete-comment" add-responder
"edit-post" add-responder
<delete-post-action> <protected>
"delete a blog post" >>description
"delete-post" add-responder
<new-comment-action> <protected>
"make a comment" >>description
"new-comment" add-responder
<delete-comment-action> <protected>
"delete a comment" >>description
"delete-comment" add-responder
<boilerplate> <boilerplate>
{ blogs "blogs-common" } >>template ; { blogs "blogs-common" } >>template ;

View File

@ -15,13 +15,13 @@
<div class="posting-footer"> <div class="posting-footer">
Post by Post by
<t:a t:href="$blogs/" t:query="author"> <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" /> <t:label t:name="author" />
</t:a> </t:a>
on on
<t:label t:name="date" /> <t:label t:name="date" />
| |
<t:a t:href="$blogs/post" t:for="id">View Post</t:a> <t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
| |
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button> <t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div> </div>

View File

@ -7,7 +7,7 @@
<t:bind-each t:name="posts"> <t:bind-each t:name="posts">
<h2 class="post-title"> <h2 class="post-title">
<t:a t:href="$blogs/post" t:query="id"> <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" /> <t:label t:name="title" />
</t:a> </t:a>
</h2> </h2>
@ -18,13 +18,13 @@
<div class="posting-footer"> <div class="posting-footer">
Post by Post by
<t:a t:href="$blogs/by" t:query="author"> <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" /> <t:label t:name="author" />
</t:a> </t:a>
on on
<t:label t:name="date" /> <t:label t:name="date" />
| |
<t:a t:href="$blogs/post" t:query="id"> <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" /> <t:label t:name="comments" />
comments. comments.
</t:a> </t:a>

View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$blogs/by" t:query="author"> <t:atom t:href="$blogs/by" t:rest="author">
Recent Posts by <t:label t:name="author" /> Recent Posts by <t:label t:name="author" />
</t:atom> </t:atom>
@ -13,7 +13,7 @@
<t:bind-each t:name="posts"> <t:bind-each t:name="posts">
<h2 class="post-title"> <h2 class="post-title">
<t:a t:href="$blogs/post" t:query="id"> <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" /> <t:label t:name="title" />
</t:a> </t:a>
</h2> </h2>
@ -24,13 +24,13 @@
<div class="posting-footer"> <div class="posting-footer">
Post by Post by
<t:a t:href="$blogs/by" t:query="author"> <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" /> <t:label t:name="author" />
</t:a> </t:a>
on on
<t:label t:name="date" /> <t:label t:name="date" />
| |
<t:a t:href="$blogs/post" t:query="id"> <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" /> <t:label t:name="comments" />
comments. comments.
</t:a> </t:a>

View File

@ -2,11 +2,11 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$blogs/post.atom" t:query="id"> <t:atom t:href="$blogs/post.atom" t:rest="id">
<t:label t:name="author" />: <t:label t:name="title" /> <t:label t:name="author" />: <t:label t:name="title" />
</t:atom> </t:atom>
<t:atom t:href="$blogs/by.atom" t:query="author"> <t:atom t:href="$blogs/by.atom" t:rest="author">
Recent Posts by <t:label t:name="author" /> Recent Posts by <t:label t:name="author" />
</t:atom> </t:atom>
@ -18,13 +18,13 @@
<div class="posting-footer"> <div class="posting-footer">
Post by Post by
<t:a t:href="$blogs/" t:query="author"> <t:a t:href="$blogs/" t:rest="author">
<t:label t:name="author" /> <t:label t:name="author" />
</t:a> </t:a>
on on
<t:label t:name="date" /> <t:label t:name="date" />
| |
<t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a> <t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
| |
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button> <t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div> </div>
@ -33,7 +33,7 @@
<hr/> <hr/>
<p class="comment-header"> <p class="comment-header">
Comment by <t:label t:name="author" /> on <t:label t:name="date" />: <a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
</p> </p>
<p class="posting-body"> <p class="posting-body">

View File

@ -19,6 +19,10 @@ IN: webapps.pastebin
TUPLE: pastebin < dispatcher ; TUPLE: pastebin < dispatcher ;
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
! ! ! ! ! !
! DOMAIN MODEL ! DOMAIN MODEL
! ! ! ! ! !
@ -170,13 +174,20 @@ M: annotation entity-url
: <delete-paste-action> ( -- action ) : <delete-paste-action> ( -- action )
<action> <action>
[ validate-integer-id ] >>validate [ validate-integer-id ] >>validate
[ [
"id" value <paste> delete-tuples [
"id" value f <annotation> delete-tuples "id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
] with-transaction
URL" $pastebin/list" <redirect> URL" $pastebin/list" <redirect>
] >>submit ; ] >>submit
<protected>
"delete pastes" >>description
{ can-delete-pastes? } >>capabilities ;
! ! ! ! ! !
! ANNOTATIONS ! ANNOTATIONS
@ -199,6 +210,7 @@ M: annotation entity-url
: <delete-annotation-action> ( -- action ) : <delete-annotation-action> ( -- action )
<action> <action>
[ { { "id" [ v-number ] } } validate-params ] >>validate [ { { "id" [ v-number ] } } validate-params ] >>validate
[ [
@ -206,11 +218,11 @@ M: annotation entity-url
[ delete-tuples ] [ delete-tuples ]
[ parent>> paste-url <redirect> ] [ parent>> paste-url <redirect> ]
bi bi
] >>submit ; ] >>submit
SYMBOL: can-delete-pastes? <protected>
"delete annotations" >>description
can-delete-pastes? define-capability { can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder ) : <pastebin> ( -- responder )
pastebin new-dispatcher pastebin new-dispatcher
@ -219,13 +231,9 @@ can-delete-pastes? define-capability
<paste-action> "paste" add-responder <paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder <paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder <new-paste-action> "new-paste" add-responder
<delete-paste-action> <protected> <delete-paste-action> "delete-paste" add-responder
"delete pastes" >>description
{ can-delete-pastes? } >>capabilities "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder <new-annotation-action> "new-annotation" add-responder
<delete-annotation-action> <protected> <delete-annotation-action> "delete-annotation" add-responder
"delete annotations" >>description
{ can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<boilerplate> <boilerplate>
{ pastebin "pastebin-common" } >>template ; { pastebin "pastebin-common" } >>template ;

View File

@ -18,6 +18,10 @@ IN: webapps.planet
TUPLE: planet-factor < dispatcher ; TUPLE: planet-factor < dispatcher ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
TUPLE: planet-factor-admin < dispatcher ; TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ; TUPLE: blog id name www-url feed-url ;
@ -30,8 +34,8 @@ blog "BLOGS"
{ {
{ "id" "ID" INTEGER +db-assigned-id+ } { "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ } { "name" "NAME" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ } { "www-url" "WWWURL" URL +not-null+ }
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } { "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent } define-persistent
TUPLE: posting < entry id ; TUPLE: posting < entry id ;
@ -40,7 +44,7 @@ posting "POSTINGS"
{ {
{ "id" "ID" INTEGER +db-assigned-id+ } { "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ } { "title" "TITLE" { VARCHAR 256 } +not-null+ }
{ "url" "LINK" { VARCHAR 256 } +not-null+ } { "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ } { "description" "DESCRIPTION" TEXT +not-null+ }
{ "date" "DATE" TIMESTAMP +not-null+ } { "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent } define-persistent
@ -134,6 +138,7 @@ posting "POSTINGS"
: <new-blog-action> ( -- action ) : <new-blog-action> ( -- action )
<page-action> <page-action>
{ planet-factor "new-blog" } >>template { planet-factor "new-blog" } >>template
[ validate-blog ] >>validate [ validate-blog ] >>validate
@ -150,9 +155,10 @@ posting "POSTINGS"
] ]
tri tri
] >>submit ; ] >>submit ;
: <edit-blog-action> ( -- action ) : <edit-blog-action> ( -- action )
<page-action> <page-action>
[ [
validate-integer-id validate-integer-id
"id" value <blog> select-tuple from-object "id" value <blog> select-tuple from-object
@ -184,20 +190,16 @@ posting "POSTINGS"
<update-action> "update" add-responder <update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder <new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder <edit-blog-action> "edit-blog" add-responder
<delete-blog-action> "delete-blog" add-responder ; <delete-blog-action> "delete-blog" add-responder
<protected>
SYMBOL: can-administer-planet-factor? "administer Planet Factor" >>description
{ can-administer-planet-factor? } >>capabilities ;
can-administer-planet-factor? define-capability
: <planet-factor> ( -- responder ) : <planet-factor> ( -- responder )
planet-factor new-dispatcher planet-factor new-dispatcher
<planet-action> "list" add-main-responder <planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder <planet-feed-action> "feed.xml" add-responder
<planet-factor-admin> <protected> <planet-factor-admin> "admin" add-responder
"administer Planet Factor" >>description
{ can-administer-planet-factor? } >>capabilities
"admin" add-responder
<boilerplate> <boilerplate>
{ planet-factor "planet-common" } >>template ; { planet-factor "planet-common" } >>template ;

View File

@ -26,7 +26,7 @@ short-url "SHORT_URLS" {
3append ; foldable 3append ; foldable
: random-url ( -- string ) : 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 ) : insert-short-url ( short-url -- short-url )
'[ , dup random-url >>short insert-tuple ] 10 retry ; '[ , dup random-url >>short insert-tuple ] 10 retry ;

View File

@ -7,7 +7,7 @@
<ul> <ul>
<t:bind-each t:name="articles"> <t:bind-each t:name="articles">
<li> <li>
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a> <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
</li> </li>
</t:bind-each> </t:bind-each>
</ul> </ul>

View File

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

View File

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

View File

@ -2,16 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$wiki/revisions.atom" t:query="title"> <t:atom t:href="$wiki/revisions.atom" t:rest="title">
Revisions of <t:label t:name="title" /> Revisions of <t:label t:name="title" />
</t:atom> </t:atom>
<t:call-next-template /> <t:call-next-template />
<div class="navbar"> <div class="navbar">
<t:a t:href="$wiki/view" t:query="title">Latest</t:a> <t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a> | <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a> | <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button> | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div> </div>

View File

@ -8,14 +8,14 @@
<table> <table>
<tr> <tr>
<th>Revision</th> <th>Revision</th>
<th>Author</th> <th>By</th>
<th>Rollback</th> <th>Rollback</th>
</tr> </tr>
<t:bind-each t:name="revisions"> <t:bind-each t:name="revisions">
<tr> <tr>
<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td> <td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td> <td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td> <td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr> </tr>
</t:bind-each> </t:bind-each>
@ -24,7 +24,7 @@
<h2>View Differences</h2> <h2>View Differences</h2>
<form action="diff" method="get"> <t:form t:action="$wiki/diff" t:method="get">
<table> <table>
<tr> <tr>
<th class="field-label">Old revision:</th> <th class="field-label">Old revision:</th>
@ -51,6 +51,6 @@
</table> </table>
<input type="submit" value="View" /> <input type="submit" value="View" />
</form> </t:form>
</t:chloe> </t:chloe>

View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:atom t:href="$wiki/user-edits.atom" t:query="author"> <t:atom t:href="$wiki/user-edits.atom" t:rest="author">
Edits by <t:label t:name="author" /> Edits by <t:label t:name="author" />
</t:atom> </t:atom>
@ -11,9 +11,9 @@
<ul> <ul>
<t:bind-each t:name="user-edits"> <t:bind-each t:name="user-edits">
<li> <li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a> <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li> </li>
</t:bind-each> </t:bind-each>
</ul> </ul>

View File

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

View File

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

8
extra/windows/com/com.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types windows.com.syntax windows.ole32 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 IN: windows.com
LIBRARY: ole32 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 ) ; HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
: com-query-interface ( interface iid -- interface' ) : com-query-interface ( interface iid -- interface' )
f <void*> "void*" heap-size [
[ IUnknown::QueryInterface ole32-error ] keep [ IUnknown::QueryInterface ole32-error ] keep *void*
*void* ; ] with-malloc ;
: com-add-ref ( interface -- interface ) : com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline [ IUnknown::AddRef drop ] keep ; inline

View File

@ -1,11 +1,12 @@
USING: alien alien.c-types windows.com.syntax USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel 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 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 IN: windows.com.wrapper
TUPLE: com-wrapper vtbls freed? ; TUPLE: com-wrapper vtbls disposed ;
<PRIVATE <PRIVATE
@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
[ H{ } +wrapped-objects+ set-global ] [ H{ } +wrapped-objects+ set-global ]
unless unless
SYMBOL: +vtbl-counter+
+vtbl-counter+ get-global
[ 0 +vtbl-counter+ set-global ]
unless
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
+vtbl-counter+ [ 1+ dup ] change ;
: com-unwrap ( wrapped -- object ) : com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at* +wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ; [ "invalid COM wrapping pointer" throw ] unless ;
@ -22,34 +33,38 @@ unless
[ +wrapped-objects+ get-global delete-at ] keep [ +wrapped-objects+ get-global delete-at ] keep
free ; free ;
: (make-query-interface) ( interfaces -- quot ) : (query-interface-cases) ( interfaces -- cases )
[ [
[ swap 16 memory>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 "void*" heap-size * rot <displaced-alien> com-add-ref
r> 1quotation [ >r iid>> r> 2array ] curry map 0 rot set-void*-nth S_OK
] map-index concat ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
[ drop f ] suffix , ] ;
\ case ,
"void*" heap-size
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
curry ,
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
\ if* ,
] [ ] make ;
: (make-add-ref) ( interfaces -- quot ) : (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * [ swap <displaced-alien> length "void*" heap-size * '[
, swap <displaced-alien>
0 over ulong-nth 0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep 1+ [ 0 rot set-ulong-nth ] keep
] curry ; ] ;
: (make-release) ( interfaces -- quot ) : (make-release) ( interfaces -- quot )
length "void*" heap-size * [ over <displaced-alien> length "void*" heap-size * '[
, over <displaced-alien>
0 over ulong-nth 0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep 1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if dup zero? [ swap (free-wrapped-object) ] [ nip ] if
] curry ; ] ;
: (make-iunknown-methods) ( interfaces -- quots ) : (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ] [ (make-query-interface) ]
@ -60,32 +75,48 @@ unless
: (thunk) ( n -- quot ) : (thunk) ( n -- quot )
dup 0 = dup 0 =
[ drop [ ] ] [ drop [ ] ]
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ] [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
if ; if ;
: (thunked-quots) ( quots iunknown-methods thunk -- quots' ) : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
[ [ swap 2array ] curry map swap ] keep [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
[ com-unwrap ] compose [ swap 2array ] curry map append ; [ '[ , [ 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 [ alien-callback ] 4 ncurry
[ gensym [ swap (( -- alien )) define-declared ] keep ] [ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit with-compilation-unit
execute ; 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) (thunk) (thunked-quots)
swap find-com-interface-definition family-tree-functions [ swap [ find-com-interface-definition family-tree-functions ]
[ return>> ] [ parameters>> [ first ] map ] bi keep (next-vtbl-counter) '[
dup length 1- roll [ swap [
first dup empty? [ name>> , , (callback-word) ]
[ 2drop [ ] ] [ return>> ] [
[ swap [ ndip ] 2curry ] parameters>>
if [ [ first ] map ]
] [ second ] bi compose [ length ] bi
] tri
] [
first2 (finish-thunk)
] bi*
"stdcall" swap compile-alien-callback "stdcall" swap compile-alien-callback
] 2map >c-void*-array [ byte-length malloc ] keep ] 2map >c-void*-array
over byte-array>memory ; (byte-array-to-malloced-buffer) ;
: (make-vtbls) ( implementations -- vtbls ) : (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods) dup [ first ] map (make-iunknown-methods)
@ -102,11 +133,10 @@ PRIVATE>
: <com-wrapper> ( implementations -- wrapper ) : <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ; (make-vtbls) f com-wrapper boa ;
M: com-wrapper dispose M: com-wrapper dispose*
t >>freed?
vtbls>> [ free ] each ; vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object ) : 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 [ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ; [ +wrapped-objects+ get-global set-at ] keep ;

View File

@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset )
rule-set-imports push ; rule-set-imports push ;
: inverted-index ( hashes key index -- ) : inverted-index ( hashes key index -- )
[ swapd [ ?push ] change-at ] 2curry each ; [ swapd push-at ] 2curry each ;
: ?push-all ( seq1 seq2 -- seq1+seq2 ) : ?push-all ( seq1 seq2 -- seq1+seq2 )
[ [