Document clumps
Slava Pestov
parent
56488c2244
commit
dc1a423f88
|
|
@ -680,7 +680,7 @@ PRIVATE>
|
||||||
: unclip ( seq -- rest first )
|
: unclip ( seq -- rest first )
|
||||||
[ rest ] [ first ] bi ;
|
[ rest ] [ first ] bi ;
|
||||||
|
|
||||||
: unclip-last ( seq -- butfirst last )
|
: unclip-last ( seq -- butlast last )
|
||||||
[ but-last ] [ peek ] bi ;
|
[ but-last ] [ peek ] bi ;
|
||||||
|
|
||||||
: unclip-slice ( seq -- rest first )
|
: unclip-slice ( seq -- rest first )
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,25 @@
|
||||||
USING: help.markup help.syntax sequences strings ;
|
USING: help.markup help.syntax sequences strings ;
|
||||||
IN: splitting
|
IN: splitting
|
||||||
|
|
||||||
|
ARTICLE: "groups-clumps" "Groups and clumps"
|
||||||
|
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
|
||||||
|
{ $subsection groups }
|
||||||
|
{ $subsection <groups> }
|
||||||
|
{ $subsection <sliced-groups> }
|
||||||
|
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
|
||||||
|
{ $subsection clumps }
|
||||||
|
{ $subsection <clumps> }
|
||||||
|
{ $subsection <sliced-clumps> }
|
||||||
|
"The difference can be summarized as the following:"
|
||||||
|
{ $list
|
||||||
|
{ "With groups, the subsequences form the original sequence when concatenated:"
|
||||||
|
{ $unchecked-example "dup n groups concat sequence= ." "t" }
|
||||||
|
}
|
||||||
|
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
|
||||||
|
{ $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
ARTICLE: "sequences-split" "Splitting sequences"
|
ARTICLE: "sequences-split" "Splitting sequences"
|
||||||
"Splitting sequences at occurrences of subsequences:"
|
"Splitting sequences at occurrences of subsequences:"
|
||||||
{ $subsection ?head }
|
{ $subsection ?head }
|
||||||
|
|
@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
|
||||||
{ $subsection ?tail-slice }
|
{ $subsection ?tail-slice }
|
||||||
{ $subsection split1 }
|
{ $subsection split1 }
|
||||||
{ $subsection split }
|
{ $subsection split }
|
||||||
"Grouping elements:"
|
|
||||||
{ $subsection group }
|
|
||||||
"A virtual sequence for grouping elements:"
|
|
||||||
{ $subsection groups }
|
|
||||||
{ $subsection <groups> }
|
|
||||||
{ $subsection <sliced-groups> }
|
|
||||||
"Splitting a string into lines:"
|
"Splitting a string into lines:"
|
||||||
{ $subsection string-lines } ;
|
{ $subsection string-lines }
|
||||||
|
{ $subsection "groups-clumps" } ;
|
||||||
|
|
||||||
ABOUT: "sequences-split"
|
ABOUT: "sequences-split"
|
||||||
|
|
||||||
|
|
@ -36,19 +50,22 @@ HELP: split
|
||||||
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
|
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
|
||||||
|
|
||||||
HELP: groups
|
HELP: groups
|
||||||
{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
|
{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
|
||||||
$nl
|
$nl
|
||||||
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
||||||
{ $see-also group } ;
|
{ $see-also group } ;
|
||||||
|
|
||||||
HELP: group
|
HELP: group
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
|
||||||
{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
|
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
|
||||||
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
|
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
|
||||||
|
{ $examples
|
||||||
|
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: <groups>
|
HELP: <groups>
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
||||||
{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
|
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example
|
{ $example
|
||||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||||
|
|
@ -58,7 +75,7 @@ HELP: <groups>
|
||||||
|
|
||||||
HELP: <sliced-groups>
|
HELP: <sliced-groups>
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
|
||||||
{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
|
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example
|
{ $example
|
||||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||||
|
|
@ -68,7 +85,46 @@ HELP: <sliced-groups>
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
{ group <groups> <sliced-groups> } related-words
|
HELP: clumps
|
||||||
|
{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
|
||||||
|
$nl
|
||||||
|
"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
|
||||||
|
|
||||||
|
HELP: clump
|
||||||
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
|
||||||
|
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
|
||||||
|
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
|
||||||
|
{ $examples
|
||||||
|
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <clumps>
|
||||||
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
|
||||||
|
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
|
||||||
|
{ $examples
|
||||||
|
"Running averages:"
|
||||||
|
{ $example
|
||||||
|
"USING: splitting sequences math prettyprint kernel ;"
|
||||||
|
"IN: scratchpad"
|
||||||
|
": share-price"
|
||||||
|
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
|
||||||
|
""
|
||||||
|
"share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
|
||||||
|
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <sliced-clumps>
|
||||||
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
|
||||||
|
{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
|
||||||
|
|
||||||
|
{ clumps groups } related-words
|
||||||
|
|
||||||
|
{ clump group } related-words
|
||||||
|
|
||||||
|
{ <clumps> <groups> } related-words
|
||||||
|
|
||||||
|
{ <sliced-clumps> <sliced-groups> } related-words
|
||||||
|
|
||||||
HELP: ?head
|
HELP: ?head
|
||||||
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
|
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
|
||||||
|
|
|
||||||
|
|
@ -44,7 +44,7 @@ M: sliced-groups nth group@ <slice> ;
|
||||||
|
|
||||||
TUPLE: clumps < abstract-groups ;
|
TUPLE: clumps < abstract-groups ;
|
||||||
|
|
||||||
: <clumps> ( seq n -- groups )
|
: <clumps> ( seq n -- clumps )
|
||||||
clumps construct-groups ; inline
|
clumps construct-groups ; inline
|
||||||
|
|
||||||
M: clumps length
|
M: clumps length
|
||||||
|
|
@ -58,7 +58,7 @@ M: clumps group@
|
||||||
|
|
||||||
TUPLE: sliced-clumps < groups ;
|
TUPLE: sliced-clumps < groups ;
|
||||||
|
|
||||||
: <sliced-clumps> ( seq n -- groups )
|
: <sliced-clumps> ( seq n -- clumps )
|
||||||
sliced-clumps construct-groups ; inline
|
sliced-clumps construct-groups ; inline
|
||||||
|
|
||||||
M: sliced-clumps nth group@ <slice> ;
|
M: sliced-clumps nth group@ <slice> ;
|
||||||
|
|
|
||||||
|
|
@ -1,179 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel sequences accessors namespaces combinators words
|
|
||||||
assocs locals db.tuples arrays splitting strings qualified
|
|
||||||
|
|
||||||
http.server.templating.chloe
|
|
||||||
http.server.boilerplate
|
|
||||||
http.server.auth.providers
|
|
||||||
http.server.auth.providers.db
|
|
||||||
http.server.auth.login
|
|
||||||
http.server.auth
|
|
||||||
http.server.forms
|
|
||||||
http.server.components.inspector
|
|
||||||
http.server.validators
|
|
||||||
http.server.sessions
|
|
||||||
http.server.actions
|
|
||||||
http.server.crud
|
|
||||||
http.server ;
|
|
||||||
EXCLUDE: http.server.components => string? number? ;
|
|
||||||
IN: http.server.auth.admin
|
|
||||||
|
|
||||||
: admin-template ( name -- template )
|
|
||||||
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
|
|
||||||
|
|
||||||
: words>strings ( seq -- seq' )
|
|
||||||
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
|
|
||||||
|
|
||||||
: strings>words ( seq -- seq' )
|
|
||||||
[ ":" split1 swap lookup ] map ;
|
|
||||||
|
|
||||||
: <capabilities> ( id -- component )
|
|
||||||
capabilities get words>strings <menu> ;
|
|
||||||
|
|
||||||
: <new-user-form> ( -- form )
|
|
||||||
"user" <form>
|
|
||||||
"new-user" admin-template >>edit-template
|
|
||||||
"username" <string> add-field
|
|
||||||
"realname" <string> add-field
|
|
||||||
"new-password" <password> t >>required add-field
|
|
||||||
"verify-password" <password> t >>required add-field
|
|
||||||
"email" <email> add-field
|
|
||||||
"capabilities" <capabilities> add-field ;
|
|
||||||
|
|
||||||
: <edit-user-form> ( -- form )
|
|
||||||
"user" <form>
|
|
||||||
"edit-user" admin-template >>edit-template
|
|
||||||
"user-summary" admin-template >>summary-template
|
|
||||||
"username" <string> hidden >>renderer add-field
|
|
||||||
"realname" <string> add-field
|
|
||||||
"new-password" <password> add-field
|
|
||||||
"verify-password" <password> add-field
|
|
||||||
"email" <email> add-field
|
|
||||||
"profile" <inspector> add-field
|
|
||||||
"capabilities" <capabilities> add-field ;
|
|
||||||
|
|
||||||
: <user-list-form> ( -- form )
|
|
||||||
"user-list" <form>
|
|
||||||
"user-list" admin-template >>view-template
|
|
||||||
"list" <edit-user-form> +unordered+ <list> add-field ;
|
|
||||||
|
|
||||||
:: <new-user-action> ( form ctor next -- action )
|
|
||||||
<action>
|
|
||||||
[
|
|
||||||
blank-values
|
|
||||||
|
|
||||||
"username" get ctor call
|
|
||||||
|
|
||||||
{
|
|
||||||
[ username>> "username" set-value ]
|
|
||||||
[ realname>> "realname" set-value ]
|
|
||||||
[ email>> "email" set-value ]
|
|
||||||
[ profile>> "profile" set-value ]
|
|
||||||
} cleave
|
|
||||||
] >>init
|
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
|
||||||
|
|
||||||
[
|
|
||||||
blank-values
|
|
||||||
|
|
||||||
form validate-form
|
|
||||||
|
|
||||||
same-password-twice
|
|
||||||
|
|
||||||
user new "username" value >>username select-tuple
|
|
||||||
[ user-exists ] when
|
|
||||||
|
|
||||||
"username" value <user>
|
|
||||||
"realname" value >>realname
|
|
||||||
"email" value >>email
|
|
||||||
"new-password" value >>encoded-password
|
|
||||||
H{ } clone >>profile
|
|
||||||
|
|
||||||
insert-tuple
|
|
||||||
|
|
||||||
next f <standard-redirect>
|
|
||||||
] >>submit ;
|
|
||||||
|
|
||||||
:: <edit-user-action> ( form ctor next -- action )
|
|
||||||
<action>
|
|
||||||
{ { "username" [ v-required ] } } >>get-params
|
|
||||||
|
|
||||||
[
|
|
||||||
blank-values
|
|
||||||
|
|
||||||
"username" get ctor call select-tuple
|
|
||||||
|
|
||||||
{
|
|
||||||
[ username>> "username" set-value ]
|
|
||||||
[ realname>> "realname" set-value ]
|
|
||||||
[ email>> "email" set-value ]
|
|
||||||
[ profile>> "profile" set-value ]
|
|
||||||
[ capabilities>> words>strings "capabilities" set-value ]
|
|
||||||
} cleave
|
|
||||||
] >>init
|
|
||||||
|
|
||||||
[ form edit-form ] >>display
|
|
||||||
|
|
||||||
[
|
|
||||||
blank-values
|
|
||||||
|
|
||||||
form validate-form
|
|
||||||
|
|
||||||
"username" value <user> select-tuple
|
|
||||||
"realname" value >>realname
|
|
||||||
"email" value >>email
|
|
||||||
|
|
||||||
{ "new-password" "verify-password" }
|
|
||||||
[ value empty? ] all? [
|
|
||||||
same-password-twice
|
|
||||||
"new-password" value >>encoded-password
|
|
||||||
] unless
|
|
||||||
|
|
||||||
"capabilities" value {
|
|
||||||
{ [ dup string? ] [ 1array ] }
|
|
||||||
{ [ dup array? ] [ ] }
|
|
||||||
} cond strings>words >>capabilities
|
|
||||||
|
|
||||||
update-tuple
|
|
||||||
|
|
||||||
next f <standard-redirect>
|
|
||||||
] >>submit ;
|
|
||||||
|
|
||||||
:: <delete-user-action> ( ctor next -- action )
|
|
||||||
<action>
|
|
||||||
{ { "username" [ ] } } >>post-params
|
|
||||||
|
|
||||||
[
|
|
||||||
"username" get
|
|
||||||
[ <user> select-tuple 1 >>deleted update-tuple ]
|
|
||||||
[ logout-all-sessions ]
|
|
||||||
bi
|
|
||||||
|
|
||||||
next f <standard-redirect>
|
|
||||||
] >>submit ;
|
|
||||||
|
|
||||||
TUPLE: user-admin < dispatcher ;
|
|
||||||
|
|
||||||
SYMBOL: can-administer-users?
|
|
||||||
|
|
||||||
can-administer-users? define-capability
|
|
||||||
|
|
||||||
:: <user-admin> ( -- responder )
|
|
||||||
[let | ctor [ [ <user> ] ] |
|
|
||||||
user-admin new-dispatcher
|
|
||||||
<user-list-form> ctor <list-action> "" add-responder
|
|
||||||
<new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
|
|
||||||
<edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
|
|
||||||
ctor "$user-admin" <delete-user-action> "delete" add-responder
|
|
||||||
<boilerplate>
|
|
||||||
"admin" admin-template >>template
|
|
||||||
{ can-administer-users? } <protected>
|
|
||||||
] ;
|
|
||||||
|
|
||||||
: make-admin ( username -- )
|
|
||||||
<user>
|
|
||||||
select-tuple
|
|
||||||
[ can-administer-users? suffix ] change-capabilities
|
|
||||||
update-tuple ;
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
|
||||||
|
|
||||||
<t:title>Users</t:title>
|
|
||||||
|
|
||||||
<t:summary t:component="list" />
|
|
||||||
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
|
||||||
|
|
||||||
<t:a t:href="$user-admin/edit" t:query="username">
|
|
||||||
<t:view t:component="username" />
|
|
||||||
</t:a>
|
|
||||||
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
<?xml version='1.0' ?>
|
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
|
||||||
|
|
||||||
<t:title>Pastebin</t:title>
|
|
||||||
|
|
||||||
<table width="100%">
|
|
||||||
<th align="left" width="50%">Summary:</th>
|
|
||||||
<th align="left" width="100">Paste by:</th>
|
|
||||||
<th align="left" width="200">Date:</th>
|
|
||||||
|
|
||||||
<t:summary t:component="pastes" />
|
|
||||||
</table>
|
|
||||||
|
|
||||||
</t:chloe>
|
|
||||||
|
|
@ -0,0 +1,31 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
|
||||||
|
|
||||||
|
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
|
||||||
|
|
||||||
|
<div class="navbar">
|
||||||
|
|
||||||
|
<t:a t:href="$pastebin/list">Pastes</t:a>
|
||||||
|
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
|
||||||
|
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
|
||||||
|
|
||||||
|
<t:if t:code="http.server.sessions:uid">
|
||||||
|
|
||||||
|
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||||
|
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||||
|
</t:if>
|
||||||
|
|
||||||
|
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
|
||||||
|
|
||||||
|
</t:if>
|
||||||
|
|
||||||
|
</div>
|
||||||
|
|
||||||
|
<h1><t:write-title /></h1>
|
||||||
|
|
||||||
|
<t:call-next-template />
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
|
|
@ -2,29 +2,20 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
|
<t:title>Pastebin</t:title>
|
||||||
|
|
||||||
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
|
<table width="100%">
|
||||||
|
<th align="left" width="50%">Summary:</th>
|
||||||
|
<th align="left" width="100">Paste by:</th>
|
||||||
|
<th align="left" width="200">Date:</th>
|
||||||
|
|
||||||
<div class="navbar">
|
<t:each-tuple t:values="pastes">
|
||||||
<t:a t:href="$pastebin/list">Pastes</t:a>
|
<tr>
|
||||||
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
|
<td><t:a t:href="$pastebin/view-paste" t:query="id"><t:field t:name="summary" /></t:a></td>
|
||||||
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
|
<td><t:field t:name="author" /></td>
|
||||||
|
<td><t:field t:name="date" /></td>
|
||||||
<t:if t:code="http.server.sessions:uid">
|
</tr>
|
||||||
|
</t:each-tuple>
|
||||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
</table>
|
||||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
|
||||||
</t:if>
|
|
||||||
|
|
||||||
| <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
|
|
||||||
|
|
||||||
</t:if>
|
|
||||||
|
|
||||||
</div>
|
|
||||||
|
|
||||||
<h1><t:write-title /></h1>
|
|
||||||
|
|
||||||
<t:call-next-template />
|
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,160 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel sequences accessors namespaces combinators words
|
||||||
|
assocs db.tuples arrays splitting strings validators
|
||||||
|
html.elements
|
||||||
|
html.components
|
||||||
|
html.templates.chloe
|
||||||
|
http.server.boilerplate
|
||||||
|
http.server.auth.providers
|
||||||
|
http.server.auth.providers.db
|
||||||
|
http.server.auth.login
|
||||||
|
http.server.auth
|
||||||
|
http.server.sessions
|
||||||
|
http.server.actions
|
||||||
|
http.server.crud
|
||||||
|
http.server ;
|
||||||
|
IN: webapps.user-admin
|
||||||
|
|
||||||
|
: admin-template ( name -- template )
|
||||||
|
"resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
|
||||||
|
|
||||||
|
: words>strings ( seq -- seq' )
|
||||||
|
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
|
||||||
|
|
||||||
|
: strings>words ( seq -- seq' )
|
||||||
|
[ ":" split1 swap lookup ] map ;
|
||||||
|
|
||||||
|
: <user-list-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
[ f <user> select-tuples "users" set-value ] >>init
|
||||||
|
[ "user-list" admin-template <html-content> ] >>display ;
|
||||||
|
|
||||||
|
: <new-user-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
"username" param <user> {
|
||||||
|
[ username>> "username" set-value ]
|
||||||
|
[ realname>> "realname" set-value ]
|
||||||
|
[ email>> "email" set-value ]
|
||||||
|
[ profile>> "profile" set-value ]
|
||||||
|
} cleave
|
||||||
|
|
||||||
|
capabilities get "all-capabilities" set-value
|
||||||
|
] >>init
|
||||||
|
|
||||||
|
[ "new-user" admin-template <html-content> ] >>display
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
|
{ "realname" [ v-one-line ] }
|
||||||
|
{ "new-password" [ v-password ] }
|
||||||
|
{ "verify-password" [ v-password ] }
|
||||||
|
{ "email" [ [ v-email ] v-optional ] }
|
||||||
|
{ "capabilities" [ ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
|
same-password-twice
|
||||||
|
|
||||||
|
user new "username" value >>username select-tuple
|
||||||
|
[ user-exists ] when
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
|
"username" value <user>
|
||||||
|
"realname" value >>realname
|
||||||
|
"email" value >>email
|
||||||
|
"new-password" value >>encoded-password
|
||||||
|
H{ } clone >>profile
|
||||||
|
|
||||||
|
insert-tuple
|
||||||
|
|
||||||
|
"$user-admin" f <standard-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
: <edit-user-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
{ { "username" [ v-username ] } } validate-params
|
||||||
|
|
||||||
|
"username" value <user> select-tuple {
|
||||||
|
[ username>> "username" set-value ]
|
||||||
|
[ realname>> "realname" set-value ]
|
||||||
|
[ email>> "email" set-value ]
|
||||||
|
[ profile>> "profile" set-value ]
|
||||||
|
[ capabilities>> words>strings "capabilities" set-value ]
|
||||||
|
} cleave
|
||||||
|
|
||||||
|
capabilities get "all-capabilities" set-value
|
||||||
|
] >>init
|
||||||
|
|
||||||
|
[ "edit-user" admin-template <html-content> ] >>display
|
||||||
|
|
||||||
|
[
|
||||||
|
{
|
||||||
|
{ "username" [ v-username ] }
|
||||||
|
{ "realname" [ v-one-line ] }
|
||||||
|
{ "new-password" [ [ v-password ] v-optional ] }
|
||||||
|
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||||
|
{ "email" [ [ v-email ] v-optional ] }
|
||||||
|
{ "capabilities" [ ] }
|
||||||
|
} validate-params
|
||||||
|
|
||||||
|
"new-password" "verify-password"
|
||||||
|
[ value empty? ] both? [
|
||||||
|
same-password-twice
|
||||||
|
] unless
|
||||||
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
|
"username" value <user> select-tuple
|
||||||
|
"realname" value >>realname
|
||||||
|
"email" value >>email
|
||||||
|
|
||||||
|
"new-password" value empty? [ drop ] [
|
||||||
|
"new-password" value >>encoded-password
|
||||||
|
] if
|
||||||
|
|
||||||
|
"capabilities" value {
|
||||||
|
{ [ dup string? ] [ 1array ] }
|
||||||
|
{ [ dup array? ] [ ] }
|
||||||
|
} cond strings>words >>capabilities
|
||||||
|
|
||||||
|
update-tuple
|
||||||
|
|
||||||
|
"$user-admin" f <standard-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
: <delete-user-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
[
|
||||||
|
{ { "username" [ v-username ] } } validate-params
|
||||||
|
[ <user> select-tuple 1 >>deleted update-tuple ]
|
||||||
|
[ logout-all-sessions ]
|
||||||
|
bi
|
||||||
|
|
||||||
|
"$user-admin" f <standard-redirect>
|
||||||
|
] >>submit ;
|
||||||
|
|
||||||
|
TUPLE: user-admin < dispatcher ;
|
||||||
|
|
||||||
|
SYMBOL: can-administer-users?
|
||||||
|
|
||||||
|
can-administer-users? define-capability
|
||||||
|
|
||||||
|
: <user-admin> ( -- responder )
|
||||||
|
user-admin new-dispatcher
|
||||||
|
<user-list-action> "" add-responder
|
||||||
|
<new-user-action> "new" add-responder
|
||||||
|
<edit-user-action> "edit" add-responder
|
||||||
|
<delete-user-action> "delete" add-responder
|
||||||
|
<boilerplate>
|
||||||
|
"admin" admin-template >>template
|
||||||
|
{ can-administer-users? } <protected> ;
|
||||||
|
|
||||||
|
: make-admin ( username -- )
|
||||||
|
<user>
|
||||||
|
select-tuple
|
||||||
|
[ can-administer-users? suffix ] change-capabilities
|
||||||
|
update-tuple ;
|
||||||
|
|
@ -0,0 +1,13 @@
|
||||||
|
<?xml version='1.0' ?>
|
||||||
|
|
||||||
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
|
<t:title>Users</t:title>
|
||||||
|
|
||||||
|
<t:each-tuple t:values="users">
|
||||||
|
<t:a t:href="$user-admin/edit" t:query="username">
|
||||||
|
<t:label t:name="username" />
|
||||||
|
</t:a>
|
||||||
|
</t:each-tuple>
|
||||||
|
|
||||||
|
</t:chloe>
|
||||||
Loading…
Reference in New Issue