Working on user capabilities

diff --git a/extra/checksums/null/null.factor b/extra/checksums/null/null.factor
new file mode 100644 (file)
index 0000000..d2dc305
--- /dev/null
+++ b/extra/checksums/null/null.factor
@@ -0,0 +1,8 @@
+USING: checksums ;
+IN: checksums.null
+
+SINGLETON: null
+
+INSTANCE: null checksum
+
+M: null checksum-bytes ;

diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 39e708c879b2c8bd426a9b7934b76215bf569da2..1f1ce361b207f96c797b2c23b7bdab4556a21229 100755 (executable)
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -1,6 +1,6 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite ;
+assocs io.sockets db db.sqlite continuations ;
 IN: http.tests
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -93,7 +93,7 @@ Host: www.sex.com
 
 STRING: read-response-test-1
 HTTP/1.1 404 not found
-Content-Type: text/html
+Content-Type: text/html; charset=UTF8
 
 blah
 ;
@@ -103,8 +103,10 @@ blah
         version: "1.1"
         code: 404
         message: "not found"
-        header: H{ { "content-type" "text/html" } }
+        header: H{ { "content-type" "text/html; charset=UTF8" } }
         cookies: V{ }
+        content-type: "text/html"
+        content-charset: "UTF8"
     }
 ] [
     read-response-test-1 lf>crlf
@@ -114,7 +116,7 @@ blah
 
 STRING: read-response-test-1'
 HTTP/1.1 404 not found
-content-type: text/html
+content-type: text/html; charset=UTF8
 
 
 ;
@@ -140,11 +142,13 @@ accessors namespaces threads ;
 
 : add-quit-action
     <action>
-        [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+        [ stop-server [ "Goodbye" write ] <html-content> ] >>display
     "quit" add-responder ;
 
 : test-db "test.db" temp-file sqlite-db ;
 
+[ test-db drop delete-file ] ignore-errors
+
 test-db [
     init-sessions-table
 ] with-db
@@ -191,7 +195,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> <protected>
+            <action> f <protected>
             <login>
             <sessions>
             "" add-responder

diff --git a/extra/http/http.factor b/extra/http/http.factor
index 9729542ea48c5b7a3da99ca847d4a6da06d05107..c5f57d4c04aae80e7bfe69e5f9c171360811b1a8 100755 (executable)
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -291,6 +291,12 @@ SYMBOL: max-post-request
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
+: parse-content-type-attributes ( string -- attributes )
+    " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
+
+: parse-content-type ( content-type -- type encoding )
+    ";" split1 parse-content-type-attributes "charset" swap at ;
+
 : read-request ( -- request )
     <request>
     read-method
@@ -377,6 +383,8 @@ code
 message
 header
 cookies
+content-type
+content-charset
 body ;
 
 : <response>
@@ -403,7 +411,10 @@ body ;
 
 : read-response-header
     read-header >>header
-    dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
+    extract-cookies
+    dup "content-type" header [
+        parse-content-type [ >>content-type ] [ >>content-charset ] bi*
+    ] when* ;
 
 : read-response ( -- response )
     <response>
@@ -422,10 +433,15 @@ body ;
 : write-response-message ( response -- response )
     dup message>> write crlf ;
 
+: unparse-content-type ( request -- content-type )
+    [ content-type>> "application/octet-stream" or ]
+    [ content-charset>> ] bi
+    [ "; charset=" swap 3append ] when* ;
+
 : write-response-header ( response -- response )
     dup header>> clone
-    over cookies>> f like
-    [ unparse-cookies "set-cookie" pick set-at ] when*
+    over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
+    over unparse-content-type "content-type" pick set-at
     write-header ;
 
 GENERIC: write-response-body* ( body -- )
@@ -453,9 +469,6 @@ M: response write-full-response ( request response -- )
     dup write-response
     swap method>> "HEAD" = [ write-response-body ] unless ;
 
-: set-content-type ( request/response content-type -- request/response )
-    "content-type" set-header ;
-
 : get-cookie ( request/response name -- cookie/f )
     >r cookies>> r> '[ , _ name>> = ] find nip ;
 
@@ -466,7 +479,7 @@ M: response write-full-response ( request response -- )
     [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
     over cookies>> push ;
 
-TUPLE: raw-response 
+TUPLE: raw-response
 version
 code
 message

diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor
index c9d27692924ff4143e7f42fe29f456960f5b34c3..0dc5d3560e7553b82621f045253db272082ec716 100644 (file)
--- a/extra/http/server/auth/admin/admin.factor
+++ b/extra/http/server/auth/admin/admin.factor
@@ -7,6 +7,7 @@ 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.components
@@ -28,6 +29,7 @@ IN: http.server.auth.admin
         "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>
@@ -39,6 +41,7 @@ IN: http.server.auth.admin
         "verify-password" <password> add-field
         "email" <email> add-field
         "profile" <inspector> add-field ;
+        ! "capabilities" <capabilities> add-field ;
 
 : <user-list-form> ( -- form )
     "user-list" <form>
@@ -77,7 +80,7 @@ IN: http.server.auth.admin
             "username" value <user>
                 "realname" value >>realname
                 "email" value >>email
-                "new-password" value >>password
+                "new-password" value >>encoded-password
                 H{ } clone >>profile
 
             insert-tuple
@@ -116,7 +119,7 @@ IN: http.server.auth.admin
             { "new-password" "verify-password" }
             [ value empty? ] all? [
                 same-password-twice
-                "new-password" value >>password
+                "new-password" value >>encoded-password
             ] unless
 
             update-tuple
@@ -139,6 +142,10 @@ IN: http.server.auth.admin
 
 TUPLE: user-admin < dispatcher ;
 
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
 :: <user-admin> ( -- responder )
     [let | ctor [ [ <user> ] ] |
         user-admin new-dispatcher
@@ -148,5 +155,5 @@ TUPLE: user-admin < dispatcher ;
             ctor "$user-admin" <delete-user-action> "delete" add-responder
         <boilerplate>
             "admin" admin-template >>template
-        <protected>
+        { can-administer-users? } <protected>
     ] ;

diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
index a25baf3ed2bad777992ad90943c914edff036c9a..36fcff4b2ef47da0d70ba5e6a358f9536e91cd4e 100755 (executable)
--- a/extra/http/server/auth/auth.factor
+++ b/extra/http/server/auth/auth.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Slava Pestov\r
 ! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel\r
+USING: accessors assocs namespaces kernel sequences\r
 http.server\r
 http.server.sessions\r
 http.server.auth.providers ;\r
@@ -33,3 +33,9 @@ M: filter-responder init-user-profile
 : uchange ( quot key -- )\r
     profile swap change-at\r
     user-changed ; inline\r
+\r
+SYMBOL: capabilities\r
+\r
+V{ } clone capabilities set-global\r
+\r
+: define-capability ( word -- ) capabilities get push-new ;\r

diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 453f4cc4d6358a9d74fd772a1201346583d94ff5..9eb79649b9d18bd8edba72f7ca8d0efe4dc1c68e 100755 (executable)
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -1,16 +1,23 @@
 ! Copyright (c) 2008 Slava Pestov\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: accessors quotations assocs kernel splitting\r
-base64 io combinators sequences io.files namespaces hashtables\r
-fry io.sockets arrays threads locals qualified continuations\r
+combinators sequences namespaces hashtables\r
+fry arrays threads locals qualified random\r
+io\r
+io.sockets\r
+io.encodings.utf8\r
+io.encodings.string\r
+io.binary\r
+continuations\r
 destructors\r
-\r
+checksums\r
+checksums.sha2\r
 html.elements\r
 http\r
 http.server\r
 http.server.auth\r
 http.server.auth.providers\r
-http.server.auth.providers.null\r
+http.server.auth.providers.db\r
 http.server.actions\r
 http.server.components\r
 http.server.flows\r
@@ -25,9 +32,24 @@ QUALIFIED: smtp
 \r
 SYMBOL: login-failed?\r
 \r
-TUPLE: login < dispatcher users ;\r
+TUPLE: login < dispatcher users checksum ;\r
+\r
+: users ( -- provider )\r
+    login get users>> ;\r
+\r
+: encode-password ( string salt -- bytes )\r
+    [ utf8 encode ] [ 4 >be ] bi* append\r
+    login get checksum>> checksum-bytes ;\r
 \r
-: users login get users>> ;\r
+: >>encoded-password ( user string -- user )\r
+    32 random-bits [ encode-password ] keep\r
+    [ >>password ] [ >>salt ] bi* ; inline\r
+\r
+: valid-login? ( password user -- ? )\r
+    [ salt>> encode-password ] [ password>> ] bi = ;\r
+\r
+: check-login ( password username -- user/f )\r
+    users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
 \r
 ! Destructor\r
 TUPLE: user-saver user ;\r
@@ -72,8 +94,7 @@ M: user-saver dispose
 \r
                 form validate-form\r
 \r
-                "password" value "username" value\r
-                users check-login [\r
+                "password" value "username" value check-login [\r
                     successful-login\r
                 ] [\r
                     login-failed? on\r
@@ -125,7 +146,7 @@ SYMBOL: user-exists?
 \r
                 "username" value <user>\r
                     "realname" value >>realname\r
-                    "new-password" value >>password\r
+                    "new-password" value >>encoded-password\r
                     "email" value >>email\r
                     H{ } clone >>profile\r
 \r
@@ -179,10 +200,10 @@ SYMBOL: user-exists?
                 [ value empty? ] all? [\r
                     same-password-twice\r
 \r
-                    "password" value uid users check-login\r
+                    "password" value uid check-login\r
                     [ login-failed? on validation-failed ] unless\r
 \r
-                    "new-password" value >>password\r
+                    "new-password" value >>encoded-password\r
                 ] unless\r
 \r
                 "realname" value >>realname\r
@@ -314,7 +335,7 @@ SYMBOL: lost-password-from
                 "ticket" value\r
                 "username" value\r
                 users claim-ticket [\r
-                    "new-password" value >>password\r
+                    "new-password" value >>encoded-password\r
                     users update-user\r
 \r
                     "recover-4" login-template serve-template\r
@@ -334,7 +355,7 @@ SYMBOL: lost-password-from
 \r
 ! ! ! Authentication logic\r
 \r
-TUPLE: protected < filter-responder ;\r
+TUPLE: protected < filter-responder capabilities ;\r
 \r
 C: <protected> protected\r
 \r
@@ -342,11 +363,17 @@ C: <protected> protected
     begin-flow\r
     "$login/login" f <standard-redirect> ;\r
 \r
+: check-capabilities ( responder user -- ? )\r
+    [ capabilities>> ] [ profile>> ] bi* '[ , at ] all? ;\r
+\r
 M: protected call-responder* ( path responder -- response )\r
     uid dup [\r
-        users get-user\r
-        [ logged-in-user set ] [ save-user-after ] bi\r
-        call-next-method\r
+        users get-user 2dup check-capabilities [\r
+            [ logged-in-user set ] [ save-user-after ] bi\r
+            call-next-method\r
+        ] [\r
+            3drop show-login-page\r
+        ] if\r
     ] [\r
         3drop show-login-page\r
     ] if ;\r
@@ -364,12 +391,13 @@ M: login call-responder* ( path responder -- response )
         swap >>default\r
         <login-action> <login-boilerplate> "login" add-responder\r
         <logout-action> <login-boilerplate> "logout" add-responder\r
-        no-users >>users ;\r
+        users-in-db >>users\r
+        sha-256 >>checksum ;\r
 \r
 ! ! ! Configuration\r
 \r
 : allow-edit-profile ( login -- login )\r
-    <edit-profile-action> <protected> <login-boilerplate>\r
+    <edit-profile-action> f <protected> <login-boilerplate>\r
         "edit-profile" add-responder ;\r
 \r
 : allow-registration ( login -- login )\r

diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
index 82a2b54b0e5980a0072ed7fe80d70d2f4e264072..09022b0921978193cfb396a5c00e4201377efa98 100755 (executable)
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@@ -1,33 +1,35 @@
 IN: http.server.auth.providers.assoc.tests\r
-USING: http.server.auth.providers \r
+USING: http.server.actions http.server.auth.providers \r
 http.server.auth.providers.assoc tools.test\r
 namespaces accessors kernel ;\r
 \r
-<users-in-memory> "provider" set\r
+<action> <login>\r
+    <users-in-memory> >>users\r
+login set\r
 \r
 [ t ] [\r
     "slava" <user>\r
-        "foobar" >>password\r
+        "foobar" >>encoded-password\r
         "slava@factorcode.org" >>email\r
         H{ } clone >>profile\r
-    "provider" get new-user\r
+    users new-user\r
     username>> "slava" =\r
 ] unit-test\r
 \r
 [ f ] [\r
     "slava" <user>\r
         H{ } clone >>profile\r
-    "provider" get new-user\r
+    users new-user\r
 ] unit-test\r
 \r
-[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
 \r
-[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
 \r
 [ t ] [ "user" get >boolean ] unit-test\r
 \r
-[ ] [ "user" get "fdasf" >>password drop ] unit-test\r
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
 \r
-[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
 \r
-[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r

diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
index 1a5298f050a0f97920b51a3caff8f7970714b64f..a6a92356b68380941f65deb45314c45c319bde57 100755 (executable)
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -1,10 +1,14 @@
 IN: http.server.auth.providers.db.tests\r
-USING: http.server.auth.providers\r
+USING: http.server.actions\r
+http.server.auth.login\r
+http.server.auth.providers\r
 http.server.auth.providers.db tools.test\r
 namespaces db db.sqlite db.tuples continuations\r
 io.files accessors kernel ;\r
 \r
-users-in-db "provider" set\r
+<action> <login>\r
+    users-in-db >>users\r
+login set\r
 \r
 [ "auth-test.db" temp-file delete-file ] ignore-errors\r
 \r
@@ -14,30 +18,30 @@ users-in-db "provider" set
 \r
     [ t ] [\r
         "slava" <user>\r
-            "foobar" >>password\r
+            "foobar" >>encoded-password\r
             "slava@factorcode.org" >>email\r
             H{ } clone >>profile\r
-            "provider" get new-user\r
+            users new-user\r
             username>> "slava" =\r
     ] unit-test\r
 \r
     [ f ] [\r
         "slava" <user>\r
             H{ } clone >>profile\r
-        "provider" get new-user\r
+        users new-user\r
     ] unit-test\r
 \r
-    [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+    [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
 \r
-    [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
+    [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
 \r
     [ t ] [ "user" get >boolean ] unit-test\r
 \r
-    [ ] [ "user" get "fdasf" >>password drop ] unit-test\r
+    [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
 \r
-    [ ] [ "user" get "provider" get update-user ] unit-test\r
+    [ ] [ "user" get users update-user ] unit-test\r
 \r
-    [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+    [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
 \r
-    [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+    [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
 ] with-db\r

diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index 66d3a00a422e3be5474f1ff7fa1863c3c9cf030f..b72f94f3bd4e045d164f09c8b5746de050506efc 100755 (executable)
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -9,7 +9,8 @@ user "USERS"
 {
     { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
     { "realname" "REALNAME" { VARCHAR 256 } }
-    { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+    { "password" "PASSWORD" BLOB +not-null+ }
+    { "salt" "SALT" INTEGER +not-null+ }
     { "email" "EMAIL" { VARCHAR 256 } }
     { "ticket" "TICKET" { VARCHAR 256 } }
     { "profile" "PROFILE" FACTOR-BLOB }

diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
index 121f065292c702f0531508f94583f4ba5bece0f4..f4c7dbbf1d24249a365277942e73b9aa403165cc 100755 (executable)
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@@ -4,7 +4,7 @@ USING: kernel accessors random math.parser locals
 sequences math ;\r
 IN: http.server.auth.providers\r
 \r
-TUPLE: user username realname password email ticket profile deleted changed? ;\r
+TUPLE: user username realname password salt email ticket profile deleted changed? ;\r
 \r
 : <user> ( username -- user )\r
     user new\r
@@ -17,9 +17,6 @@ GENERIC: update-user ( user provider -- )
 \r
 GENERIC: new-user ( user provider -- user/f )\r
 \r
-: check-login ( password username provider -- user/f )\r
-    get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
-\r
 ! Password recovery support\r
 \r
 :: issue-ticket ( email username provider -- user/f )\r

diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index 1dc5effbe20956e50840a745061a14598240bbb7..e0a4037e31897cab7d51898dfec20dafe2165566 100644 (file)
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces boxes sequences strings
-io io.streams.string arrays
+io io.streams.string arrays locals
 html.elements
 http
 http.server
@@ -47,7 +47,7 @@ SYMBOL: nested-template?
 SYMBOL: next-template
 
 : call-next-template ( -- )
-    next-template get write ;
+    next-template get write-html ;
 
 M: f call-template* drop call-next-template ;
 
@@ -68,9 +68,10 @@ M: f call-template* drop call-next-template ;
         bi*
     ] with-scope ; inline
 
-M: boilerplate call-responder*
-    tuck call-next-method
-    dup "content-type" header "text/html" = [
-        clone swap template>>
-        [ [ with-boilerplate ] 2curry ] curry change-body
-    ] [ nip ] if ;
+M:: boilerplate call-responder* ( path responder -- )
+    path responder call-next-method
+    dup content-type>> "text/html" = [
+        clone [| body |
+            [ body responder template>> with-boilerplate ]
+        ] change-body
+    ] when ;

diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor
index cca594232830be7d0e077ff2f403bb7af7f495e4..31ea164a58bc3619df028c752ba664dba969bc6e 100755 (executable)
--- a/extra/http/server/callbacks/callbacks-tests.factor
+++ b/extra/http/server/callbacks/callbacks-tests.factor
@@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
     <action> [\r
         [\r
             "hello" print\r
-            "text/html" <content> swap '[ , write ] >>body\r
+            '[ , write ] <html-content>\r
         ] show-page\r
         "byebye" print\r
         [ 123 ] show-final\r

diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor
index 90b70c7bccfc335d6a4b11d523d986fadb402078..8bf07700e81d690467d1f0d28221decc8401b1bf 100644 (file)
--- a/extra/http/server/components/code/code.factor
+++ b/extra/http/server/components/code/code.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components ;
+http.server.components xml.entities ;
 IN: http.server.components.code
 
 TUPLE: code-renderer < text-renderer mode ;

diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index cb109fc847a99a656fd72ede6afaa0a74d52b1dd..eb97092fb78b80e3666ed193549227893a7a51a4 100755 (executable)
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -3,7 +3,7 @@
 USING: accessors namespaces kernel io math.parser assocs classes
 words classes.tuple arrays sequences splitting mirrors
 hashtables fry combinators continuations math
-calendar.format html.elements
+calendar.format html.elements xml.entities
 http.server.validators ;
 IN: http.server.components
 
@@ -18,13 +18,13 @@ TUPLE: field type ;
 
 C: <field> field
 
-M: field render-view* drop write ;
+M: field render-view* drop escape-string write ;
 
 M: field render-edit*
     <input type>> =type [ =id ] [ =name ] bi =value input/> ;
 
 : render-error ( message -- )
-    <span "error" =class span> write </span> ;
+    <span "error" =class span> escape-string write </span> ;
 
 TUPLE: hidden < field ;
 
@@ -232,7 +232,7 @@ TUPLE: text-renderer rows cols ;
     text-renderer new-text-renderer ;
 
 M: text-renderer render-view*
-    drop write ;
+    drop escape-string write ;
 
 M: text-renderer render-edit*
     <textarea
@@ -241,7 +241,7 @@ M: text-renderer render-edit*
         [ =id   ]
         [ =name ] bi
     textarea>
-        write
+        escape-string write
     </textarea> ;
 
 TUPLE: text < string ;
@@ -261,7 +261,7 @@ TUPLE: html-text-renderer < text-renderer ;
     html-text-renderer new-text-renderer ;
 
 M: html-text-renderer render-view*
-    drop write ;
+    drop escape-string write ;
 
 TUPLE: html-text < text ;
 
@@ -286,7 +286,7 @@ GENERIC: link-href ( obj -- url )
 SINGLETON: link-renderer
 
 M: link-renderer render-view*
-    drop <a dup link-href =href a> link-title write </a> ;
+    drop <a dup link-href =href a> link-title escape-string write </a> ;
 
 TUPLE: link < string ;
 
@@ -341,15 +341,19 @@ TUPLE: choice-renderer choices ;
 C: <choice-renderer> choice-renderer
 
 M: choice-renderer render-view*
-    drop write ;
+    drop escape-string write ;
+
+: render-option ( text selected? -- )
+    <option [ "true" =selected ] when option>
+        escape-string write
+    </option> ;
+
+: render-options ( text selected -- )
+    [ [ drop ] [ member? ] 2bi render-option ] curry each ;
 
 M: choice-renderer render-edit*
     <select swap =name select>
-        choices>> [
-            <option [ = [ "true" =selected ] when ] keep option>
-                write
-            </option>
-        ] with each
+        choices>> swap 1array render-options
     </select> ;
 
 TUPLE: choice < string ;
@@ -357,3 +361,19 @@ TUPLE: choice < string ;
 : <choice> ( id choices -- component )
     swap choice new-string
         swap <choice-renderer> >>renderer ;
+
+! Menu
+TUPLE: menu-renderer choices size ;
+
+C: <menu-renderer> menu-renderer
+
+M: menu-renderer render-edit*
+    <select dup size>> [ number>string =size ] when* swap =name select>
+        choices>> render-options
+    </select> ;
+
+TUPLE: menu < string ;
+
+: <menu> ( id choices -- component )
+    swap menu new-string
+        swap <menu-renderer> >>renderer ;

diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor
index a8d320f82f7fca8afd734aef9f8ee0777cca2407..87b7170bbfdf79dd75f4d265cadfb40f565a1c14 100755 (executable)
--- a/extra/http/server/components/farkup/farkup.factor
+++ b/extra/http/server/components/farkup/farkup.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: splitting kernel io sequences farkup accessors\r
-http.server.components ;\r
+http.server.components xml.entities ;\r
 IN: http.server.components.farkup\r
 \r
 TUPLE: farkup-renderer < text-renderer ;\r

diff --git a/extra/http/server/components/inspector/inspector.factor b/extra/http/server/components/inspector/inspector.factor
index 25ee631a06daccc4d4d500615817e4945ce6d376..42366b57e40f84d73b9150033237822b655619f5 100644 (file)
--- a/extra/http/server/components/inspector/inspector.factor
+++ b/extra/http/server/components/inspector/inspector.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: splitting kernel io sequences inspector accessors
-http.server.components ;
+http.server.components xml.entities html ;
 IN: http.server.components.inspector
 
 SINGLETON: inspector-renderer
 
 M: inspector-renderer render-view*
-    drop describe ;
+    drop [ describe ] with-html-stream ;
 
 TUPLE: inspector < component ;
 

diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
index 60f3da25b6c418e72ed3d067030eb623c92f3b06..92fb25bb162ac1fb4cf8073b56f56b157705acad 100644 (file)
--- a/extra/http/server/forms/forms.factor
+++ b/extra/http/server/forms/forms.factor
@@ -37,9 +37,7 @@ M: form init V{ } clone >>components ;
     ] with-form ;
 
 : <form-response> ( form template -- response )
-    [ components>> components set ]
-    [ "text/html" <content> swap >>body ]
-    bi* ;
+    [ components>> components set ] [ <html-content> ] bi* ;
 
 : view-form ( form -- response )
     dup view-template>> <form-response> ;

diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index ad04812c63b89a04e218ed3d483aaf27e0a45474..f6dd6c57bb156a300f0b3115f7b4032a0f4a9284 100755 (executable)
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
-threads http sequences prettyprint io.server logging calendar
-html.elements accessors math.parser combinators.lib
-tools.vocabs debugger html continuations random combinators
+threads sequences prettyprint io.server logging calendar
+http html html.elements accessors math.parser combinators.lib
+tools.vocabs debugger continuations random combinators
 destructors io.encodings.8-bit fry classes words ;
 IN: http.server
 
@@ -22,7 +22,10 @@ GENERIC: call-responder* ( path responder -- response )
     <response>
         200 >>code
         "Document follows" >>message
-        swap set-content-type ;
+        swap >>content-type ;
+
+: <html-content> ( quot -- response )
+    "text/html" <content> swap >>body ;
 
 TUPLE: trivial-responder response ;
 
@@ -38,9 +41,7 @@ M: trivial-responder call-responder* nip response>> call ;
     </html> ;
 
 : <trivial-response> ( code message -- response )
-    2dup '[ , , trivial-response-body ]
-    "text/html" <content>
-        swap >>body
+    2dup '[ , , trivial-response-body ] <html-content>
         swap >>message
         swap >>code ;
 

diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index b4cf0bd679e36472bc6b7e41533b82a0870211a7..0d98bf2150cb27da5534438200fa759b3436239e 100755 (executable)
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -143,7 +143,7 @@ M: foo call-responder*
             ] with-destructors response set\r
         ] unit-test\r
 \r
-        [ "text/plain" ] [ response get "content-type" header ] unit-test\r
+        [ "text/plain" ] [ response get content-type>> ] unit-test\r
 \r
         [ f ] [ response get cookies>> empty? ] unit-test\r
     ] with-scope\r

diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index af6018fbdc18c1fdd1264abec2f53804fce27193..f0a367f0fbedece3d2fa692b2f9acc2229285b5d 100755 (executable)
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -1,21 +1,20 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar html io io.files kernel math math.parser http\r
-http.server namespaces parser sequences strings assocs\r
-hashtables debugger http.mime sorting html.elements logging\r
-calendar.format accessors io.encodings.binary fry ;\r
+USING: calendar html io io.files kernel math math.order\r
+math.parser http http.server namespaces parser sequences strings\r
+assocs hashtables debugger http.mime sorting html.elements\r
+logging calendar.format accessors io.encodings.binary fry ;\r
 IN: http.server.static\r
 \r
 ! special maps mime types to quots with effect ( path -- )\r
 TUPLE: file-responder root hook special ;\r
 \r
-: file-http-date ( filename -- string )\r
-    file-info modified>> timestamp>http-string ;\r
-\r
-: last-modified-matches? ( filename -- ? )\r
-    file-http-date dup [\r
-        request get "if-modified-since" header =\r
-    ] when ;\r
+: modified-since? ( filename -- ? )\r
+    request get "if-modified-since" header dup [\r
+        [ file-info modified>> ] [ rfc822>timestamp ] bi* after?\r
+    ] [\r
+        2drop t\r
+    ] if ;\r
 \r
 : <304> ( -- response )\r
     304 "Not modified" <trivial-response> ;\r
@@ -26,16 +25,17 @@ TUPLE: file-responder root hook special ;
 : <static> ( root -- responder )\r
     [\r
         <content>\r
-        swap\r
-        [ file-info size>> "content-length" set-header ]\r
-        [ file-http-date "last-modified" set-header ]\r
-        [ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
-        tri\r
+        swap [\r
+            file-info\r
+            [ size>> "content-length" set-header ]\r
+            [ modified>> "last-modified" set-header ] bi\r
+        ]\r
+        [ '[ , binary <file-reader> stdio get stream-copy ] >>body ] bi\r
     ] <file-responder> ;\r
 \r
 : serve-static ( filename mime-type -- response )\r
-    over last-modified-matches?\r
-    [ 2drop <304> ] [ file-responder get hook>> call ] if ;\r
+    over modified-since?\r
+    [ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
 \r
 : serving-path ( filename -- filename )\r
     file-responder get root>> right-trim-separators\r
@@ -65,8 +65,7 @@ TUPLE: file-responder root hook special ;
     ] simple-html-document ;\r
 \r
 : list-directory ( directory -- response )\r
-    "text/html" <content>\r
-    swap '[ , directory. ] >>body ;\r
+    '[ , directory. ] <html-content> ;\r
 \r
 : find-index ( filename -- path )\r
     "index.html" append-path dup exists? [ drop f ] unless ;\r

diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index 610ec78fed2ee41c3a6afb1e5ab920a6d638c508..73f6095eae98f8f2467b6d6adbb7422bb55b859e 100644 (file)
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -24,5 +24,4 @@ M: template write-response-body* call-template ;
 
 ! responder integration
 : serve-template ( template -- response )
-    "text/html" <content>
-    swap '[ , call-template ] >>body ;
+    '[ , call-template ] <html-content> ;

diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 76e7a1464aa4ac15f2cbe3e2201ab0b3d3408ee1..144900d6ec8f392a25c1c6c25525f0962ad7e4b8 100644 (file)
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -8,6 +8,7 @@ http.server.actions
 http.server.components
 http.server.components.code
 http.server.templating.chloe
+http.server.auth
 http.server.auth.login
 http.server.boilerplate
 http.server.validators
@@ -236,13 +237,17 @@ annotation "ANNOTATION"
 
 TUPLE: pastebin < dispatcher ;
 
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
 : <pastebin> ( -- responder )
     pastebin new-dispatcher
         <paste-list-action> "list" add-main-responder
         <feed-action> "feed.xml" add-responder
         <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
-                   [ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" add-responder
-                   [ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> <protected> "delete-annotation" add-responder
+        [ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+        [ <annotation> ] "$pastebin/view-paste" { can-delete-pastes? } <delete-annotation-action> <protected> "delete-annotation" add-responder
         <paste-form> [ <paste> ]    <view-paste-action>     "$pastebin/view-paste"   add-responder
         <new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action>     "new-paste"    add-responder
         <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index d3260e1c70772326f23c5658bbef5e07da97b3df..c8aeab35a8f8b865b9a7165ec5653ba26b951229 100755 (executable)
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -11,7 +11,8 @@ http.server.actions
 http.server.boilerplate
 http.server.templating.chloe
 http.server.components
-http.server.auth.login ;
+http.server.auth.login
+http.server.auth ;
 IN: webapps.planet
 
 TUPLE: planet-factor < dispatcher postings ;
@@ -159,11 +160,15 @@ blog "BLOGS"
             blog-form blog-ctor "$planet-factor/admin" <edit-action>   "edit-blog"   add-responder
     ] ;
 
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
 : <planet-factor> ( -- responder )
     planet-factor new-dispatcher
         dup <planet-action> "list" add-main-responder
         dup <feed-action> "feed.xml" add-responder
-        dup <planet-factor-admin> <protected> "admin" add-responder
+        dup <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
     <boilerplate>
         "planet" planet-template >>template ;
 

diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml
index ef1e1fd26adc4eb12264ddc7413f923e6dc4045c..9b7e9e667a0afe10100c000bff3d92607334e318 100644 (file)
--- a/extra/webapps/todo/edit-todo.xml
+++ b/extra/webapps/todo/edit-todo.xml
@@ -4,22 +4,22 @@
 
        <t:title>Edit Item</t:title>
 
-       <t:form action="$todo-list/edit">
-               <t:edit component="id" />
+       <t:form t:action="$todo-list/edit">
+               <t:edit t:component="id" />
 
                <table>
-                       <tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
-                       <tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
-                       <tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+                       <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
+                       <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
+                       <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
                </table>
 
                <input type="SUBMIT" value="Done" />
        </t:form>
 
-       <t:a href="$todo-list/view" query="id">View</t:a>
+       <t:a t:href="$todo-list/view" t:query="id">View</t:a>
        |
-       <t:form action="$todo-list/delete" class="inline">
-               <t:edit component="id" />
+       <t:form t:action="$todo-list/delete" t:class="inline">
+               <t:edit t:component="id" />
                <button type="submit" class="link-button link">Delete</button>
        </t:form>
 

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index e1ebc65bb58ef766f6ed5c4efb28140b8df128dd..8bfda1aad563f862c2b7787f00172748e92c6b26 100755 (executable)
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -76,5 +76,5 @@ TUPLE: todo-list < dispatcher ;
                       ctor "$todo-list/list" <delete-action> "delete" add-responder
         <boilerplate>
             "todo" todo-template >>template
-        <protected>
+        f <protected>
     ] ;

diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml
index f77396c73c39dd834e34daa087b72cd4646e06e3..1bd73f48e1f0e271d6bfe663f0344af62d7def40 100644 (file)
--- a/extra/webapps/todo/view-todo.xml
+++ b/extra/webapps/todo/view-todo.xml
@@ -5,8 +5,8 @@
        <t:title>View Item</t:title>
 
        <table>
-               <tr><th class="field-label">Summary:    </th><td><t:view component="summary"     /></td></tr>
-               <tr><th class="field-label">Priority:   </th><td><t:view component="priority"    /></td></tr>
+               <tr><th class="field-label">Summary:    </th><td><t:view t:component="summary"     /></td></tr>
+               <tr><th class="field-label">Priority:   </th><td><t:view t:component="priority"    /></td></tr>
        </table>
 
        <div class="description">