Implemented user capabilities

extra/http/http-tests.factor

@@ -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

extra/http/http.factor

@@ -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 [
+        "&" split H{ } clone [
-            "=" split1 [ dup [ url-decode ] when ] bi@
+            [
-        ] H{ } map>assoc
+                >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 ]
+            { [ dup number? ] [ number>string ] }
-        bi*
+            { [ dup string? ] [ 1array ] }
-        "=" swap 3append
+            { [ dup sequence? ] [ ] }
-    ] { } assoc>map
+        } cond
-    "&" join ;
+    ] 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 ;
 

extra/http/server/auth/admin/admin.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators
+USING: kernel sequences accessors namespaces combinators words
-locals db.tuples
+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 ;
+        "email" <email> add-field
-        ! "capabilities" <capabilities> 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 ;
+        "profile" <inspector> add-field
-        ! "capabilities" <capabilities> 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 ;

extra/http/server/auth/admin/admin.xml

@@ -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>

extra/http/server/auth/admin/edit-user.xml

@@ -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>

extra/http/server/auth/admin/new-user.xml

@@ -33,6 +33,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>
+
 	</table>
 	
 	<p>

extra/http/server/auth/basic/basic.factor

@@ -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
 

extra/http/server/auth/login/login.factor

@@ -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 [

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -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
+http.server.auth.providers.assoc http.server.auth.login
-namespaces accessors kernel ;
+tools.test namespaces accessors kernel ;
 
 <action> <login>
     <users-in-memory> >>users

extra/http/server/auth/providers/db/db.factor

@@ -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

extra/http/server/auth/providers/providers.factor

@@ -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

extra/http/server/components/components.factor

@@ -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 -- )
+: render-options ( options selected -- )
-    [ [ drop ] [ member? ] 2bi render-option ] curry each ;
+    '[ 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*
+M:: menu-renderer render-edit* ( value id renderer -- )
-    <select dup size>> [ number>string =size ] when* swap =name select>
+    <select
-        choices>> render-options
+        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 ;

extra/http/server/static/static.factor

@@ -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 ;

extra/webapps/factor-website/page.css

@@ -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;
+}

extra/webapps/factor-website/page.xml

@@ -12,56 +12,7 @@
 
 			<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
 
-			<t:style>
+			<t:style t:include="resource:extra/webapps/factor-website/page.css" />
-				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:write-style />
 		</head>

extra/webapps/planet/planet.xml

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

extra/webapps/todo/todo.xml

@@ -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>