Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
300971447e
|
|
@ -10,3 +10,5 @@ IN: grouping.tests
|
|||
2 over set-length
|
||||
>array
|
||||
] unit-test
|
||||
|
||||
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ M: clumps set-length
|
|||
M: clumps group@
|
||||
[ n>> over + ] [ seq>> ] bi ;
|
||||
|
||||
TUPLE: sliced-clumps < groups ;
|
||||
TUPLE: sliced-clumps < clumps ;
|
||||
|
||||
: <sliced-clumps> ( seq n -- clumps )
|
||||
sliced-clumps new-groups ; inline
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -39,18 +39,13 @@ IN: dns.server
|
|||
zones sort-largest-first [ name-in-domain? ] with find nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! fill-authority
|
||||
! name->authority
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fill-authority ( message -- message )
|
||||
[ ]
|
||||
[ message-query name>> name->zone NS IN query boa matching-rrs ]
|
||||
[ answer-section>> ]
|
||||
tri
|
||||
diff >>authority-section ;
|
||||
: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! fill-additional
|
||||
! extract-names
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->rdata-names ( rr -- names/f )
|
||||
|
|
@ -61,12 +56,33 @@ IN: dns.server
|
|||
}
|
||||
cond ;
|
||||
|
||||
: extract-rdata-names ( message -- names )
|
||||
[ answer-section>> ] [ authority-section>> ] bi append
|
||||
[ rr->rdata-names ] map concat ;
|
||||
|
||||
: extract-names ( message -- names )
|
||||
[ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! fill-authority
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fill-authority ( message -- message )
|
||||
dup
|
||||
extract-names [ name->authority ] map concat prune
|
||||
over answer-section>> diff
|
||||
>>authority-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! fill-additional
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
|
||||
|
||||
: fill-additional ( message -- message )
|
||||
dup
|
||||
[ answer-section>> ] [ authority-section>> ] bi append
|
||||
[ rr->rdata-names ] map concat
|
||||
[ A IN query boa matching-rrs ] map concat prune
|
||||
over answer-section>> diff
|
||||
extract-rdata-names [ name->rrs-a ] map concat prune
|
||||
over answer-section>> diff
|
||||
>>additional-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -90,10 +106,6 @@ DEFER: query->rrs
|
|||
! have-answers
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : have-answers ( message -- message/f )
|
||||
! dup message-query query->rrs ! message rrs/f
|
||||
! [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
|
||||
|
||||
: have-answers ( message -- message/f )
|
||||
dup message-query query->rrs
|
||||
[ empty? ]
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
|
|||
|
||||
TUPLE: protected < filter-responder description capabilities ;
|
||||
|
||||
: <protected> ( 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 } ;
|
||||
|
||||
: <login-action> ( -- action )
|
||||
<page-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
|
||||
|
||||
<protected>
|
||||
"edit your profile" >>description ;
|
||||
|
||||
! ! ! Password recovery
|
||||
|
||||
|
|
@ -316,32 +327,36 @@ SYMBOL: lost-password-from
|
|||
] >>submit ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
: <protected> ( responder -- protected )
|
||||
protected new
|
||||
swap >>responder ;
|
||||
|
||||
: show-login-page ( -- response )
|
||||
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 -- ? )
|
||||
[ 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 ;
|
||||
|
||||
: <login-boilerplate> ( responder -- responder' )
|
||||
|
|
@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
|
|||
! ! ! Configuration
|
||||
|
||||
: allow-edit-profile ( login -- login )
|
||||
<edit-profile-action> <protected>
|
||||
"edit your profile" >>description
|
||||
<login-boilerplate>
|
||||
"edit-profile" add-responder ;
|
||||
<edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> <login-boilerplate>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<url>
|
||||
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 ] [
|
||||
<url>
|
||||
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 -- )
|
||||
[
|
||||
<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 ;
|
||||
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
|
||||
|
||||
CHLOE: a
|
||||
[ a-start-tag ]
|
||||
|
|
@ -158,11 +153,12 @@ CHLOE: a
|
|||
[
|
||||
[
|
||||
<form
|
||||
"POST" =method
|
||||
[ link-attrs ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ tag-attrs non-chloe-attrs-only print-attrs ]
|
||||
tri
|
||||
{
|
||||
[ link-attrs ]
|
||||
[ "method" optional-attr "post" or =method ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ tag-attrs non-chloe-attrs-only print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
]
|
||||
[ form-magic ] bi
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<url>
|
||||
"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 )
|
||||
<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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> <trivial-responder> 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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <pool> ( 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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> duplex-stream
|
||||
|
|
|
|||
|
|
@ -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 <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 ;
|
||||
|
||||
: <list-posts-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
list-posts "posts" set-value
|
||||
] >>init
|
||||
|
||||
[ list-posts "posts" set-value ] >>init
|
||||
{ blogs "list-posts" } >>template ;
|
||||
|
||||
: <list-posts-feed-action> ( -- action )
|
||||
|
|
@ -100,21 +106,24 @@ M: comment entity-url
|
|||
[ list-posts ] >>entries
|
||||
[ list-posts-url ] >>url ;
|
||||
|
||||
: <user-posts-action> ( -- action )
|
||||
: <posts-by-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"author" >>rest
|
||||
|
||||
[
|
||||
validate-author
|
||||
list-posts "posts" set-value
|
||||
] >>init
|
||||
{ blogs "user-posts" } >>template ;
|
||||
|
||||
: <user-posts-feed-action> ( -- action )
|
||||
{ blogs "posts-by" } >>template ;
|
||||
|
||||
: <posts-by-feed-action> ( -- action )
|
||||
<feed-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 ;
|
||||
|
||||
: <post-feed-action> ( -- action )
|
||||
<feed-action>
|
||||
|
|
@ -125,6 +134,7 @@ M: comment entity-url
|
|||
|
||||
: <view-post-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"id" >>rest
|
||||
|
||||
[
|
||||
|
|
@ -147,6 +157,7 @@ M: comment entity-url
|
|||
|
||||
: <new-post-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
[
|
||||
validate-post
|
||||
uid "author" set-value
|
||||
|
|
@ -160,38 +171,76 @@ M: comment entity-url
|
|||
[ insert-tuple ] [ entity-url <redirect> ] bi
|
||||
] >>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 )
|
||||
<page-action>
|
||||
[
|
||||
validate-integer-id
|
||||
"id" value <post> 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 <post> select-tuple
|
||||
dup { "title" "content" } deposit-slots
|
||||
"id" value <post>
|
||||
dup { "title" "author" "date" "content" } deposit-slots
|
||||
[ update-tuple ] [ entity-url <redirect> ] bi
|
||||
] >>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 )
|
||||
<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 <redirect>
|
||||
] >>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>
|
||||
] >>submit ;
|
||||
[
|
||||
f <post> "author" value >>author select-tuples [ id>> delete-post ] each
|
||||
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 ( -- )
|
||||
{
|
||||
|
|
@ -213,41 +262,44 @@ M: comment entity-url
|
|||
uid >>author
|
||||
now >>date
|
||||
[ insert-tuple ] [ entity-url <redirect> ] bi
|
||||
] >>submit ;
|
||||
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"make a comment" >>description ;
|
||||
|
||||
: <delete-comment-action> ( -- action )
|
||||
<action>
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
{ { "parent" [ v-integer ] } } validate-params
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"parent" value <post> select-tuple
|
||||
author>> authorize-author
|
||||
] >>authorize
|
||||
|
||||
[
|
||||
f "id" value <comment> delete-tuples
|
||||
"parent" value view-post-url <redirect>
|
||||
] >>submit ;
|
||||
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"delete a comment" >>description ;
|
||||
|
||||
: <blogs> ( -- dispatcher )
|
||||
blogs new-dispatcher
|
||||
<list-posts-action> "" add-responder
|
||||
<list-posts-feed-action> "posts.atom" add-responder
|
||||
<user-posts-action> "by" add-responder
|
||||
<user-posts-feed-action> "by.atom" add-responder
|
||||
<posts-by-action> "by" add-responder
|
||||
<posts-by-feed-action> "by.atom" add-responder
|
||||
<view-post-action> "post" add-responder
|
||||
<post-feed-action> "post.atom" add-responder
|
||||
<new-post-action> <protected>
|
||||
"make a new blog post" >>description
|
||||
"new-post" add-responder
|
||||
<edit-post-action> <protected>
|
||||
"edit a blog post" >>description
|
||||
"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
|
||||
<new-post-action> "new-post" add-responder
|
||||
<edit-post-action> "edit-post" add-responder
|
||||
<delete-post-action> "delete-post" add-responder
|
||||
<new-comment-action> "new-comment" add-responder
|
||||
<delete-comment-action> "delete-comment" add-responder
|
||||
<boilerplate>
|
||||
{ blogs "blogs-common" } >>template ;
|
||||
|
|
|
|||
|
|
@ -15,13 +15,13 @@
|
|||
|
||||
<div class="posting-footer">
|
||||
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:a>
|
||||
on
|
||||
<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>
|
||||
</div>
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
<t:bind-each t:name="posts">
|
||||
|
||||
<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:a>
|
||||
</h2>
|
||||
|
|
@ -18,13 +18,13 @@
|
|||
|
||||
<div class="posting-footer">
|
||||
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:a>
|
||||
on
|
||||
<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" />
|
||||
comments.
|
||||
</t:a>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<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" />
|
||||
</t:atom>
|
||||
|
||||
|
|
@ -13,7 +13,7 @@
|
|||
<t:bind-each t:name="posts">
|
||||
|
||||
<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:a>
|
||||
</h2>
|
||||
|
|
@ -24,13 +24,13 @@
|
|||
|
||||
<div class="posting-footer">
|
||||
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:a>
|
||||
on
|
||||
<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" />
|
||||
comments.
|
||||
</t:a>
|
||||
|
|
@ -2,11 +2,11 @@
|
|||
|
||||
<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: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" />
|
||||
</t:atom>
|
||||
|
||||
|
|
@ -18,13 +18,13 @@
|
|||
|
||||
<div class="posting-footer">
|
||||
Post by
|
||||
<t:a t:href="$blogs/" t:query="author">
|
||||
<t:a t:href="$blogs/" t:rest="author">
|
||||
<t:label t:name="author" />
|
||||
</t:a>
|
||||
on
|
||||
<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>
|
||||
</div>
|
||||
|
|
@ -33,7 +33,7 @@
|
|||
<hr/>
|
||||
|
||||
<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 class="posting-body">
|
||||
|
|
|
|||
|
|
@ -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
|
|||
|
||||
: <delete-paste-action> ( -- action )
|
||||
<action>
|
||||
|
||||
[ 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>
|
||||
] >>submit ;
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"delete pastes" >>description
|
||||
{ can-delete-pastes? } >>capabilities ;
|
||||
|
||||
! ! !
|
||||
! ANNOTATIONS
|
||||
|
|
@ -199,6 +210,7 @@ M: annotation entity-url
|
|||
|
||||
: <delete-annotation-action> ( -- action )
|
||||
<action>
|
||||
|
||||
[ { { "id" [ v-number ] } } validate-params ] >>validate
|
||||
|
||||
[
|
||||
|
|
@ -206,11 +218,11 @@ M: annotation entity-url
|
|||
[ delete-tuples ]
|
||||
[ parent>> paste-url <redirect> ]
|
||||
bi
|
||||
] >>submit ;
|
||||
] >>submit
|
||||
|
||||
SYMBOL: can-delete-pastes?
|
||||
|
||||
can-delete-pastes? define-capability
|
||||
<protected>
|
||||
"delete annotations" >>description
|
||||
{ can-delete-pastes? } >>capabilities ;
|
||||
|
||||
: <pastebin> ( -- responder )
|
||||
pastebin new-dispatcher
|
||||
|
|
@ -219,13 +231,9 @@ can-delete-pastes? define-capability
|
|||
<paste-action> "paste" add-responder
|
||||
<paste-feed-action> "paste.atom" add-responder
|
||||
<new-paste-action> "new-paste" add-responder
|
||||
<delete-paste-action> <protected>
|
||||
"delete pastes" >>description
|
||||
{ can-delete-pastes? } >>capabilities "delete-paste" add-responder
|
||||
<delete-paste-action> "delete-paste" add-responder
|
||||
<new-annotation-action> "new-annotation" add-responder
|
||||
<delete-annotation-action> <protected>
|
||||
"delete annotations" >>description
|
||||
{ can-delete-pastes? } >>capabilities "delete-annotation" add-responder
|
||||
<delete-annotation-action> "delete-annotation" add-responder
|
||||
<boilerplate>
|
||||
{ pastebin "pastebin-common" } >>template ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
|||
|
||||
: <new-blog-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
{ planet-factor "new-blog" } >>template
|
||||
|
||||
[ validate-blog ] >>validate
|
||||
|
|
@ -150,9 +155,10 @@ posting "POSTINGS"
|
|||
]
|
||||
tri
|
||||
] >>submit ;
|
||||
|
||||
|
||||
: <edit-blog-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
"id" value <blog> select-tuple from-object
|
||||
|
|
@ -184,20 +190,16 @@ posting "POSTINGS"
|
|||
<update-action> "update" add-responder
|
||||
<new-blog-action> "new-blog" add-responder
|
||||
<edit-blog-action> "edit-blog" add-responder
|
||||
<delete-blog-action> "delete-blog" add-responder ;
|
||||
|
||||
SYMBOL: can-administer-planet-factor?
|
||||
|
||||
can-administer-planet-factor? define-capability
|
||||
<delete-blog-action> "delete-blog" add-responder
|
||||
<protected>
|
||||
"administer Planet Factor" >>description
|
||||
{ can-administer-planet-factor? } >>capabilities ;
|
||||
|
||||
: <planet-factor> ( -- responder )
|
||||
planet-factor new-dispatcher
|
||||
<planet-action> "list" add-main-responder
|
||||
<planet-feed-action> "feed.xml" add-responder
|
||||
<planet-factor-admin> <protected>
|
||||
"administer Planet Factor" >>description
|
||||
{ can-administer-planet-factor? } >>capabilities
|
||||
"admin" add-responder
|
||||
<planet-factor-admin> "admin" add-responder
|
||||
<boilerplate>
|
||||
{ planet-factor "planet-common" } >>template ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
<ul>
|
||||
<t:bind-each t:name="articles">
|
||||
<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>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
|
|
|
|||
|
|
@ -4,16 +4,26 @@
|
|||
|
||||
<t:title>Recent Changes</t:title>
|
||||
|
||||
<ul>
|
||||
<t:bind-each t:name="changes">
|
||||
<li>
|
||||
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
|
||||
on
|
||||
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
|
||||
by
|
||||
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
|
||||
</li>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
<div class="revisions">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th>Article</th>
|
||||
<th>Date</th>
|
||||
<th>By</th>
|
||||
</tr>
|
||||
|
||||
<t:bind-each t:name="changes">
|
||||
<tr>
|
||||
<td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
|
||||
<td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
|
||||
<td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
|
||||
</tr>
|
||||
</t:bind-each>
|
||||
|
||||
</table>
|
||||
|
||||
</div>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -8,13 +8,13 @@
|
|||
<tr>
|
||||
<th class="field-label">Old revision:</th>
|
||||
<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>
|
||||
</tr>
|
||||
<tr>
|
||||
<th class="field-label">New revision:</th>
|
||||
<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>
|
||||
</tr>
|
||||
</table>
|
||||
|
|
|
|||
|
|
@ -2,16 +2,16 @@
|
|||
|
||||
<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" />
|
||||
</t:atom>
|
||||
|
||||
<t:call-next-template />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
|
||||
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
|
||||
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
|
||||
<t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
|
||||
| <t:a t:href="$wiki/revisions" t:rest="title">Revisions</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>
|
||||
</div>
|
||||
|
||||
|
|
|
|||
|
|
@ -8,14 +8,14 @@
|
|||
<table>
|
||||
<tr>
|
||||
<th>Revision</th>
|
||||
<th>Author</th>
|
||||
<th>By</th>
|
||||
<th>Rollback</th>
|
||||
</tr>
|
||||
|
||||
<t:bind-each t:name="revisions">
|
||||
<tr>
|
||||
<td> <t:a t:href="revision" t:query="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/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
|
||||
<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
|
||||
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
|
||||
</tr>
|
||||
</t:bind-each>
|
||||
|
|
@ -24,7 +24,7 @@
|
|||
|
||||
<h2>View Differences</h2>
|
||||
|
||||
<form action="diff" method="get">
|
||||
<t:form t:action="$wiki/diff" t:method="get">
|
||||
<table>
|
||||
<tr>
|
||||
<th class="field-label">Old revision:</th>
|
||||
|
|
@ -51,6 +51,6 @@
|
|||
</table>
|
||||
|
||||
<input type="submit" value="View" />
|
||||
</form>
|
||||
</t:form>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<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" />
|
||||
</t:atom>
|
||||
|
||||
|
|
@ -11,9 +11,9 @@
|
|||
<ul>
|
||||
<t:bind-each t:name="user-edits">
|
||||
<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
|
||||
<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>
|
||||
</t:bind-each>
|
||||
</ul>
|
||||
|
|
|
|||
|
|
@ -8,6 +8,6 @@
|
|||
<t:farkup t:name="content" />
|
||||
</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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<url> 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 ;
|
|||
|
||||
: <view-article-action> ( -- action )
|
||||
<action>
|
||||
|
||||
"title" >>rest
|
||||
|
||||
[
|
||||
validate-title
|
||||
"view?title=" relative-link-prefix set
|
||||
] >>init
|
||||
|
||||
[
|
||||
|
|
@ -100,11 +103,14 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
: <view-revision-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"id" >>rest
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
"id" value <revision>
|
||||
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 ;
|
|||
|
||||
: <edit-article-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"title" >>rest
|
||||
|
||||
[
|
||||
validate-title
|
||||
"title" value <article> 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 <redirect> ] bi
|
||||
] >>submit ;
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"edit wiki articles" >>description ;
|
||||
|
||||
: list-revisions ( -- seq )
|
||||
f <revision> "title" value >>title select-tuples
|
||||
|
|
@ -148,21 +160,32 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
: <list-revisions-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"title" >>rest
|
||||
|
||||
[
|
||||
validate-title
|
||||
list-revisions "revisions" set-value
|
||||
] >>init
|
||||
|
||||
{ wiki "revisions" } >>template ;
|
||||
|
||||
: <list-revisions-feed-action> ( -- action )
|
||||
<feed-action>
|
||||
|
||||
"title" >>rest
|
||||
|
||||
[ validate-title ] >>init
|
||||
|
||||
[ "Revisions of " "title" value append ] >>title
|
||||
|
||||
[ "title" value revisions-url ] >>url
|
||||
|
||||
[ list-revisions ] >>entries ;
|
||||
|
||||
: <rollback-action> ( -- action )
|
||||
<action>
|
||||
|
||||
[ validate-integer-id ] >>validate
|
||||
|
||||
[
|
||||
|
|
@ -171,13 +194,12 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
] >>submit ;
|
||||
|
||||
: list-changes ( -- seq )
|
||||
"id" value <revision> select-tuples
|
||||
f <revision> select-tuples
|
||||
reverse-chronological-order ;
|
||||
|
||||
: <list-changes-action> ( -- action )
|
||||
<page-action>
|
||||
[ list-changes "changes" set-value ] >>init
|
||||
|
||||
{ wiki "changes" } >>template ;
|
||||
|
||||
: <list-changes-feed-action> ( -- action )
|
||||
|
|
@ -188,13 +210,18 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
: <delete-action> ( -- action )
|
||||
<action>
|
||||
|
||||
[ validate-title ] >>validate
|
||||
|
||||
[
|
||||
"title" value <article> delete-tuples
|
||||
f <revision> "title" value >>title delete-tuples
|
||||
URL" $wiki" <redirect>
|
||||
] >>submit ;
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"delete wiki articles" >>description
|
||||
{ can-delete-wiki-articles? } >>capabilities ;
|
||||
|
||||
: <diff-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -218,6 +245,7 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
: <list-articles-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
[
|
||||
f <article> select-tuples
|
||||
[ [ title>> ] compare ] sort
|
||||
|
|
@ -232,23 +260,24 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
: <user-edits-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
"author" >>rest
|
||||
|
||||
[
|
||||
validate-author
|
||||
list-user-edits "user-edits" set-value
|
||||
] >>init
|
||||
|
||||
{ wiki "user-edits" } >>template ;
|
||||
|
||||
: <user-edits-feed-action> ( -- action )
|
||||
<feed-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
|
||||
|
||||
: <article-boilerplate> ( responder -- responder' )
|
||||
<boilerplate>
|
||||
{ wiki "page-common" } >>template ;
|
||||
|
|
@ -261,18 +290,13 @@ can-delete-wiki-articles? define-capability
|
|||
<list-revisions-action> <article-boilerplate> "revisions" add-responder
|
||||
<list-revisions-feed-action> "revisions.atom" add-responder
|
||||
<diff-action> <article-boilerplate> "diff" add-responder
|
||||
<edit-article-action> <article-boilerplate> <protected>
|
||||
"edit wiki articles" >>description
|
||||
"edit" add-responder
|
||||
<edit-article-action> <article-boilerplate> "edit" add-responder
|
||||
<rollback-action> "rollback" add-responder
|
||||
<user-edits-action> "user-edits" add-responder
|
||||
<list-articles-action> "articles" add-responder
|
||||
<list-changes-action> "changes" add-responder
|
||||
<user-edits-feed-action> "user-edits.atom" add-responder
|
||||
<list-changes-feed-action> "changes.atom" add-responder
|
||||
<delete-action> <protected>
|
||||
"delete wiki articles" >>description
|
||||
{ can-delete-wiki-articles? } >>capabilities
|
||||
"delete" add-responder
|
||||
<delete-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
{ wiki "wiki-common" } >>template ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue