Document clumps
Slava Pestov
parent
56488c2244
commit
dc1a423f88
|
|
@ -680,7 +680,7 @@ PRIVATE>
|
|||
: unclip ( seq -- rest first )
|
||||
[ rest ] [ first ] bi ;
|
||||
|
||||
: unclip-last ( seq -- butfirst last )
|
||||
: unclip-last ( seq -- butlast last )
|
||||
[ but-last ] [ peek ] bi ;
|
||||
|
||||
: unclip-slice ( seq -- rest first )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,25 @@
|
|||
USING: help.markup help.syntax sequences strings ;
|
||||
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"
|
||||
"Splitting sequences at occurrences of subsequences:"
|
||||
{ $subsection ?head }
|
||||
|
|
@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
|
|||
{ $subsection ?tail-slice }
|
||||
{ $subsection split1 }
|
||||
{ $subsection split }
|
||||
"Grouping elements:"
|
||||
{ $subsection group }
|
||||
"A virtual sequence for grouping elements:"
|
||||
{ $subsection groups }
|
||||
{ $subsection <groups> }
|
||||
{ $subsection <sliced-groups> }
|
||||
"Splitting a string into lines:"
|
||||
{ $subsection string-lines } ;
|
||||
{ $subsection string-lines }
|
||||
{ $subsection "groups-clumps" } ;
|
||||
|
||||
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?\" }" } } ;
|
||||
|
||||
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
|
||||
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
|
||||
{ $see-also group } ;
|
||||
|
||||
HELP: group
|
||||
{ $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." }
|
||||
{ $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." } ;
|
||||
{ $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." }
|
||||
{ $examples
|
||||
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
|
||||
} ;
|
||||
|
||||
HELP: <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
|
||||
{ $example
|
||||
"USING: arrays kernel prettyprint sequences splitting ;"
|
||||
|
|
@ -58,7 +75,7 @@ HELP: <groups>
|
|||
|
||||
HELP: <sliced-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
|
||||
{ $example
|
||||
"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
|
||||
{ $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 ;
|
||||
|
||||
: <clumps> ( seq n -- groups )
|
||||
: <clumps> ( seq n -- clumps )
|
||||
clumps construct-groups ; inline
|
||||
|
||||
M: clumps length
|
||||
|
|
@ -58,7 +58,7 @@ M: clumps group@
|
|||
|
||||
TUPLE: sliced-clumps < groups ;
|
||||
|
||||
: <sliced-clumps> ( seq n -- groups )
|
||||
: <sliced-clumps> ( seq n -- clumps )
|
||||
sliced-clumps construct-groups ; inline
|
||||
|
||||
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: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: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:each-tuple t:values="pastes">
|
||||
<tr>
|
||||
<td><t:a t:href="$pastebin/view-paste" t:query="id"><t:field t:name="summary" /></t:a></td>
|
||||
<td><t:field t:name="author" /></td>
|
||||
<td><t:field t:name="date" /></td>
|
||||
</tr>
|
||||
</t:each-tuple>
|
||||
</table>
|
||||
|
||||
</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