steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implemented user capabilities

db4
Slava Pestov 2008-05-01 20:03:02 -05:00
parent 583d036e8a
commit 5bae9bf6ef
17 changed files with 183 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/http/http-tests.factor
View File

@ -24,6 +24,12 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1

38
extra/http/http.factor
View File

@ -119,21 +119,41 @@ IN: http
header-value>string check-header-string write crlf
] assoc-each crlf ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc )
dup [
"&" split [
"=" split1 [ dup [ url-decode ] when ] bi@
] H{ } map>assoc
"&" split H{ } clone [
[
>r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
[ url-encode ]
[ dup number? [ number>string ] when url-encode ]
bi*
"=" swap 3append
] { } assoc>map
"&" join ;
{
{ [ dup number? ] [ number>string ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
>r url-encode r>
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ;

36
extra/http/server/auth/admin/admin.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators
locals db.tuples
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
@ -10,17 +11,26 @@ http.server.auth.login
http.server.auth
http.server.forms
http.server.components.inspector
http.server.components
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
@ -28,8 +38,8 @@ IN: http.server.auth.admin
"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 ;
"email" <email> add-field
"capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form )
"user" <form>
@ -40,8 +50,8 @@ IN: http.server.auth.admin
"new-password" <password> add-field
"verify-password" <password> add-field
"email" <email> add-field
"profile" <inspector> add-field ;
! "capabilities" <capabilities> add-field ;
"profile" <inspector> add-field
"capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form )
"user-list" <form>
@ -102,6 +112,7 @@ IN: http.server.auth.admin
[ realname>> "realname" set-value ]
[ email>> "email" set-value ]
[ profile>> "profile" set-value ]
[ capabilities>> words>strings "capabilities" set-value ]
} cleave
] >>init
@ -122,6 +133,11 @@ IN: http.server.auth.admin
"new-password" value >>encoded-password
] unless
"capabilities" value {
{ [ dup string? ] [ 1array ] }
{ [ dup array? ] [ ] }
} cond strings>words >>capabilities
update-tuple
next f <standard-redirect>
@ -157,3 +173,9 @@ can-administer-users? define-capability
"admin" admin-template >>template
{ can-administer-users? } <protected>
] ;
: make-admin ( username -- )
<user>
select-tuple
[ can-administer-users? suffix ] change-capabilities
update-tuple ;

2
extra/http/server/auth/admin/admin.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:style include="resource:extra/http/server/auth/admin/admin.css" />
<t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
<div class="navbar">
<t:a t:href="$user-admin">List Users</t:a>

5
extra/http/server/auth/admin/edit-user.xml
View File

@ -35,6 +35,11 @@
<td><t:edit t:component="email" /></td>
</tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:edit t:component="capabilities" /></td>
</tr>
<tr>
<th class="field-label">Profile:</th>
<td><t:view t:component="profile" /></td>

5
extra/http/server/auth/admin/new-user.xml
View File

@ -32,6 +32,11 @@
<th class="field-label">E-mail:</th>
<td><t:edit t:component="email" /></td>
</tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:edit t:component="capabilities" /></td>
</tr>
</table>

2
extra/http/server/auth/basic/basic.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http.server.auth.providers http.server.auth.login
http sequences ;
IN: http.server.auth.basic

4
extra/http/server/auth/login/login.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
combinators sequences namespaces hashtables
combinators sequences namespaces hashtables sets
fry arrays threads locals qualified random
io
io.sockets
@ -364,7 +364,7 @@ C: <protected> protected
"$login/login" f <standard-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] [ profile>> ] bi* '[ , at ] all? ;
[ capabilities>> ] bi@ subset? ;
M: protected call-responder* ( path responder -- response )
uid dup [

4
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -1,7 +1,7 @@
IN: http.server.auth.providers.assoc.tests
USING: http.server.actions http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces accessors kernel ;
http.server.auth.providers.assoc http.server.auth.login
tools.test namespaces accessors kernel ;
<action> <login>
<users-in-memory> >>users

1
extra/http/server/auth/providers/db/db.factor
View File

@ -13,6 +13,7 @@ user "USERS"
{ "salt" "SALT" INTEGER +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } }
{ "capabilities" "CAPABILITIES" FACTOR-BLOB }
{ "profile" "PROFILE" FACTOR-BLOB }
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent

5
extra/http/server/auth/providers/providers.factor
View File

@ -4,7 +4,10 @@ USING: kernel accessors random math.parser locals
sequences math ;
IN: http.server.auth.providers
TUPLE: user username realname password salt email ticket profile deleted changed? ;
TUPLE: user
username realname
password salt
email ticket capabilities profile deleted changed? ;
: <user> ( username -- user )
user new

43
extra/http/server/components/components.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math
hashtables fry locals combinators continuations math
calendar.format html.elements xml.entities
http.server.validators ;
IN: http.server.components
@ -18,10 +18,11 @@ TUPLE: field type ;
C: <field> field
M: field render-view* drop escape-string write ;
M: field render-view*
drop escape-string write ;
M: field render-edit*
<input type>> =type [ =id ] [ =name ] bi =value input/> ;
<input type>> =type =name =value input/> ;
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;
@ -348,8 +349,8 @@ M: choice-renderer render-view*
escape-string write
</option> ;
: render-options ( text selected -- )
[ [ drop ] [ member? ] 2bi render-option ] curry each ;
: render-options ( options selected -- )
'[ dup , member? render-option ] each ;
M: choice-renderer render-edit*
<select swap =name select>
@ -365,11 +366,16 @@ TUPLE: choice < string ;
! Menu
TUPLE: menu-renderer choices size ;
C: <menu-renderer> menu-renderer
: <menu-renderer> ( choices -- renderer )
5 menu-renderer boa ;
M: menu-renderer render-edit*
<select dup size>> [ number>string =size ] when* swap =name select>
choices>> render-options
M:: menu-renderer render-edit* ( value id renderer -- )
<select
renderer size>> [ number>string =size ] when*
id =name
"true" =multiple
select>
renderer choices>> value render-options
</select> ;
TUPLE: menu < string ;
@ -377,3 +383,22 @@ TUPLE: menu < string ;
: <menu> ( id choices -- component )
swap menu new-string
swap <menu-renderer> >>renderer ;
! Checkboxes
TUPLE: checkbox-renderer label ;
C: <checkbox-renderer> checkbox-renderer
M: checkbox-renderer render-edit*
<input
"checkbox" =type
swap =id
swap [ "true" =selected ] when
input>
label>> escape-string write
</input> ;
TUPLE: checkbox < string ;
: <checkbox> ( id label -- component )
checkbox swap <checkbox-renderer> new-component ;

16
extra/http/server/static/static.factor
View File

@ -7,7 +7,7 @@ logging calendar.format accessors io.encodings.binary fry ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special ;
TUPLE: file-responder root hook special allow-listings ;
: modified-since? ( filename -- ? )
request get "if-modified-since" header dup [
@ -19,8 +19,14 @@ TUPLE: file-responder root hook special ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <file-responder> ( root hook -- responder )
H{ } clone file-responder boa ;
file-responder new
swap >>hook
swap >>root
H{ } clone >>special ;
: <static> ( root -- responder )
[
@ -65,7 +71,11 @@ TUPLE: file-responder root hook special ;
] simple-html-document ;
: list-directory ( directory -- response )
'[ , directory. ] <html-content> ;
file-responder get allow-listings>> [
'[ , directory. ] <html-content>
] [
drop <403>
] if ;
: find-index ( filename -- path )
"index.html" append-path dup exists? [ drop f ] unless ;

48
extra/webapps/factor-website/page.css Normal file
View File

@ -0,0 +1,48 @@
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
.link-button {
padding: 0px;
background: none;
border: none;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
.inline {
display: inline;
}
.navbar {
background-color: #eee;
padding: 5px;
border: 1px solid #ccc;
}
.big-field-label {
vertical-align: top;
}
.description {
border: 1px dashed #ccc;
background-color: #f5f5f5;
padding: 5px;
font-size: 150%;
color: #000000;
}

51
extra/webapps/factor-website/page.xml
View File

@ -12,56 +12,7 @@
<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
<t:style>
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
.link-button {
padding: 0px;
background: none;
border: none;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
.inline {
display: inline;
}
.navbar {
background-color: #eee;
padding: 5px;
border: 1px solid #ccc;
}
.big-field-label {
vertical-align: top;
}
.description {
border: 1px dashed #ccc;
background-color: #f5f5f5;
padding: 5px;
font-size: 150%;
color: #000000;
}
</t:style>
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:write-style />
</head>

5
extra/webapps/planet/planet.xml
View File

@ -2,10 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:comment>
<t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" />
<t:style t:include="resource:extra/webapps/planet/planet.css" />
<div class="navbar">
<t:a t:href="$planet-factor/list">Front Page</t:a>

2
extra/webapps/todo/todo.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:style include="resource:extra/webapps/todo/todo.css" />
<t:style t:include="resource:extra/webapps/todo/todo.css" />
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>